summaryrefslogtreecommitdiff
path: root/src/Control/Funflow/Diagram.hs
diff options
context:
space:
mode:
authornclarke <>2018-05-08 13:34:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-05-08 13:34:00 (GMT)
commit4aade684e6d16c8fcb22b0364de3d79cf9731f45 (patch)
tree260ecfebcca36a7a1bcf106651c2072a9d334aae /src/Control/Funflow/Diagram.hs
version 1.0.01.0.0
Diffstat (limited to 'src/Control/Funflow/Diagram.hs')
-rw-r--r--src/Control/Funflow/Diagram.hs59
1 files changed, 59 insertions, 0 deletions
diff --git a/src/Control/Funflow/Diagram.hs b/src/Control/Funflow/Diagram.hs
new file mode 100644
index 0000000..9581911
--- /dev/null
+++ b/src/Control/Funflow/Diagram.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- | A Diagram is a representation of an arrow with labels.
+-- No computation is actually performed by a diagram, it just carries
+-- around a description.
+-- We explot the fact that in 7.10,
+-- everything is typeable to label the incoming and outgoing node types.
+module Control.Funflow.Diagram where
+
+import Control.Arrow
+import Control.Arrow.Free (ArrowError (..))
+import Control.Category
+import Data.Proxy (Proxy (..))
+import qualified Data.Text as T
+import Prelude hiding (id, (.))
+
+
+newtype NodeProperties = NodeProperties {
+ labels :: [T.Text]
+}
+
+emptyNodeProperties :: NodeProperties
+emptyNodeProperties = NodeProperties []
+
+data Diagram ex a b where
+ Node :: NodeProperties
+ -> Proxy a
+ -> Proxy b
+ -> Diagram ex a b
+ Seq :: Diagram ex a b -> Diagram ex b c -> Diagram ex a c
+ Par :: Diagram ex a b -> Diagram ex c d -> Diagram ex (a,c) (b,d)
+ Fanin :: Diagram ex a c -> Diagram ex b c -> Diagram ex (Either a b) c
+ Catch :: Diagram ex a b -> Diagram ex (a,ex) b -> Diagram ex a b
+
+instance Category (Diagram ex) where
+ id = Node emptyNodeProperties Proxy Proxy
+ (.) = flip Seq
+
+instance Arrow (Diagram ex) where
+ arr :: forall a b. (a -> b) -> Diagram ex a b
+ arr = const $ Node emptyNodeProperties (Proxy :: Proxy a) (Proxy :: Proxy b)
+ first f = Par f id
+ second f = Par id f
+ (***) = Par
+
+instance ArrowChoice (Diagram ex) where
+ f +++ g = (f >>> arr Left) ||| (g >>> arr Right)
+ f ||| g = Fanin f g
+
+instance ArrowError ex (Diagram ex) where
+ f `catch` g = Catch f g
+
+-- | Construct a labelled node
+node :: forall arr a b ex. Arrow arr => arr a b -> [T.Text] -> (Diagram ex) a b
+node _ lbls = Node props (Proxy :: Proxy a) (Proxy :: Proxy b)
+ where props = NodeProperties lbls