statechart.hs

{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE ViewPatterns               #-}

module StateChart
  ( SC(SC)
  , S(..)
  , transition
  , run
  , dot
  , dog_example
  ) where

import Control.Applicative (liftA2)
import Data.List (find)

newtype SC m e s = SC
  { lookupS :: s -> S m e s
  }

data Transition e s = Transition
  { t_event :: e
  , t_state :: s
  }
  deriving (Eq, Ord, Show)


transition :: e -> s -> [Transition e s]
transition e s = pure $ Transition e s


data S m e s where
  Effect      :: (Show a, Enum a, Bounded a) => String -> m a -> (a -> s) -> S m e s
  Transitions :: [Transition e s] -> S m e s
  Empty       :: S m e s


pushS :: (Monad m, Eq e, Eq s) => SC m e s -> e -> s -> m s
pushS sc e0 s = pump sc =<< go (lookupS sc s) e0
  where
    go (Effect _ ma fas) e = ma >>= pushS sc e . fas
    go (Transitions ts) e =
      case find ((== e) . t_event) ts of
        Just (Transition _ s') -> pure s'
        Nothing -> pure s
    go Empty _ = pure s


pump :: (Eq s, Monad m) => SC m e s -> s -> m s
pump sc s = case lookupS sc s of
  Effect _ ma fas -> ma >>= pump sc . fas
  _ -> pure s


run :: (Monad m, Monad m, Eq e, Eq s) => SC m e s -> s -> [e] -> m s
run sc s = foldr (\e ms -> ms >>= pushS sc e) (pure s)


dot :: (Enum s, Bounded s, Show s, Show e) => SC m e s -> String
dot sc = mconcat [ "digraph statechart {", unlines $ dotSC sc, "}" ]


dotSC :: forall m e s. (Enum s, Bounded s, Show s, Show e) => SC m e s -> [String]
dotSC (SC sm) = foldMap (liftA2 dotS id sm) [minBound @s .. maxBound]


mkArr :: String -> String -> String -> String
mkArr s s' e = mconcat [ s , " -> " , s' , " [label=\"" , e , "\"];" ]


dotS :: forall m e s. (Show s, Show e) => s -> S m e s -> [String]
dotS s (Effect lbl (_ :: m a) fas) =
  mkArr (show s) (show lbl) ""
    : fmap (\a -> mkArr (show lbl) (show $ fas a) $ show a)
           [minBound @a .. maxBound]
dotS s (Transitions ts) =
  foldMap (\(Transition e s') -> pure $ mkArr (show s) (show s') (show e)) ts
dotS _ Empty = mempty


------------------------------------------------------------------------------


data States = Idle | Loading | Resolved | Rejected
  deriving (Eq, Ord, Show, Enum, Bounded)

data Event = FETCH | CANCEL
  deriving (Eq, Ord, Show, Enum, Bounded)


dog_example :: SC IO Event States
dog_example = SC \case
  Idle ->
    Transitions $ mconcat
      [ transition FETCH Loading
      , transition CANCEL Rejected
      ]
  Loading ->
    Effect  "Compare /tmp/test with 5"
      (fmap (compare @Int 5 . read) $ readFile "/tmp/test")
      \case
        GT -> Idle
        EQ -> Resolved
        LT -> Rejected
  Rejected -> Transitions $
    transition FETCH Loading
  Resolved ->
    Empty

{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE ViewPatterns               #-}

{-# OPTIONS_GHC -Wall        #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module StateChart where

import           Control.Applicative (liftA)
import           Control.Monad
import           Data.Map (Map)
import qualified Data.Map as M


instance (Bounded b, Enum a, Enum b) => Enum (a, b) where
  fromEnum (a, b) = (fromEnum (maxBound @b) + 1) * fromEnum a + fromEnum b
  toEnum n =
    let bound = fromEnum (maxBound @b) + 1
        b = n `rem` bound
        a = n `div` bound
     in (toEnum a, toEnum b)

data Node m e s a where
  Terminal :: a -> Node m e s a
  Goto :: s -> (e -> Node m e s a) -> Node m e s a
  Invoke :: (Bounded x, Enum x, Show x) => s -> String -> m x -> (x -> Node m e s a) -> Node m e s a

instance Functor (Node m e s) where
  fmap = liftA

instance Applicative (Node m e s) where
  pure = Terminal
  (<*>) = ap

instance Monad (Node m e s) where
  (>>=) (Terminal a) fanmesb = fanmesb a
  (>>=) (Goto s fenmesa) fanmesb = Goto s $ fmap (fanmesb =<<) fenmesa
  (>>=) (Invoke s lbl mx fxnmesa) fanmesb = Invoke s lbl mx $ fmap (fanmesb =<<) fxnmesa


run :: (Ord s, Monad m) => s -> StateChart m e s -> [e] -> m (Either s s)
run s sc es = go es (knot s sc)

go :: Monad m => [e] -> Node m e s s -> m (Either s s)
go [] nmess = pure $ currentState nmess
go (e : l_e3) nmess  = either (go l_e3) (pure . Right) =<< runNode nmess e

runNode :: Monad m => Node m e s a -> e -> m (Either (Node m e s a) a)
runNode n e = runInvoke n >>= \case
   (Terminal a) -> pure $ Right a
   (Goto _ fenmesa) -> fmap Left $ runInvoke $ fenmesa e
   Invoke{} -> error "impossible"

currentState :: Node m e s a -> Either s a
currentState (Terminal a) = Right a
currentState (Goto s _) = Left s
currentState (Invoke s _ _ _) = Left s


runInvoke :: Monad m => Node m e s a -> m (Node m e s a)
runInvoke (Invoke _ _ mx fxnmesa) = runInvoke . fxnmesa =<< mx
runInvoke m = pure m


arr :: (Show src, Show dst, Show e) => src -> dst -> Maybe e -> String
arr s s' e = arr' (show s) (show s') (fmap show e)


arr' :: String -> String -> Maybe String -> String
arr' s s' (Just e) = mconcat
  [ s , " -> " , s' , " [label=" , e , "];" ]
arr' s s' Nothing = mconcat
  [ s , " -> " , s' , " [style=dotted];" ]



inspect :: (Bounded e, Enum e, Show e, Show s) => StateChart m e s -> String
inspect sc
  = unlines
  . flip mappend ["}"]
  . ("digraph x {" :)
  . foldMap (snd . inspect')
  . M.elems
  $ unStateChart sc


node :: Show s => s -> Maybe String -> String
node _ Nothing = mempty
node lbl (Just l_c) = mconcat [ show lbl, " [shape=", l_c, "];" ]


inspect' :: (Bounded e, Enum e, Show e, Show s) => Node m e s s -> (s, [String])
inspect' (Terminal a) = (a, mempty)
inspect' (Goto s fenmesa) = (s,) $ do
  e <- [minBound .. maxBound]
  let (s', sub) = inspect' $ fenmesa e
  arr s s' (Just e) : sub
inspect' (Invoke s lbl _ fxnmesa) =
  (s,) $ node lbl (Just "box") : arr s lbl (Nothing @()) : do
    x <- [minBound .. maxBound]
    let (s', sub) = inspect' $ fxnmesa x
    arr lbl (show s') (Just $ show x) : sub


data States = Idle | Loading | Resolved | Rejected
  deriving (Eq, Ord, Show, Enum, Bounded)

data Event = FETCH | CANCEL
  deriving (Eq, Ord, Show, Enum, Bounded)

newtype StateChart m e s = StateChart
  { unStateChart :: Map s (Node m e s s)
  } deriving newtype (Semigroup, Monoid)



transition :: s -> (e -> s) -> StateChart m e s
transition s f = StateChart $ M.singleton s $ Goto s $ fmap pure f


invoke
    :: (Enum x, Bounded x, Show x)
    => s -> String -> m x -> (x -> s) -> StateChart m e s
invoke s lbl m f = StateChart $ M.singleton s $ Invoke s lbl m $ fmap pure f


knot :: Ord s => s -> StateChart m e s -> Node m e s s
knot s0 m =
  case M.lookup s0 $ unStateChart m of
    Nothing -> pure s0
    Just n -> n >>= flip knot m


cat :: StateChart IO Event States
cat =
  mconcat
    [ transition Idle $ \case
        FETCH  -> Loading
        CANCEL -> Rejected
    , invoke Loading "Compare /tmp/test with 5"
        (fmap (compare @Int 5 . read) $ readFile "/tmp/test") $ \case
          LT -> Rejected
          EQ -> Resolved
          GT -> Idle
    , transition Rejected $ \case
        FETCH -> Loading
        _ -> Rejected
    ]