{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
Try :: Diagram ex a b -> Diagram ex a (Either ex 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
try = Try
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