|
| 1 | +{-# LANGUAGE ExistentialQuantification #-} |
| 2 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 3 | +{-# LANGUAGE PatternGuards #-} |
| 4 | +{-# LANGUAGE BangPatterns #-} |
| 5 | +{-# LANGUAGE RecordWildCards #-} |
| 6 | +{-# LANGUAGE TupleSections #-} |
| 7 | +{-# LANGUAGE DeriveDataTypeable #-} |
| 8 | +{-# LANGUAGE DeriveGeneric #-} |
| 9 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 10 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 11 | +{-# LANGUAGE GADTs #-} |
| 12 | +{-# LANGUAGE RankNTypes #-} |
| 13 | + |
| 14 | +module Control.Distributed.Process.FSM where |
| 15 | + |
| 16 | +import Control.Distributed.Process (Process) |
| 17 | +import Control.Distributed.Process.Extras |
| 18 | + ( ExitReason(ExitShutdown) |
| 19 | + ) |
| 20 | +import Control.Distributed.Process.Extras.Time |
| 21 | + ( TimeInterval |
| 22 | + , seconds |
| 23 | + ) |
| 24 | +import Control.Distributed.Process.Serializable (Serializable) |
| 25 | +import Control.Monad (void) |
| 26 | +import Control.Monad.Fix (MonadFix) |
| 27 | +import Control.Monad.IO.Class (MonadIO) |
| 28 | +import qualified Control.Monad.State.Strict as ST |
| 29 | + ( MonadState |
| 30 | + , StateT |
| 31 | + , get |
| 32 | + , lift |
| 33 | + , runStateT |
| 34 | + ) |
| 35 | +import Data.Binary (Binary) |
| 36 | +import Data.Typeable (Typeable) |
| 37 | +import GHC.Generics |
| 38 | + |
| 39 | +data State s d m = State |
| 40 | + |
| 41 | +newtype FSM s d m o = FSM { |
| 42 | + unFSM :: ST.StateT (State s d m) Process o |
| 43 | + } |
| 44 | + deriving ( Functor |
| 45 | + , Monad |
| 46 | + , ST.MonadState (State s d m) |
| 47 | + , MonadIO |
| 48 | + , MonadFix |
| 49 | + , Typeable |
| 50 | + , Applicative |
| 51 | + ) |
| 52 | + |
| 53 | +data Action = Consume | Produce | Skip |
| 54 | +data Transition s m = Remain | PutBack m | Change s |
| 55 | +data Event m = Event |
| 56 | + |
| 57 | +data Step s d where |
| 58 | + Start :: s -> d -> Step s d |
| 59 | + Await :: (Serializable m) => Event m -> Step s d -> Step s d |
| 60 | + Always :: FSM s d m (Transition s d) -> Step s d |
| 61 | + Perhaps :: (Eq s) => s -> FSM s d m (Transition s d) -> Step s d |
| 62 | + Matching :: (m -> Bool) -> FSM s d m (Transition s d) -> Step s d |
| 63 | + Sequence :: Step s d -> Step s d -> Step s d |
| 64 | + Alternate :: Step s d -> Step s d -> Step s d |
| 65 | + Reply :: (Serializable r) => FSM s f m r -> Step s d |
| 66 | + |
| 67 | +type Pipeline = forall s d . Step s d |
| 68 | + |
| 69 | +initState :: forall s d . s -> d -> Step s d |
| 70 | +initState = Start |
| 71 | + |
| 72 | +-- endState :: Action -> State |
| 73 | +-- endState = undefined |
| 74 | + |
| 75 | +enter :: forall s d m . s -> FSM s d m (Transition s d) |
| 76 | +enter = undefined |
| 77 | + |
| 78 | +stopWith :: ExitReason -> Action |
| 79 | +stopWith = undefined |
| 80 | + |
| 81 | +event :: (Serializable m) => Event m |
| 82 | +event = Event |
| 83 | + |
| 84 | +currentState :: forall s d m . FSM s d m s |
| 85 | +currentState = undefined |
| 86 | + |
| 87 | +reply :: forall s d m r . (Serializable r) => FSM s d m r -> Step s d |
| 88 | +reply = Reply |
| 89 | + |
| 90 | +timeout :: Serializable a => TimeInterval -> a -> FSM s d m (Transition s d) |
| 91 | +timeout = undefined |
| 92 | + |
| 93 | +set :: forall s d m . (d -> d) -> FSM s d m () |
| 94 | +set = undefined |
| 95 | + |
| 96 | +put :: forall s d m . d -> FSM s d m () |
| 97 | +put = undefined |
| 98 | + |
| 99 | +(.|) :: Step s d -> Step s d -> Step s d |
| 100 | +(.|) = Alternate |
| 101 | +infixr 9 .| |
| 102 | + |
| 103 | +(|>) :: Step s d -> Step s d -> Step s d |
| 104 | +(|>) = Sequence |
| 105 | +infixr 9 |> |
| 106 | + |
| 107 | +(<|) :: Step s d -> Step s d -> Step s d |
| 108 | +(<|) = undefined |
| 109 | +infixr 9 <| |
| 110 | + |
| 111 | +(~>) :: forall s d m . (Serializable m) => Event m -> Step s d -> Step s d |
| 112 | +(~>) = Await |
| 113 | +infixr 9 ~> |
| 114 | + |
| 115 | +(~@) :: forall s d m . (Eq s) => s -> FSM s d m (Transition s d) -> Step s d |
| 116 | +(~@) = Perhaps |
| 117 | +infixr 9 ~@ |
| 118 | + |
| 119 | +allState :: forall s d m . FSM s d m (Transition s d) -> Step s d |
| 120 | +allState = Always |
| 121 | + |
| 122 | +(~?) :: forall s d m . (m -> Bool) -> FSM s d m (Transition s d) -> Step s d |
| 123 | +(~?) = Matching |
| 124 | + |
| 125 | +start :: Pipeline -> Process () |
| 126 | +start = const $ return () |
| 127 | + |
| 128 | +data StateName = On | Off deriving (Eq, Show, Typeable, Generic) |
| 129 | +instance Binary StateName where |
| 130 | + |
| 131 | +data Reset = Reset deriving (Eq, Show, Typeable, Generic) |
| 132 | +instance Binary Reset where |
| 133 | + |
| 134 | +type StateData = Integer |
| 135 | +type ButtonPush = () |
| 136 | +type Stop = ExitReason |
| 137 | + |
| 138 | +initCount :: StateData |
| 139 | +initCount = 0 |
| 140 | + |
| 141 | +startState :: Step StateName Integer |
| 142 | +startState = initState Off initCount |
| 143 | + |
| 144 | +demo :: Step StateName StateData |
| 145 | +demo = startState |
| 146 | + |> (event :: Event ButtonPush) |
| 147 | + ~> ( (On ~@ (set (+1) >> enter Off)) |
| 148 | + .| (Off ~@ (set (+1) >> enter On)) |
| 149 | + ) <| (reply currentState) |
| 150 | + .| (event :: Event Stop) |
| 151 | + ~> ((== ExitShutdown) ~? (timeout (seconds 3) Reset)) |
| 152 | + .| (event :: Event Reset) ~> (allState $ put initCount >> enter Off) |
| 153 | +-- .| endState $ stopWith ExitNormal |
0 commit comments