motor 0.1.1.0 → 0.2.0.0

raw patch · 5 files changed

+171/−12 lines, 5 filesdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +2/−0
• README.md +2/−5
• motor.cabal +5/−3
• src/Motor/FSM/TH.hs +142/−0
• test/Motor/FSMSpec/Game.hs +20/−4

@@ -1,3 +1,5 @@+* 0.2.0.0+  - Add `motor-reflection` and `motor-diagrams` packages. * 0.1.1.0   - Add `call` operation to `MonadFSM` class * 0.1.0.0

@@ -1,9 +1,6 @@-# Motor: Type-safe effectful state machines in Haskell+# `motor` (core library) -*Motor* is an experimental Haskell library for building finite-state-machines with type-safe transitions and effects. It draws inspiration-from the Idris-[ST](http://docs.idris-lang.org/en/latest/st/state.html) library.+This library provides the core part of Motor.  ## Usage 

@@ -1,5 +1,5 @@ name:                motor-version:             0.1.1.0+version:             0.2.0.0 synopsis:   Type-safe effectful state machines in Haskell description:@@ -29,13 +29,15 @@                      , Motor.FSM.Class                      , Motor.FSM.Sugar                      , Motor.FSM.Logging+                     , Motor.FSM.TH   -- other-modules:   -- other-extensions:-  build-depends:       base >=4.9 && <5+  build-depends:       CTRex+                     , base >=4.9 && <5                      , indexed                      , indexed-extras-                     , CTRex                      , reflection+                     , template-haskell >= 2.11.1.0   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -Wall

@@ -0,0 +1,142 @@+{-# 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

@@ -6,6 +6,7 @@ {-# LANGUAGE PolyKinds                  #-} {-# LANGUAGE RebindableSyntax           #-} {-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-} module Motor.FSMSpec.Game where@@ -18,6 +19,7 @@  import           Motor.FSM import           Motor.FSM.Logging+import           Motor.FSM.TH  -- * Game Protocol/Machine @@ -26,10 +28,24 @@  class MonadFSM m => Game (m :: Row * -> Row * -> * -> *) where   type State m :: * -> *-  spawn :: KnownSymbol n => Name n -> m r (n ::= State m Standing :| r) ()-  jump :: KnownSymbol n => Name n -> m r (n ::= State m Jumping :| (r :- n)) ()-  land :: KnownSymbol n => Name n -> m r (n ::= State m Standing :| (r :- n)) ()-  perish :: KnownSymbol n => Name n -> m r (r :- n) ()+  spawn+    :: KnownSymbol n+    => Name n+    -> Actions m '[n !+ State m Standing] r ()+  jump+    :: KnownSymbol n+    => Name n+    -> 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 ()+  perish+    :: KnownSymbol n+    => Name n+    -> Actions m '[n !- State m Standing] r ()++showClass ''Game  -- * Game Implemention