Diagrams

src/AFRP/Diagram.hs

@@ -0,0 +1,44 @@
+module AFRP.Diagram where
+import Data.Text (Text)
+import qualified Text.Printf as Text
+import qualified Data.Text as T
+
+-- For rendering the arrows
+data DiagramF f
+  = Empty
+  | Step Text f -- Named step
+  | Then f f -- >>>
+  | Both f f -- &&&
+  | Branch f f -- |||
+  | Merge f f -- <>
+  | Compose f f -- <*>
+
+type DiagramAlgebra a = DiagramF a -> a
+type DiagramC= forall a. DiagramAlgebra a -> a
+
+combineDiagram :: (forall a. a -> a -> DiagramF a) -> DiagramC -> DiagramC -> DiagramC
+combineDiagram constructor a b r = r (constructor (a r) (b r))
+
+emptyDiagram :: DiagramC
+emptyDiagram r = r Empty
+
+
+renderF :: DiagramF (Maybe String) -> Maybe String
+renderF = \case
+  Empty -> Nothing
+  Step n x -> Just $ T.unpack n <> maybe "" (Text.printf "( %s )") x
+  Then (Just a) (Just b) -> Just $ a <> " -> " <> b
+  Then (Just a) _ -> Just a
+  Then _ b -> b
+  Both (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Both (Just a) _ -> Just a
+  Both _ b -> b
+  Branch (Just a) (Just b) -> Just $ Text.printf "(%s || %s)" a b
+  Branch (Just a) Nothing -> Just $ Text.printf "(%s || <skip>)" a
+  Branch _ b -> b
+  Merge (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Merge (Just a) _ -> Just a
+  Merge _ b -> b
+  Compose (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Compose (Just a) _ -> Just a
+  Compose _ b -> b