version 1.0.01.0.0

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