motor 0.2.0.0 → 0.3.0
raw patch · 10 files changed
+324/−224 lines, 10 filesdep +row-typesdep −CTRexdep ~basenew-component:exe:example-door
Dependencies added: row-types
Dependencies removed: CTRex
Dependency ranges changed: base
Files
- CHANGELOG.md +10/−0
- examples/Door.hs +156/−0
- motor.cabal +19/−5
- src/Motor/FSM.hs +43/−27
- src/Motor/FSM/Class.hs +19/−5
- src/Motor/FSM/Logging.hs +2/−2
- src/Motor/FSM/Sugar.hs +54/−27
- src/Motor/FSM/TH.hs +0/−142
- test/Motor/FSMSpec.hs +4/−4
- test/Motor/FSMSpec/Game.hs +17/−12
CHANGELOG.md view
@@ -1,3 +1,13 @@+* 0.3.0+ - Use row-types instead of CTRex.+ - Rename `:->` operator to `:=`.+ - Provide better default constraints from using `Actions`.+ - Make `Actions` a data type and use it promoted.+ - Add `Remain` action.+ - Add `get` operator, returning the current state of a named+ resource.+ - Add `update` operator, mapping an update function over the current+ state of a named resource. * 0.2.0.0 - Add `motor-reflection` and `motor-diagrams` packages. * 0.1.1.0
+ examples/Door.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Prelude++import Control.Concurrent (threadDelay)+import Control.Monad.Indexed+import Control.Monad.IO.Class+import Data.Row.Records+import GHC.OverloadedLabels++import Motor.FSM++-- * Protocol (Abstract state types)++-- We only use marker types for states in the Door protocol.+data Open+data Closed++class MonadFSM m => Door m where+ -- The associated type lets the instance choose the concrete state+ -- data type.+ type State m :: * -> *++ -- Events:+ initial :: Name n -> Actions m '[ n !+ State m Closed ] r ()+ open :: Name n -> Actions m '[ n := State m Closed !--> State m Open ] r ()+ close :: Name n -> Actions m '[ n := State m Open !--> State m Closed ] r ()+ end :: Name n -> Actions m '[ n !- State m Closed ] r ()++-- * Implemention (Concrete types)+--+-- This could be in another module, hiding the constructors.++newtype ConsoleDoor m (i :: Row *) (o :: Row *) a =+ ConsoleDoor { runConsoleDoor :: FSM m i o a }+ deriving (IxFunctor, IxPointed, IxApplicative, IxMonad, MonadFSM)++run :: Monad m => ConsoleDoor m Empty Empty () -> m ()+run = runFSM . runConsoleDoor++deriving instance Monad m => Functor (ConsoleDoor m i i)+deriving instance Monad m => Applicative (ConsoleDoor m i i)+deriving instance Monad m => Monad (ConsoleDoor m i i)++instance (MonadIO m) => MonadIO (ConsoleDoor m i i) where+ liftIO = ConsoleDoor . liftIO++data DoorState s where+ Open :: DoorState Open+ Closed :: DoorState Closed++instance Show (DoorState s) where+ show Open = "Open"+ show Closed = "Closed"++logLn :: (MonadIO m) => String -> m ()+logLn = liftIO . putStrLn++logDoor :: (MonadIO m, HasType n (DoorState s) i) => Name n -> ConsoleDoor m i i ()+logDoor n =+ get n+ >>>= \s -> logLn ("Door is now " ++ show s)++-- Extremely boring implementation:+instance (MonadIO m) => Door (ConsoleDoor m) where+ type State (ConsoleDoor m) = DoorState+ initial n = new n Closed+ open n = enter n Open >>> logDoor n+ close n = enter n Closed >>> logDoor n+ end = delete++-- * Runner Program++-- This uses the protocol to define a program using the Door protocol.++sleep :: (MonadIO (m i i)) => Int -> m (i :: Row *) (i :: Row *) ()+sleep seconds = liftIO (threadDelay (seconds * 1000000))++confirm :: (MonadIO (m i i)) => String -> m (i :: Row *) (i :: Row *) Bool+confirm s = liftIO (putStrLn s >> ("y" ==) <$> getLine)++type OpenAndClose m n o c =+ ( Door m+ -- TODO: Can these constraints be added to the Sugar module+ -- automatically?+ , Modify n (State m Open) c ~ o+ , Modify n (State m Closed) o ~ c+ , (o .! n) ~ State m Open+ , (c .! n) ~ State m Closed+ , (o .- n) ~ (c .- n)+ )++type OpenAndCloseIO m n o c =+ ( OpenAndClose m n o c+ , MonadIO (m o o)+ , MonadIO (m c c)+ )++inClosed :: OpenAndCloseIO m n o c => Name n -> m c (c .- n) ()+inClosed door = confirm "Open door?" >>>= \case+ True -> open door >>>= const (inOpen door)+ False -> end door++inOpen :: OpenAndCloseIO m n o c => Name n -> m o (o .- n) ()+inOpen door = confirm "The door must be closed. OK?" >>>= \case+ True -> close door >>>= const (inClosed door)+ False -> inOpen door++-- The program initializes a door, and starts the looping between+-- open/closed.+main :: IO ()+main = run $ initial #door >>>= const (inClosed #door)++{- $example-run++Running this program can look like this:++>>> main+Open door?+y+Door is now Open+The door must be closed. OK?+y+Door is now Closed+Open door?+y+Door is now Open+The door must be closed. OK?+n+The door must be closed. OK?+n+The door must be closed. OK?+n+The door must be closed. OK?+y+Door is now Closed+Open door?+n+-}
motor.cabal view
@@ -1,5 +1,5 @@ name: motor-version: 0.2.0.0+version: 0.3.0 synopsis: Type-safe effectful state machines in Haskell description:@@ -29,14 +29,13 @@ , Motor.FSM.Class , Motor.FSM.Sugar , Motor.FSM.Logging- , Motor.FSM.TH -- other-modules: -- other-extensions:- build-depends: CTRex- , base >=4.9 && <5+ build-depends: base >=4.9 && <5 , indexed , indexed-extras , reflection+ , row-types , template-haskell >= 2.11.1.0 hs-source-dirs: src default-language: Haskell2010@@ -52,7 +51,22 @@ build-depends: base , indexed , indexed-extras- , CTRex+ , row-types+ , motor+ ghc-options: -Wall+ -fno-warn-orphans+ -fno-warn-missing-signatures+ -fno-warn-unticked-promoted-constructors+ -fno-warn-name-shadowing+ default-language: Haskell2010++executable example-door+ hs-source-dirs: examples+ main-is: Door.hs+ build-depends: base+ , indexed+ , indexed-extras+ , row-types , motor ghc-options: -Wall -fno-warn-orphans
src/Motor/FSM.hs view
@@ -39,9 +39,10 @@ , Name (..) -- ** State Actions- , (:->)- , To, Add, Delete+ , Action (..)+ , ActionMapping (..) , FromActions, NoActions, Actions , OnlyActions+ , Get -- ** Aliases , type (!-->)@@ -50,13 +51,19 @@ -- ** FSM , FSM, runFSM++ -- * Indexed Monad Utilities+ , (>>>)++ , module Control.Monad.Indexed ) where import Control.Monad.IO.Class import Control.Monad.Indexed import Control.Monad.Indexed.State import Control.Monad.Indexed.Trans-import Data.OpenRecords+import Data.Functor.Identity (runIdentity)+import Data.Row.Records import Motor.FSM.Class import Motor.FSM.Sugar@@ -108,15 +115,21 @@ runFSM (FSM f) = fst <$> runIxStateT f empty instance Monad m => MonadFSM (FSM m) where- new (Name :: Name n) x = FSM (imodify ((lbl := x) .|))+ new (Name :: Name n) x = FSM (imodify (extend lbl x)) where lbl = Label :: Label n+ get (Name :: Name n) = FSM (igets (.! lbl))+ where+ lbl = Label :: Label n delete (Name :: Name n) = FSM (imodify (.- lbl)) where lbl = Label :: Label n- enter (Name :: Name n) x = FSM (imodify $ \s -> lbl := x .| (s .- lbl))+ update (Name :: Name n) f = FSM (imodify $ \s -> runIdentity (focus lbl (pure . f) s)) where lbl = Label :: Label n+ enter (Name :: Name n) x = FSM (imodify $ \s -> runIdentity (focus lbl (const (pure x)) s))+ where+ lbl = Label :: Label n call (FSM ma) = FSM (ilift (fst <$> runIxStateT ma empty)) {- $usage@@ -145,7 +158,7 @@ with state @Idle@ could have the following type: >>> :t newConn-newConn :: MonadFSM m => m r ("connection" ::= Idle :| r) ()+newConn :: MonadFSM m => m r (Extend "connection" Idle r) () A computation @spawnTwoPlayers@ that adds two resources could have this type:@@ -153,10 +166,10 @@ >>> :t spawnTwoPlayers spawnTwoPlayers :: :: MonadFSM m =>- m r ("hero2" ::= Standing :| "hero1" ::= Standing :| r) ()+ m r (Extend "hero2" Standing (Extend "hero1" Standing r)) () -Motor uses the extensible records in "Data.OpenRecords", provided by-the [CTRex](https://wiki.haskell.org/CTRex) library, for row kinds.+Motor uses the extensible records in "Data.Row.Records", provided by+the [row-types](https://wiki.haskell.org/row-types) library, for row kinds. Have a look at it's documentation to learn more about the type-level operators available for rows. @@ -166,8 +179,7 @@ {- $indexed-monads As mentioned above, 'MonadFSM' is an indexed monad. It uses the-definition from "Control.Monad.Indexed", in the-[indexed](https://hackage.haskell.org/package/indexed-0.1.3)+definition from "Control.Monad.Indexed", in the [indexed](https://hackage.haskell.org/package/indexed-0.1.3) package. This means that you can use 'ibind' and friends to compose FSM computations. @@ -196,31 +208,35 @@ -} +(>>>) :: IxMonad m => m i j a -> m j k b -> m i k b+(>>>) a = (>>>=) a . const+ {- $state-actions To make it easier to read and write FSM computation types, there is some syntax sugar available. /State actions/ allow you two describe state changes of named resources with a /single/ list, as opposed two writing two rows. They-also take care of matching the CTRex row combinators with the-expectations of Motor, which can be tricky to do by hand.+also take care of building the correct row types and constraints for Motor, which+can be tricky to do by hand. -There are three state actions:+There are three state 'Action's: * 'Add' adds a new resource.+* 'Remain' keeps an existing resource in the same state. * 'To' transitions the state of a resource. * 'Delete' deletes an existing resource. -A mapping between a resource name is written using the `:->` type operator,+A mapping between a resource name is written using the `:=` type operator, with a `Symbol` on the left, and a state action type on the right. Here are some examples: @-"container" :-> Add Empty+"container" := Add Empty -"list" :-> To Empty NonEmpty+"list" := To Empty NonEmpty -"game" :-> Delete GameEnded+"game" := Delete GameEnded @ So, the list of mappings from resource names to state actions describe@@ -229,7 +245,7 @@ FSM computation using the 'Actions' type: @-MonadFSM m => Actions m '[ n1 :-> a1, n2 :-> a2, ... ] r a+MonadFSM m => Actions m '[ n1 := a1, n2 := a2, ... ] r a @ A computation that adds two resources could have the following type:@@ -237,7 +253,7 @@ @ addingTwoThings :: MonadFSM m =>- Actions m '[ "container" :-> Add Empty, "game" :-> Add Started ] r ()+ Actions m '[ "container" := Add Empty, "game" := Add Started ] r () @ -} @@ -250,7 +266,7 @@ @ useStateMachines :: MonadFSM m =>- Actions m '[ "program" :-> NotCool !--> Cool ] r ()+ Actions m '[ "program" := NotCool !--> Cool ] r () @ The `!+` and `!-` are infix aliases for mappings from resource names to `Add`@@ -269,17 +285,17 @@ {- $row-polymorphism -Because of how CTRex works, FSM computations that have a free variable as-their input row of resources, i.e. that are polymorphic in the sense of-other resource states, must list /all their actions in reverse order/.+Because of how the row polymorphism implementation works, FSM computations that+are polymorphic (in the sense of other resource states) must list /all their actions in order/.+This limitation will hopefully be addressed soon. @ doFourThings :: Game m- => Actions m '[ "hero2" !- Standing- , "hero1" !- Standing+ => Actions m '[ "hero1" !+ Standing , "hero2" !+ Standing- , "hero1" !+ Standing+ , "hero1" !- Standing+ , "hero2" !- Standing ] r () doFourThings = spawn hero1
src/Motor/FSM/Class.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-}@@ -19,7 +20,8 @@ ) where import Control.Monad.Indexed-import Data.OpenRecords+import Data.Row.Records+import GHC.OverloadedLabels import GHC.TypeLits (Symbol) -- * FSM monad@@ -27,16 +29,28 @@ -- | An indexed monad for finite-state machines, managing the state -- of named resources. class IxMonad m => MonadFSM (m :: (Row *) -> (Row *) -> * -> *) where- -- | Creates a new resource and returns its 'Name'.+ -- | Creates a new resource by name. new :: Name n -> a -> m r (Extend n a r) ()+ -- | Returns an existing resource.+ get :: HasType n a r => Name n -> m r r a -- | Deletes an existing resource named by its 'Name'.- delete :: Name n -> m r (r :- n) ()+ delete :: Name n -> m r (r .- n) () -- | Replaces the state of an existing resource named by its 'Name'.- enter :: Name n -> b -> m r (n ::= b :| (r :- n)) ()- -- | Run another 'MonadFSM' computation, with empty resource rows,+ enter ::+ (HasType n a r, Modify n b r ~ r')+ => Name n+ -> b+ -> m r r' ()+ -- | Updates the state, using a pure function, of an existing+ -- resource named by its 'Name'.+ update :: (HasType n a r, Modify n a r ~ r) => Name n -> (a -> a) -> m r r ()+ -- | Embed another 'MonadFSM' computation, with empty resource rows, -- in this computation. call :: m Empty Empty a -> m r r a -- | A name of a resource, represented using a 'Symbol'. data Name (n :: Symbol) where Name :: KnownSymbol n => Name n++instance (KnownSymbol n, n ~ n') => IsLabel n (Name n') where+ fromLabel = Name :: Name n'
src/Motor/FSM/Logging.hs view
@@ -6,14 +6,14 @@ module Motor.FSM.Logging where import Control.Monad.IO.Class-import Data.OpenRecords+import Data.Row.Records import Data.Proxy import Data.Reflection import Motor.FSM log ::- (MonadIO (m i i), KnownSymbol n, Reifies n String)+ (MonadIO (m i i), KnownSymbol n) => Name n -> String -> m (i :: Row *) (i :: Row *) ()
src/Motor/FSM/Sugar.hs view
@@ -1,72 +1,99 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}--- | Syntactic sugar for 'MonadFSM' types.+-- | Syntactic sugar for 'MonadFSM' types, adding appropriate row+-- constraints and hiding complexity of the internal implementation. module Motor.FSM.Sugar- ( Add(..)- , Delete(..)- , To(..)- , (:->)+ ( Action(..)+ , ActionMapping(..) , FromActions , NoActions , Actions , OnlyActions+ , Get , type (!-->) , type (!+) , type (!-) ) where -import Data.OpenRecords+import Data.Kind+import Data.Row.Records import GHC.TypeLits (Symbol) --- | Action that adds a new resource in state 's'.-newtype Add s = Add s---- | Action that deletes an existing resource in state 's'.-newtype Delete s = Delete s---- | Action that transitions the state of an existing resource from--- state 'a' to 'b'.-data To a b = Transition a b+-- | An 'Action' describes a resource action.+data Action+ = Add Type+ -- ^ Adds a new resource of the given 'Type'.+ | Remain Type+ -- ^ The existing resource of the given 'Type' remains the same.+ | To Type+ Type+ -- ^ Transitions an existing resource from the first 'Type' to a+ -- resource of the second 'Type'.+ | Delete Type+ -- ^ Deletes an existing resource of the given 'Type'. --- | Mapping from 'Symbol' to some action 'k'.-data (:->) (n :: Symbol) (a :: k)+-- | Mapping from 'Symbol' to some action 'a'.+data ActionMapping = (:=) Symbol Action -infixr 5 :->+infixr 5 := -- | Translates a list of 'Action's to a 'Row'.-type family FromActions (as :: [*]) (rs :: Row *) :: (Row *) where- FromActions '[] rs = rs- FromActions ((n :-> Add a) ': ts) r = Extend n a (FromActions ts r)- FromActions ((n :-> Delete a) ': ts) r = FromActions ts r :- n- FromActions ((n :-> To a b) ': ts) r = Extend n b (FromActions ts r :- n)+type family FromActions (as :: [ActionMapping]) (rs :: Row *) (c :: Constraint) :: (Row *, Constraint) where+ FromActions '[] rs c = '( rs, c)+ FromActions ((n ':= 'Add a) ': ts) r c =+ FromActions ts (Extend n a r) ( c+ , (Extend n a r .! n) ~ a+ )+ FromActions ((n ':= 'Delete a) ': ts) r c =+ FromActions ts (r .- n) ( c+ , (r .! n) ~ a+ )+ FromActions ((n ':= 'To a b) ': ts) r c =+ FromActions ts (Modify n b r) ( c+ , (r .! n) ~ a+ , (Modify n b r .! n) ~ b+ )+ FromActions ((n ':= 'Remain a) ': ts) r c =+ FromActions ts r (c, (r .! n) ~ a) +type NoConstraint = (() :: Constraint)+ -- | Alias for 'MonadFSM' that includes no actions. type NoActions m (r :: Row *) a = m r r a -- | Alias for 'MonadFSM' that uses 'FromActions' to construct rows.-type Actions m as (r :: Row *) a = m r (FromActions as r) a+type Actions m as (i :: Row *) a+ = forall o c. (FromActions as i NoConstraint ~ '( o, c), c) =>+ m i o a -- | Alias for 'MonadFSM' that uses 'FromActions' to construct rows, -- starting from an 'Empty' row, i.e. allowing no /other/ resources. type OnlyActions m as a = Actions m as Empty a +-- | Gets an existing resource in state 's'.+type Get m (r :: Row *) n = m r r (r .! n)+ -- | Infix version of 'To'.-type (!-->) i o = To i o+type (!-->) i o = 'To i o infixl 6 !--> -- | Add a named resource. Alias of 'Add'.-type (!+) (n :: Symbol) s = n :-> Add s+type (!+) (n :: Symbol) s = n ':= 'Add s infix 6 !+ -- | Delete a named resource. Alias of 'Delete'.-type (!-) (n :: Symbol) s = n :-> Delete s+type (!-) (n :: Symbol) s = n ':= 'Delete s infix 6 !-
− src/Motor/FSM/TH.hs
@@ -1,142 +0,0 @@-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}--- |-module Motor.FSM.TH where--import Control.Applicative-import Data.Foldable-import Data.Maybe-import Data.Semigroup-import Language.Haskell.TH-import Language.Haskell.TH.Syntax--data TransitionSigs = TransitionSigs { stateTypeFamily :: Maybe TypeFamilyHead- , transitionSigs :: [(Name, Type)]- } deriving (Eq, Show)--instance Semigroup TransitionSigs where- TransitionSigs tf1 s1 <> TransitionSigs tf2 s2 =- TransitionSigs (tf1 <|> tf2) (s1 <> s2)--instance Monoid TransitionSigs where- mempty = TransitionSigs Nothing []- mappend = (<>)--data Transition- = Add String- | Transition String- String- | Delete String- deriving (Eq, Show, Lift)--newtype Transitions = Transitions [(String, Transition)]- deriving (Eq, Show, Lift)--asTransitions :: TransitionSigs -> Q Transitions-asTransitions sigs = do- TypeFamilyHead tfName _ _ _ <-- fail "Missing associated type." `fromMaybe` (return <$> stateTypeFamily sigs)- Transitions . concat <$> mapM (sigToTransition tfName) (transitionSigs sigs)--sigToTransition :: Name -> (Name, Type) -> Q [(String, Transition)]-sigToTransition tfName (transitionName, type') =- case type' of- (ForallT- [ KindedTV _m1 (AppT- (AppT- ArrowT- (AppT- (ConT _rowKind1) StarT))- (AppT- (AppT ArrowT- (AppT (ConT _rowKind2) StarT))- (AppT (AppT ArrowT StarT) StarT)))- ]- [ AppT (ConT _className) (VarT _cm)- ]- (ForallT- [ KindedTV _n1 (ConT _symbolKind1)- , KindedTV _r1 (AppT (ConT _rowKind3) StarT)- ]- _constraints- (AppT _ actions))) ->- map (nameBase transitionName,) <$> actionsToTransitions tfName actions- _ -> do- reportWarning ("Unsupported type:" ++ show type')- return []--actionsToTransitions :: Name -> Type -> Q [Transition]-actionsToTransitions tfName =- \case- SigT (AppT (AppT (AppT (AppT (ConT _actions) (VarT _m)) as) (VarT _r)) _) _ ->- actionListToTransitions tfName as- _ -> return []--actionListToTransitions :: Name -> Type -> Q [Transition]-actionListToTransitions tfName =- \case- SigT- (AppT- (AppT- PromotedConsT- action)- actions)- (AppT ListT StarT) ->- mappend- <$> actionToTransitions tfName action- <*> actionListToTransitions tfName actions- SigT PromotedNilT (AppT ListT StarT) ->- return []- t -> do- reportWarning ("Unsupported action type: " ++ show t)- return []--actionToTransitions :: Name -> Type -> Q [Transition]-actionToTransitions tfName =- \case- AppT- (AppT (ConT _add) (VarT _n))- (AppT- (AppT- (ConT tf)- (VarT _m))- (ConT state))- | show tf == show tfName ->- return [Add (nameBase state)]-- AppT- (AppT (ConT _assoc) (VarT _n))- (AppT- (AppT (ConT _to) (AppT (AppT (ConT tf1) (VarT _m1)) (ConT from)))- (AppT- (AppT (ConT tf2) (VarT _m2))- (ConT to)))- | show tf1 == show tfName && show tf2 == show tfName ->- return [Transition (nameBase from) (nameBase to)]- action -> fail ("Action not supported: " ++ show action)--showClass :: Name -> Q [Dec]-showClass name = do- info <- reify name- case info of- ClassI (ClassD _ctx _className _binders _deps decls) _ -> do- ts <- asTransitions =<< fold <$> mapM getTransitions decls- [d|- transitions :: Transitions- transitions = ts- |]- _ ->- fail "Not an FSM typeclass."-- where- getTransitions :: Dec -> Q TransitionSigs- getTransitions dec =- case dec of- OpenTypeFamilyD tf@(TypeFamilyHead _n _ _ _) ->- return mempty { stateTypeFamily = Just tf }- SigD n t ->- return mempty { transitionSigs = [(n, t)]}- _ -> return mempty
test/Motor/FSMSpec.hs view
@@ -7,7 +7,7 @@ import Prelude hiding ((>>), (>>=)) import Control.Monad.Indexed-import Data.OpenRecords+import Data.Row.Records import Motor.FSM @@ -20,14 +20,14 @@ n2 :: Name "n2" n2 = Name -s1s2 :: MonadFSM m => Name n -> m r (n ::= S2 :| (r :- n)) ()+s1s2 :: MonadFSM m => Name n -> m r (Modify n S2 r) () s1s2 s = enter s S2 -s2s1 :: MonadFSM m => Name n -> m r (n ::= S1 :| (r :- n)) ()+s2s1 :: MonadFSM m => Name n -> m r (Modify n S1 r) () s2s1 s = enter s S1 -dropS1 :: MonadFSM m => Name n -> m r (r :- n) ()+dropS1 :: MonadFSM m => Name n -> m r (r .- n) () dropS1 = delete test :: MonadFSM m => m Empty Empty ()
test/Motor/FSMSpec/Game.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}@@ -15,11 +17,10 @@ import Control.Monad.Indexed import Control.Monad.IO.Class-import Data.OpenRecords+import Data.Row.Records import Motor.FSM import Motor.FSM.Logging-import Motor.FSM.TH -- * Game Protocol/Machine @@ -35,18 +36,16 @@ jump :: KnownSymbol n => Name n- -> Actions m '[n :-> State m Standing !--> State m Jumping] r ()+ -> Actions m '[n := State m Standing !--> State m Jumping] r () land :: KnownSymbol n => Name n- -> Actions m '[n :-> State m Jumping !--> State m Standing] r ()+ -> Actions m '[n := State m Jumping !--> State m Standing] r () perish :: KnownSymbol n => Name n -> Actions m '[n !- State m Standing] r () -showClass ''Game- -- * Game Implemention newtype GameImpl m (i :: Row *) (o :: Row *) a =@@ -89,22 +88,28 @@ testTwoAdds :: Game m- => Actions m '[ "hero2" !+ State m Standing- , "hero1" !+ State m Standing- ] r ()+ => Actions m '[ "hero1" !+ State m Standing+ , "hero2" !+ State m Standing+ ] r () testTwoAdds = spawn hero1 >>>= \_ -> spawn hero2 testTwoDeletes :: Game m- => Actions m '[ "hero2" !- State m Standing, "hero1" !- State m Standing] r ()+ => Actions m '[ "hero1" !- State m Standing+ , "hero2" !- State m Standing+ ] r () testTwoDeletes = perish hero1 >>>= \_ -> perish hero2 testTwoAddDeletes :: Game m- => NoActions m r ()-testTwoAddDeletes = call $ do+ => Actions m '[ "hero1" !+ State m Standing+ , "hero2" !+ State m Standing+ , "hero1" !- State m Standing+ , "hero2" !- State m Standing+ ] r ()+testTwoAddDeletes = do spawn hero1 spawn hero2 perish hero1