module Medium.LabeledControlled.List where
import qualified Medium.Controlled.List as CtrlMediumList
import qualified Medium.Controlled as CtrlMedium
import qualified Medium
import Control.Applicative (liftA, )
import Data.Foldable (Foldable(foldMap))
import Data.Traversable (Traversable(sequenceA))
import qualified Data.Traversable as Traversable
data T label control content =
Cons {label :: label,
structure :: Structure label control content}
deriving (Show, Eq, Ord )
data Structure label control content =
Primitive content
| Serial [T label control content]
| Parallel [T label control content]
| Control control (T label control content)
deriving (Show, Eq, Ord )
class Label label where
emptyLabel :: label
foldLabelSerial :: [label] -> label
foldLabelParallel :: [label] -> label
serialLabel, parallelLabel :: Label label =>
[T label control content] -> T label control content
serialLabel xs = Cons (foldLabelSerial (map label xs)) (Serial xs)
parallelLabel xs = Cons (foldLabelParallel (map label xs)) (Parallel xs)
instance (Label label) => Medium.Construct (T label control) where
prim = Cons emptyLabel . Primitive
(+:+) x y = serialLabel (serialToList x ++ serialToList y)
(=:=) x y = parallelLabel (parallelToList x ++ parallelToList y)
serial1 = serialLabel
parallel1 = parallelLabel
serial = serialLabel
parallel = parallelLabel
switchList ::
(label -> b -> c) ->
(a -> b) ->
([T label control a] -> b) ->
([T label control a] -> b) ->
(control -> T label control a -> b) ->
(T label control a -> c)
switchList lab f g h k (Cons l s) =
lab l $
case s of
Primitive x -> f x
Serial m -> g m
Parallel m -> h m
Control c m -> k c m
foldList ::
(label -> b -> c) ->
(a -> b) ->
([c] -> b) ->
([c] -> b) ->
(control -> c -> b) ->
(T label control a -> c)
foldList lab f g h k =
let recourse = foldList lab f g h k
in switchList lab f
(g . map recourse) (h . map recourse) (\c -> k c . recourse)
fromControlledMediumList :: Label label =>
(a -> (label, b)) -> (control -> T label control b -> label) ->
CtrlMediumList.T control a -> T label control b
fromControlledMediumList f k =
CtrlMedium.foldList
((\(lab,x) -> Cons lab (Primitive x)) . f)
serialLabel
parallelLabel
(\c x -> Cons (k c x) (Control c x))
mapLabel :: (i -> j) -> (T i control a -> T j control a)
mapLabel f =
foldList (Cons . f) Primitive Serial Parallel Control
instance Functor (T i control) where
fmap f = foldList Cons (Primitive . f) Serial Parallel Control
instance Foldable (T i control) where
foldMap = Traversable.foldMapDefault
instance Traversable (T i control) where
sequenceA =
foldList
(liftA . Cons)
(liftA Primitive)
(liftA Serial . sequenceA)
(liftA Parallel . sequenceA)
(liftA . Control)
serialToList, parallelToList :: T label control a -> [T label control a]
serialToList (Cons _ (Serial ns)) = ns
serialToList n = [n]
parallelToList (Cons _ (Parallel ns)) = ns
parallelToList n = [n]