packages feed

scxml-statecharts 0.1.0.0 → 0.2.0.0

raw patch · 11 files changed

+478/−105 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -1,6 +1,41 @@ # Changelog -## 0.1.0.0 -- unreleased+## 0.2.0.0 -- 2026-09-17++- **Breaking.** The `event` attribute now names one event and then the Haskell+  types its constructor holds, so `event="Order Items Int"` declares+  `Order Items Int`. SCXML reads the attribute as a space-separated list of+  event descriptors, and that shorthand is gone: `event="A B"` no longer means+  two transitions with one target, which is written as two `<transition>`+  elements instead. This is the one place the parser knowingly differs from+  the specification.+- The event reaching a callback is now the one the caller passed in rather+  than a value rebuilt from its name, so whatever payload it carries survives+  the trip, and an event a callback raises carries its own. The evaluator is+  parameterised over the event type and still selects transitions by name+  alone, so a payload never decides where the chart goes; that stays with the+  events a callback raises. `Def` trades `defEventFromName :: Text -> Maybe ev`+  for a total `defDoneEvent :: StateId -> ev`, since `done.state` events are+  the only ones the evaluator synthesises and they carry nothing.+- A payload type is one type constructor, optionally module-qualified,+  resolved after the quasiquote like a callback name, so it may be defined+  below it. `Maybe Int`, `[Int]` and tuples cannot be told apart from separate+  fields in an attribute whose parts are separated by spaces, so they go+  through a type alias; writing one directly is rejected with a message naming+  the way in. Allowing them later is a compatible change.+- Every transition naming an event must declare the same payload for it, since+  they all reach the one generated constructor, and a disagreement is a+  compile error naming both places.+- **Breaking.** An event that carries data costs `FsmEvent` its derived `Ord`,+  `Enum` and `Bounded`: `Ord` would demand an instance of every payload type,+  and the other two need every constructor nullary. A chart whose events carry+  nothing derives all of them as before.+- The Nix dev shell gained zlib, which `xml-conduit` reaches through+  `conduit-extra` and `streaming-commons`. Without it `cabal build` compiled+  everything and then failed at the link with `cannot find -lz`, and every+  Template Haskell splice warned about `libz.so`.++## 0.1.0.0 -- 2026-09-09  First release.
README.md view
@@ -101,7 +101,8 @@  Entry callbacks receive the state being entered, exit callbacks the state being left. The event is the one being processed, or `Nothing` during-`initiateStateMachine`.+`initiateStateMachine`. It is the event the caller passed in, so whatever+payload it carries arrives with it.  Returning `Just event` raises it, which is SCXML's `<raise>`. Raised events are queued and processed before `notifyStateMachine` returns. This is how branching@@ -119,6 +120,57 @@ signature and stays usable elsewhere. Declaring the weakest constraint each callback needs is therefore still worth it. +## Events that carry data++The `event` attribute holds the event name and then the Haskell types its+constructor carries:++```xml+<state id="Idle">+  <transition event="Order Item Int" target="Checking"/>+</state>+```++That declares `Order Item Int` in `FsmEvent`, and the payload reaches the+callbacks of the states the transition enters:++```haskell+check :: FsmState -> Maybe FsmEvent -> m (Maybe FsmEvent)+check _ (Just (Order (Item what) n))+  | n > 0     = pure (Just Ok)+  | otherwise = pure (Just (Reject (Reason ("nothing ordered of " <> what))))+check _ _     = pure (Just (Reject (Reason "no order")))+```++Selection is still by name alone: a payload never decides which transition+fires, which is the same rule as the missing `cond` and keeps the routing+readable from the chart. A decision that depends on the data is a state whose+entry callback raises one of the events leading out of it, and that raised+event may carry data of its own.++A payload belongs to its event rather than to the step. An event a callback+raises carries its data to the callbacks that event reaches, but a+`done.state` event raised afterwards is a different event and carries nothing.++A few things to know:++- **Payload types are written as one type constructor**, optionally qualified:+  `Int`, `Data.Text.Text`, `Order.LineItem`. `Maybe Int`, `[Int]` and+  `(Int, Int)` cannot be written directly, because the attribute separates one+  field from the next by a space; give them a type alias and name that. Like+  callback names, the types are resolved after the quasiquote, so they may be+  defined below it.+- **Every transition naming an event must declare the same payload**, since+  they all reach the one constructor. Disagreeing declarations are a compile+  error naming both.+- **`done.state.X` events carry nothing.** The chart raises them itself, so+  there is nowhere for a payload to come from.+- **An event that carries data costs `FsmEvent` its derived `Ord`, `Enum` and+  `Bounded`.** `Ord` would demand an instance of every payload type, and the+  other two need every constructor nullary. A chart whose events carry nothing+  derives all of them as before. `Show`, `Read` and `Eq` are always derived,+  so payload types need them.+ ## Semantics  `notifyStateMachine` runs `<onexit>` callbacks of exited states, innermost@@ -252,8 +304,11 @@   because it makes the entry point depend on the order children happen to be   written in. - **One transition per state per event**, held as a map from event name to-  target, so nothing has to break a tie. `event="A B"` is still shorthand for-  two transitions to the same target.+  target, so nothing has to break a tie. The `event` attribute names one event+  and then the types its constructor carries, which is the one place this+  knowingly differs from the specification: SCXML reads the attribute as a+  space-separated list of event descriptors. Two events reaching one target+  are two `<transition>` elements. - **`done.state.X` may only be handled on `X` itself.** Since a transition   also targets a sibling, completion climbs one level at a time: a state that   finishes moves to a `<final>` sibling, which completes their parent and
scxml-statecharts.cabal view
@@ -1,11 +1,11 @@ cabal-version:      3.0 name:               scxml-statecharts-version:            0.1.0.0+version:            0.2.0.0 synopsis:           Typed statecharts from SCXML, via Template Haskell description:     Define a statechart (<https://statecharts.dev/>) in SCXML inside a Haskell     module and get typed states, events and a step function out of it.-    .+     > [scxml|     > <scxml initial="Draft">     >   <state id="Draft"><transition event="Submit" target="Review"/></state>@@ -16,7 +16,7 @@     >   <final id="Done"/>     > </scxml>     > |]-    .+     generates @FsmState@, @FsmEvent@ and the functions     @initiateStateMachine :: m FsmState@ and     @notifyStateMachine :: FsmState -> FsmEvent -> m FsmState@, which call the@@ -25,14 +25,19 @@     exactly one legal configuration: illegal states are unrepresentable and     @case@ is exhaustive. Names in the XML are used verbatim as Haskell     constructor names.-    .+     Hierarchy, parallel regions, entry and exit callbacks and SCXML's     @done.state@ completion events are supported. @cond@ guards and eventless     transitions are deliberately not: a decision becomes a state whose entry     callback raises one of the events leading out of it, which keeps the-    branching visible in the chart. See the README for the full mapping and-    the list of unsupported SCXML features.+    branching visible in the chart. +    An event can carry data, by naming the Haskell types its constructor holds+    after it: @event="Order Item Int"@ declares @Order Item Int@, and the+    callbacks of the states that transition enters receive the value with its+    payload. Transitions are still selected by event name alone. See the+    README for the full mapping and the list of unsupported SCXML features.+ homepage:           https://github.com/AxelUlmestig/scxml-statecharts bug-reports:        https://github.com/AxelUlmestig/scxml-statecharts/issues license:            BSD-3-Clause@@ -83,6 +88,7 @@     main-is:          Main.hs     other-modules:    Reordered                       Overrides+                      Payloads     build-depends:         base              >=4.18  && <5,         scxml-statecharts,
src/Scxml/Statechart/Def.hs view
@@ -10,14 +10,18 @@ -- interpreter runs. @s@ is the state type and @ev@ the event type. The @scxml@ -- quasiquoter generates one of these per chart. data Def s ev = Def-  { defChart         :: Chart-  , defEventName     :: ev -> Text-  , defEventFromName :: Text -> Maybe ev-    -- ^ total: 'Nothing' means the generated event type has no constructor-    -- for that name, which the generator makes impossible for names the-    -- interpreter can produce-  , defToConfig      :: s -> Set StateId+  { defChart      :: Chart+  , defEventName  :: ev -> Text+    -- ^ the name a transition matches on. An event's payload never takes part+    -- in selection, so this is all the interpreter needs; the event itself is+    -- carried along beside it.+  , defDoneEvent  :: StateId -> ev+    -- ^ the constructor for a state's @done.state@ event, which the+    -- interpreter raises itself and which therefore carries no payload.+    -- Total: the generator emits one for every state that can complete, which+    -- is every state the interpreter can pass here.+  , defToConfig   :: s -> Set StateId     -- ^ the set of active state ids described by a typed state-  , defFromConfig    :: Set StateId -> Maybe s+  , defFromConfig :: Set StateId -> Maybe s     -- ^ rebuild the typed state from a configuration produced by the interpreter   }
src/Scxml/Statechart/Interpret.hs view
@@ -37,13 +37,22 @@ data Phase = OnEntry | OnExit   deriving (Eq, Ord, Show) --- | How the evaluator reaches the callbacks, in the only terms it knows:--- state ids and event names. "Scxml.Statechart.Run" wraps the typed+-- | How the evaluator reaches the callbacks, and everything it needs to know+-- about the event type to do so. "Scxml.Statechart.Run" wraps the typed -- 'Scxml.Statechart.Run.Hooks' into one of these.-newtype Callbacks m = Callbacks-  { runCallback :: Phase -> Text -> Configuration -> Maybe Text -> m (Maybe Text)+--+-- The evaluator selects transitions by name and never looks inside an event,+-- but it carries the event itself from the caller through to the callbacks,+-- so an event may hold a payload the chart knows nothing about.+data Callbacks m ev = Callbacks+  { runCallback :: Phase -> Text -> Configuration -> Maybe ev -> m (Maybe ev)     -- ^ run the named callback, given the configuration it observes and the     -- event being processed ('Nothing' during 'start'); returns an event to raise+  , eventNameOf :: ev -> Text+    -- ^ the name a transition matches on+  , doneEvent :: StateId -> ev+    -- ^ the event a state raises on completing, which the evaluator+    -- synthesises rather than receiving, and which therefore carries nothing   }  -- | The event SCXML raises when a state completes.@@ -53,11 +62,12 @@ -- Entering ------------------------------------------------------------------  -- | The result of entering a state: its subtree's configuration, the states--- entered with the done events each entry implies, and whether the subtree is--- now in a final state.+-- entered with the states each entry completes, and whether the subtree is+-- now in a final state. A completed state is carried as its id, since the+-- event it raises is built by 'doneEvent' only when it reaches the queue. data Entered = Entered   { enConfig  :: Configuration-  , enEntered :: [(Node, [Text])] -- ^ outermost first+  , enEntered :: [(Node, [StateId])] -- ^ outermost first   , enFinal   :: Bool   } @@ -68,7 +78,7 @@   | nodeKind target /= Final = e   | otherwise = e {enEntered = attach (enEntered e), enFinal = True}   where-    attach ((h, ds) : rest) = (h, ds ++ [doneEventName parent]) : rest+    attach ((h, ds) : rest) = (h, ds ++ [parent]) : rest     attach [] = []  -- | Enter a state and everything default entry into it implies.@@ -86,7 +96,7 @@   Parallel rs ->     let belows = fmap enter rs         allFinal = all enFinal belows-        dones = [doneEventName (nodeId n) | allFinal]+        dones = [nodeId n | allFinal]      in Entered           { enConfig = Set.insert (nodeId n) (Set.unions (fmap enConfig (NE.toList belows)))           , enEntered = (n, dones) : concatMap enEntered (NE.toList belows)@@ -130,7 +140,7 @@     -- children.   , rpConfig :: Configuration -- ^ meaningful only when 'rpMove' is 'Nothing'   , rpExited :: [Node] -- ^ innermost first-  , rpEntered :: [(Node, [Text])] -- ^ outermost first+  , rpEntered :: [(Node, [StateId])] -- ^ outermost first   , rpConsumed :: Bool   , rpFinal :: Bool   }@@ -197,7 +207,7 @@             , rpExited = concatMap rpExited (NE.toList belows)             , rpEntered =                 concatMap rpEntered (NE.toList belows)-                  ++ [(n, [doneEventName (nodeId n)]) | justCompleted]+                  ++ [(n, [nodeId n]) | justCompleted]             , rpConsumed = True             , rpFinal = allFinal             }@@ -220,7 +230,7 @@ -- Running -------------------------------------------------------------------  -- | Enter the chart's initial state, then process whatever that raises.-start :: Monad m => Chart -> Callbacks m -> m Configuration+start :: Monad m => Chart -> Callbacks m ev -> m Configuration start ch cbs = do   let entered = enter (NE.head (chartRoot ch))       cfg = enConfig entered@@ -228,7 +238,7 @@   runToCompletion ch cbs cfg raised  -- | Process one external event. 'Nothing' if no transition was enabled for it.-macrostep :: Monad m => Chart -> Callbacks m -> Configuration -> Text -> m (Maybe Configuration)+macrostep :: Monad m => Chart -> Callbacks m ev -> Configuration -> ev -> m (Maybe Configuration) macrostep ch cbs cfg ev = do   r <- microstep ch cbs cfg ev   case r of@@ -237,7 +247,7 @@  -- | Process raised events in order until the queue is empty. One that no -- transition handles is dropped.-runToCompletion :: Monad m => Chart -> Callbacks m -> Configuration -> [Text] -> m Configuration+runToCompletion :: Monad m => Chart -> Callbacks m ev -> Configuration -> [ev] -> m Configuration runToCompletion ch cbs = go (0 :: Int)   where     go _ cfg [] = pure cfg@@ -251,12 +261,12 @@  -- | One event, one pass. The chart root behaves as a compound state: exactly -- one of its children is active, and it has no transitions of its own.-microstep :: Monad m => Chart -> Callbacks m -> Configuration -> Text -> m (Maybe (Configuration, [Text]))+microstep :: Monad m => Chart -> Callbacks m ev -> Configuration -> ev -> m (Maybe (Configuration, [ev])) microstep ch cbs cfg ev =   case activeChild cfg (chartRoot ch) of     Nothing -> pure Nothing     Just active ->-      let below = offer cfg ev active+      let below = offer cfg (eventNameOf cbs ev) active        in if not (rpConsumed below)             then pure Nothing             else do@@ -270,15 +280,15 @@               pure (Just (cfg', raised))  -- | Exit callbacks see the state being left, so they get the old configuration.-runExits :: Monad m => Callbacks m -> Configuration -> Text -> Node -> m ()+runExits :: Monad m => Callbacks m ev -> Configuration -> ev -> Node -> m () runExits cbs cfg ev n =   mapM_ (\a -> runCallback cbs OnExit a cfg (Just ev)) (nodeOnExit n)  -- | Entry callbacks see the configuration the step settles in, so they all get -- the new one even though they run outermost first.-runEntries :: Monad m => Callbacks m -> Configuration -> Maybe Text -> [(Node, [Text])] -> m [Text]+runEntries :: Monad m => Callbacks m ev -> Configuration -> Maybe ev -> [(Node, [StateId])] -> m [ev] runEntries cbs cfg ev = fmap concat . mapM one   where     one (n, dones) = do       raised <- mapM (\a -> runCallback cbs OnEntry a cfg ev) (nodeOnEntry n)-      pure ([r | Just r <- raised] ++ dones)+      pure ([r | Just r <- raised] ++ map (doneEvent cbs) dones)
src/Scxml/Statechart/Model.hs view
@@ -13,6 +13,7 @@     StateId   , Kind (..)   , Node (..)+  , Event (..)   , Chart (..)   , nodeChildren   , childrenOfKind@@ -58,11 +59,22 @@   }   deriving (Eq, Show, Lift) +-- | An event a transition names, with the payload its constructor carries.+-- The fields are Haskell type names, written after the event name in the+-- @event@ attribute, and are empty for an event that carries nothing. Every+-- transition naming an event must declare the same fields for it, since they+-- all reach the one generated constructor.+data Event = Event+  { eventName   :: Text+  , eventFields :: [Text] -- ^ type names, in order; empty for a bare event+  }+  deriving (Eq, Show, Lift)+ -- | A whole chart. This is what the quasiquoter lifts into the generated code. data Chart = Chart   { chartName   :: Maybe Text   , chartRoot   :: NonEmpty Node -- ^ children of @<scxml>@; the first is entered-  , chartEvents :: [Text]        -- ^ every event a transition names, in document order+  , chartEvents :: [Event]       -- ^ every event a transition names, in document order   }   deriving (Eq, Show, Lift)
src/Scxml/Statechart/Parse.hs view
@@ -26,6 +26,12 @@ -- @done.state.X@ event, which becomes the constructor @DoneX@. The @name@ -- attribute on @<scxml>@ is optional metadata, kept in 'chartName' for -- logging and persistence; it does not affect the generated names.+--+-- The @event@ attribute names one event and then the Haskell types its+-- constructor carries: @event="Ok Int"@ declares @Ok Int@. SCXML instead reads+-- the attribute as a space-separated list of event descriptors, which is the+-- one place this parser knowingly differs from the spec; two events reaching+-- one target are written as two @<transition>@ elements. module Scxml.Statechart.Parse (parseScxml) where  import Control.Monad (ap, forM_, unless, when)@@ -44,9 +50,11 @@  import Scxml.Statechart.Model --- A state+error monad collecting event names in the order they are first--- seen. Document order is derived from the tree, so nothing counts here.-newtype P a = P {runP :: [Text] -> Either String (a, [Text])}+-- A state+error monad collecting events in the order they are first seen,+-- each with the state that declared it so a later disagreement about its+-- payload can point back. Document order is derived from the tree, so nothing+-- counts here.+newtype P a = P {runP :: [(Event, String)] -> Either String (a, [(Event, String)])}  instance Functor P where   fmap f (P g) = P $ \st -> fmap (\(a, st') -> (f a, st')) (g st)@@ -64,10 +72,27 @@ liftE :: Either String a -> P a liftE = either throwP pure --- | Record an event name at its first occurrence in the document.-seeEvent :: Text -> P ()-seeEvent e = P $ \seen -> Right ((), if e `elem` seen then seen else seen ++ [e])+-- | Record an event at its first occurrence in the document. Every transition+-- naming an event reaches the same generated constructor, so a second one has+-- to agree about the payload.+seeEvent :: String -> Event -> P ()+seeEvent label e = P $ \seen ->+  case [d | d <- seen, eventName (fst d) == eventName e] of+    [] -> Right ((), seen ++ [(e, label)])+    (prev, declaredOn) : _+      | eventFields prev == eventFields e -> Right ((), seen)+      | otherwise ->+          Left $+            label ++ ": the event " ++ show (T.unpack (eventName e)) ++ " carries "+              ++ describeEvent e ++ " here and " ++ describeEvent prev ++ " on " ++ declaredOn+              ++ ". Every transition naming an event reaches the same constructor, so they must agree" +-- | An event's payload, for error messages.+describeEvent :: Event -> String+describeEvent e+  | null (eventFields e) = "nothing"+  | otherwise = unwords (map T.unpack (eventFields e))+ -- | Parse and validate an SCXML document. The 'Left' case is a message meant -- to be shown to whoever wrote the XML; the quasiquoter reports it as a -- compile error.@@ -76,7 +101,7 @@   root <- parseXml src   unless (localName root == "scxml") $     Left ("root element must be <scxml>, found <" ++ localName root ++ ">")-  (kids, events) <- runP (mapM buildNode (stateChildren root)) []+  (kids, declared) <- runP (mapM buildNode (stateChildren root)) []   rootKids <- case NE.nonEmpty kids of     Just ks -> Right ks     Nothing -> Left "<scxml> contains no states"@@ -87,7 +112,7 @@         Chart           { chartName = T.pack <$> attr "name" root           , chartRoot = ordered-          , chartEvents = events+          , chartEvents = map fst declared           }   validate ch   pure ch@@ -180,10 +205,31 @@  -- | Ids, event names and the chart name become Haskell constructors verbatim. checkConName :: String -> String -> Either String ()-checkConName what raw = case raw of-  c : cs | isUpper c && all (\x -> isAlphaNum x || x == '_' || x == '\'') cs -> Right ()-  _ -> Left (what ++ " " ++ show raw ++ " must be a Haskell constructor name (start with an upper-case letter, then letters, digits, _ or ')")+checkConName what raw+  | isConName raw = Right ()+  | otherwise = Left (what ++ " " ++ show raw ++ " must be a Haskell constructor name (start with an upper-case letter, then letters, digits, _ or ')") +-- | An upper-case Haskell identifier, which a constructor, a type and a+-- module all are.+isConName :: String -> Bool+isConName str = case str of+  c : cs -> isUpper c && all (\x -> isAlphaNum x || x == '_' || x == '\'') cs+  [] -> False++-- | A payload type is written as a Haskell type constructor, optionally+-- module-qualified. Nothing more elaborate fits: the @event@ attribute+-- separates fields by spaces, so @Maybe Int@ cannot be told apart from two+-- fields @Maybe@ and @Int@. A type alias covers the rest.+checkTypeName :: String -> String -> Either String ()+checkTypeName what raw+  | all isConName (map T.unpack (T.splitOn (T.pack ".") (T.pack raw))) = Right ()+  | otherwise =+      Left $+        what ++ " " ++ show raw ++ " must be a Haskell type name, optionally module-qualified"+          ++ " (Int, Text, Order.LineItem). A type variable, or a type built with an application,"+          ++ " a list, a tuple or a function arrow, cannot be written here, because the event attribute separates"+          ++ " fields by spaces; give it a type alias and name that"+ -- | The prefix of SCXML's automatic completion events. donePrefix :: Text donePrefix = T.pack "done.state."@@ -295,26 +341,29 @@       | localName c == "transition" = do           t <- buildTransition label c           (ts, ns) <- go rest-          pure (t ++ ts, ns)+          pure (t : ts, ns)       | localName c `elem` ["state", "parallel", "final", "history"] = do           n <- buildNode c           (ts, ns) <- go rest           pure (ts, n : ns)       | otherwise = go rest --- | The (event, target) pairs one @<transition>@ element contributes. SCXML--- allows several event names on one element, which is only shorthand for--- several transitions with the same target.-buildTransition :: String -> Element -> P [(Text, StateId)]+-- | The (event, target) pair one @<transition>@ element contributes. The+-- @event@ attribute holds the event name followed by the Haskell types its+-- constructor carries, so @event="Ok Int"@ declares @Ok Int@ and+-- @event="Ok"@ declares @Ok@. Two events reaching one target are two+-- @<transition>@ elements.+buildTransition :: String -> Element -> P (Text, StateId) buildTransition label el = do-  let events = maybe [] words (attr "event" el)+  let evWords = maybe [] words (attr "event" el)       targets = map T.pack (maybe [] words (attr "target" el))   when (attr "cond" el /= Nothing) $     throwP (label ++ ": cond is not supported; make the decision in an <onentry> callback that raises an event instead")   unless (null (childrenNamed ["script"] el)) $     throwP (label ++ ": <script> on a transition is not supported; put it in the <onentry> of the target, which receives the triggering event")-  when (null events) $-    throwP (label ++ ": transition without an event; eventless transitions are not supported, raise an event from a callback instead")+  (name, fields) <- case evWords of+    [] -> throwP (label ++ ": transition without an event; eventless transitions are not supported, raise an event from a callback instead")+    (n : fs) -> pure (n, fs)   target <- case targets of     [t] -> pure t     [] -> throwP (label ++ ": transition without a target; to act on an event without leaving the state, target the state itself")@@ -328,14 +377,33 @@     Just "internal" ->       throwP (label ++ ": type=\"internal\" is not supported; it can only differ from an external transition for a target inside the source, which is not allowed")     Just other -> throwP (label ++ ": unknown transition type " ++ show other)-  forM_ events $ \e ->-    when ('*' `elem` e) $-      throwP (label ++ ": wildcard event descriptor " ++ show e ++ " is not supported")-  forM_ events $ \e -> case stripPrefix (T.unpack donePrefix) e of-    Just inner -> liftE (checkConName (label ++ " done.state event state") inner)-    Nothing -> liftE (checkConName (label ++ " event") e)-  mapM_ (seeEvent . T.pack) events-  pure [(T.pack e, target) | e <- events]+  when ('*' `elem` name) $+    throwP (label ++ ": wildcard event descriptor " ++ show name ++ " is not supported")+  -- A type written with brackets is cut at the spaces inside it, so by the+  -- time the pieces reach checkTypeName they are meaningless. Catch it on the+  -- attribute, where the whole type is still there to show.+  forM_ (attr "event" el) $ \raw ->+    when (any (`elem` "()[],") raw) $+      throwP $+        label ++ ": the event attribute " ++ show raw ++ " writes a type with parentheses,"+          ++ " brackets or a comma. The attribute holds an event name and then one type"+          ++ " constructor per payload field, separated by spaces, so there is nowhere for"+          ++ " those to go: name the type yourself (type Items = [Item]) and write that"+  ev <- case stripPrefix (T.unpack donePrefix) name of+    Just inner -> do+      liftE (checkConName (label ++ " done.state event state") inner)+      unless (null fields) $+        throwP $+          label ++ ": " ++ show name ++ " cannot carry a payload; the chart raises its own"+            ++ " done.state events, so there is nowhere for one to come from"+      pure (Event (T.pack name) [])+    Nothing -> do+      liftE (checkConName (label ++ " event") name)+      forM_ fields $ \f ->+        liftE (checkTypeName (label ++ " event " ++ show name ++ " payload type") f)+      pure (Event (T.pack name) (map T.pack fields))+  seeEvent label ev+  pure (eventName ev, target)  -- | One transition per event, so selection never has to break a tie. transitionMap :: String -> [(Text, StateId)] -> Either String (Map.Map Text StateId)
src/Scxml/Statechart/Run.hs view
@@ -40,19 +40,15 @@ exitAction :: m () -> m () exitAction = id -toInterp :: Monad m => Def s ev -> Hooks m s ev -> I.Callbacks m+-- | The event reaching a callback is the one the caller passed in, not a value+-- rebuilt from its name, so whatever payload it carries survives the trip.+toInterp :: Def s ev -> Hooks m s ev -> I.Callbacks m ev toInterp def h =-  I.Callbacks $ \phase name cfg ev ->-    fmap (defEventName def) <$> runAction h phase name (unsafeFromConfig def cfg) (typedEvent def <$> ev)---- | The generator emits a constructor for every event name the interpreter can--- produce, including a @done.state@ event for every state that can complete,--- so this cannot fail for a chart the quasiquoter built.-typedEvent :: Def s ev -> Text -> ev-typedEvent def t =-  fromMaybe-    (error ("Statechart: no constructor for the event " ++ show (T.unpack t) ++ "; this is a bug in scxml-statecharts"))-    (defEventFromName def t)+  I.Callbacks+    { I.runCallback = \phase name cfg ev -> runAction h phase name (unsafeFromConfig def cfg) ev+    , I.eventNameOf = defEventName def+    , I.doneEvent = defDoneEvent def+    }  unsafeFromConfig :: Def s ev -> Set.Set StateId -> s unsafeFromConfig def cfg =@@ -69,4 +65,4 @@ stepOrStay :: Monad m => Def s ev -> Hooks m s ev -> s -> ev -> m s stepOrStay def h s e =   maybe s (unsafeFromConfig def)-    <$> I.macrostep (defChart def) (toInterp def h) (defToConfig def s) (defEventName def e)+    <$> I.macrostep (defChart def) (toInterp def h) (defToConfig def s) e
src/Scxml/Statechart/TH.hs view
@@ -11,8 +11,9 @@ --   the state id. A compound state becomes a constructor carrying a sum type --   of the same name as the state; a parallel state becomes a constructor --   with one field per compound region; atomic and final states are nullary.--- * @data FsmEvent@: one constructor per event name, verbatim, plus @DoneX@---   for SCXML's automatic @done.state.X@ completion events.+-- * @data FsmEvent@: one constructor per event name, verbatim, carrying the+--   payload types written after the name in the @event@ attribute, plus a+--   nullary @DoneX@ for SCXML's automatic @done.state.X@ completion events. -- * @fsmChart :: Def FsmState FsmEvent@, for "Scxml.Statechart.Run". -- * @serializeStateMachine :: FsmState -> [Text]@ and --   @deserializeStateMachine :: [Text] -> Maybe FsmState@, which store a state@@ -32,7 +33,9 @@ -- @ -- -- Every generated type derives @Show@, @Read@, @Eq@ and @Ord@, and the event--- type also derives @Enum@ and @Bounded@. For storing a state outside+-- type also derives @Enum@ and @Bounded@ as long as no event carries a+-- payload: @Ord@ would demand an instance of every payload type, and the+-- other two need every constructor nullary. For storing a state outside -- Haskell, prefer the generated @serializeStateMachine@ over @Show@. module Scxml.Statechart.TH (scxml) where @@ -104,8 +107,19 @@ -- > -- notifyStateMachine   :: FsmState -> FsmEvent -> StateT [FsmState] IO FsmState -- -- Returning @Just event@ instead of @Nothing@ raises that event, which is how--- a callback decides where the chart goes next. The generated names are fixed,--- so a module holds one chart.+-- a callback decides where the chart goes next.+--+-- An event may carry data, by writing the Haskell types its constructor holds+-- after its name. @\<transition event="Order Item Int" target="Checking"/\>@+-- declares @Order Item Int@, and the callbacks of the states that transition+-- enters receive the value the caller passed in, payload and all. A payload+-- type is one type constructor, optionally qualified (@Int@,+-- @Order.LineItem@); like a callback name it is resolved after the+-- quasiquote, so it may be defined below it. Transitions are still selected+-- by event name alone, so a payload never decides where the chart goes; that+-- stays with the events a callback raises.+--+-- The generated names are fixed, so a module holds one chart. scxml :: QuasiQuoter scxml =   QuasiQuoter@@ -152,12 +166,24 @@   -- Events: those named in transitions, in document order, then done events of   -- states that can complete but that no transition mentions.   let referenced = chartEvents ch-      doneEvents = [I.doneEventName (nodeId n) | n <- states, completes n]-      events = referenced ++ filter (`notElem` referenced) doneEvents-      eventCon e = case T.stripPrefix (T.pack "done.state.") e of-        Just sid -> (mkName ("Done" ++ T.unpack sid), "completion event " ++ show (T.unpack e))-        Nothing -> (mkName (T.unpack e), "event " ++ show (T.unpack e))-      eventCons = map eventCon events+      completing = [n | n <- states, completes n]+      doneEvents = [Event (I.doneEventName (nodeId n)) [] | n <- completing]+      events = referenced ++ filter ((`notElem` map eventName referenced) . eventName) doneEvents+      -- (constructor, payload type names, what it came from, wire name)+      eventInfo e =+        let name = eventName e+         in case T.stripPrefix (T.pack "done.state.") name of+              Just sid -> (mkName ("Done" ++ T.unpack sid), [], "completion event " ++ show (T.unpack name), name)+              Nothing -> (mkName (T.unpack name), eventFields e, "event " ++ show (T.unpack name), name)+      eventInfos = map eventInfo events+      eventCons = [(c, origin) | (c, _, origin, _) <- eventInfos]+      -- Enum and Bounded need every constructor nullary, and Ord would make+      -- the whole chart fail to compile over a payload type that has no+      -- instance, so an event carrying data costs all three.+      eventDerivs+        | null eventInfos = [''Show, ''Read, ''Eq, ''Ord]+        | any (\(_, fs, _, _) -> not (null fs)) eventInfos = [''Show, ''Read, ''Eq]+        | otherwise = [''Show, ''Read, ''Eq, ''Ord, ''Enum, ''Bounded]    groups <- forM (Nothing : map Just compounds) $ \g -> do     let ty = maybe stateT (nameFor . nodeId) g@@ -187,19 +213,31 @@    stateDecs <- concat <$> mapM (groupDecs nameFor groupOf . snd) groups   eventDec <--    dataD (cxt []) eventT [] Nothing [normalC c [] | (c, _) <- eventCons]-      [derivClause Nothing (map conT (if null eventCons then [''Show, ''Read, ''Eq, ''Ord] else [''Show, ''Read, ''Eq, ''Ord, ''Enum, ''Bounded]))]+    dataD (cxt []) eventT [] Nothing+      [ normalC c [bangType (bang noSourceUnpackedness noSourceStrictness) (conT (mkName (T.unpack f))) | f <- fs]+      | (c, fs, _, _) <- eventInfos+      ]+      [derivClause Nothing (map conT eventDerivs)]    let eventNameE-        | null eventCons = [| \_ -> error "eventName: chart has no events" |]-        | otherwise = lamCaseE [match (conP c []) (normalB (lift e)) [] | ((c, _), e) <- zip eventCons events]-      eventFromNameE = do-        t <- newName "t"-        lam1E (varP t) $+        | null eventInfos = [| \_ -> error "eventName: chart has no events" |]+        | otherwise =+            lamCaseE+              [ match (conP c (replicate (length fs) wildP)) (normalB (lift name)) []+              | (c, fs, _, name) <- eventInfos+              ]+      -- Total for every state the interpreter can complete, which is exactly+      -- the states that got a DoneX constructor.+      doneEventE = do+        sid <- newName "sid"+        lam1E (varP sid) $           foldr-            (\((c, _), e) rest -> [| if $(varE t) == $(lift e) then Just $(conE c) else $rest |])-            [| Nothing |]-            (zip eventCons events)+            (\n rest ->+               [| if $(varE sid) == $(lift (nodeId n))+                    then $(conE (mkName ("Done" ++ T.unpack (nodeId n))))+                    else $rest |])+            [| error ("Statechart: no done.state constructor for " ++ show $(varE sid) ++ "; this is a bug in scxml-statecharts") |]+            completing    defSig <- sigD defName [t| Def $(conT stateT) $(conT eventT) |]   defDec <-@@ -208,7 +246,7 @@         [| Def              { defChart = $(lift ch)              , defEventName = $eventNameE-             , defEventFromName = $eventFromNameE+             , defDoneEvent = $doneEventE              , defToConfig = $(varE (gTo rootGroup))              , defFromConfig = $(varE (gFrom rootGroup))              } |])
test/Main.hs view
@@ -12,6 +12,7 @@ -- The library's entire public API. import Scxml.Statechart (scxml) import qualified Overrides+import qualified Payloads import qualified Reordered  -- An order process: compound states, a parallel state that completes via@@ -24,9 +25,10 @@ <scxml xmlns="http://www.w3.org/2005/07/scxml" version="1.0" name="order-v1" initial="Draft">   <state id="Draft">     <transition event="Submit" target="Validating"/>-    <!-- Several event names on one element is shorthand for several-         transitions with the same target. -->-    <transition event="Discard Abandon" target="Cancelled"/>+    <!-- Two events reaching one target are two transitions: the event+         attribute holds one event name and then its payload types. -->+    <transition event="Discard" target="Cancelled"/>+    <transition event="Abandon" target="Cancelled"/>   </state>    <state id="Validating">@@ -259,7 +261,7 @@   check "a self-transition re-enters without moving" (Processing Authorizing) stayed   viaDiscard <- stepFrom (shopWith ["book"]) Draft Discard   viaAbandon <- stepFrom (shopWith ["book"]) Draft Abandon-  check "several events on one transition all reach its target"+  check "separate transitions to one target both reach it"     (Cancelled, Cancelled) (viaDiscard, viaAbandon)   check "all events, in document order"     [ Submit, Discard, Abandon, Valid, Invalid, Poll, PaymentAuthorized, Packed@@ -287,7 +289,8 @@   -- A second chart, in its own module since the generated names are fixed.   reordered <- Reordered.spec   overrides <- Overrides.spec-  mapM_ (\(label, expected, actual) -> check label expected actual) (reordered ++ overrides)+  payloads <- Payloads.spec+  mapM_ (\(label, expected, actual) -> check label expected actual) (reordered ++ overrides ++ payloads)    n <- readIORef failures   when (n > 0) exitFailure
+ test/Payloads.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+-- | Events that carry data. The @event@ attribute names the event and then the+-- Haskell types its constructor holds, so @event="Order Item Int"@ declares+-- @Order Item Int@. Selection still happens on the name alone: the payload+-- goes to the callbacks and never decides which transition fires.+module Payloads where++import Control.Monad.Trans.State.Strict (StateT, modify', runStateT)+import Data.Text (Text)+import qualified Data.Text as T++import Scxml.Statechart (scxml)++[scxml|+<scxml initial="Idle">+  <state id="Idle">+    <onentry><script>arrive</script></onentry>+    <!-- Items is a type alias: a list cannot be written in the attribute,+         which separates one payload field from the next by a space. -->+    <transition event="Order Items Int" target="Checking"/>+  </state>++  <state id="Checking">+    <!-- Reads the payload of the event that got here and decides by raising+         one of the two events leading out, one of which carries data too. -->+    <onentry><script>check</script></onentry>+    <transition event="Ok" target="Shipping"/>+    <transition event="Reject Reason" target="Refused"/>+  </state>++  <state id="Shipping" initial="Packing">+    <state id="Packing">+      <!-- A module-qualified payload type. -->+      <transition event="Ship Data.Text.Text" target="Sent"/>+    </state>+    <final id="Sent"/>+    <transition event="done.state.Shipping" target="Idle"/>+  </state>++  <state id="Refused">+    <onentry><script>note</script></onentry>+    <!-- The same event again, declared with the same payload. Both+         transitions reach the one Order constructor. -->+    <transition event="Order Items Int" target="Checking"/>+  </state>+</scxml>+|]++-- Generated:+--+--   data FsmState = Idle | Checking | Shipping Shipping | Refused+--   data Shipping = Packing | Sent+--   data FsmEvent = Order Items Int | Ok | Reject Reason | Ship Text+--                 | DoneShipping+--+-- An event carries data, so FsmEvent derives Show, Read and Eq only: Enum and+-- Bounded need every constructor nullary, and Ord would demand an instance of+-- every payload type.++type M = StateT [Text] IO++initiateStateMachine :: M FsmState+notifyStateMachine :: FsmState -> FsmEvent -> M FsmState++-- The payload types, written after the quasiquote: like callback names, they+-- are resolved once the generated declarations are spliced in.+newtype Item = Item Text+  deriving (Show, Read, Eq)++-- A payload type is one type constructor, so a list gets a name of its own.+type Items = [Item]++newtype Reason = Reason Text+  deriving (Show, Read, Eq)++arrive, check, note :: FsmState -> Maybe FsmEvent -> M (Maybe FsmEvent)+arrive _ ev = do+  say ("idle after " <> maybe "start" (T.pack . show) ev)+  pure Nothing++check _ ev = case ev of+  Just (Order items n)+    | n > 0 -> do+        say ("checking " <> T.pack (show n) <> " x " <> named items)+        pure (Just Ok)+    | otherwise -> pure (Just (Reject (Reason ("nothing ordered of " <> named items))))+  _ -> pure (Just (Reject (Reason "no order")))+  where+    named items = T.intercalate " + " [what | Item what <- items]++note _ ev = do+  say (case ev of Just (Reject (Reason why)) -> "refused: " <> why; _ -> "refused")+  pure Nothing++say :: Text -> M ()+say t = modify' (++ [t])++-- | Start the chart and feed events. Returns the final state and the log.+run :: [FsmEvent] -> IO (FsmState, [Text])+run evs = runStateT (initiateStateMachine >>= go evs) []+  where+    go [] s = pure s+    go (e : rest) s = notifyStateMachine s e >>= go rest++-- | Checks to run, as (label, expected, actual) triples.+spec :: IO [(String, String, String)]+spec = do+  (accepted, acceptedLog) <- run [Order [Item "book"] 2]+  (refused, refusedLog) <- run [Order [Item "book"] 0]+  (shipped, shippedLog) <- run [Order [Item "book"] 2, Ship "trk-1"]+  (again, _) <- run [Order [Item "book"] 0, Order [Item "pen"] 1]+  pure+    [ ("a payload reaches the entry callback of the state the event causes"+      , show ["idle after start", "checking 2 x book" :: Text]+      , show acceptedLog+      )+    , ("and decides what that callback raises", show (Shipping Packing), show accepted)+    , -- The Reject raised by Checking's callback carries a Reason, which the+      -- callback of the state it leads to reads back.+      ("a raised event carries its payload to the next callback"+      , show ["idle after start", "refused: nothing ordered of book" :: Text]+      , show refusedLog+      )+    , ("a raised event still selects by name alone", show Refused, show refused)+    , ("done.state events fire as before alongside events that carry data"+      , show Idle+      , show shipped+      )+    , ("a done.state event carries nothing, and reaches the callback after it"+      , show ["idle after start", "checking 2 x book", "idle after DoneShipping" :: Text]+      , show shippedLog+      )+    , ("the same event on two transitions is one constructor"+      , show (Shipping Packing)+      , show again+      )+    , ("an event shows and reads back with its payload"+      , show (Order [Item "book"] 2)+      , show (read (show (Order [Item "book"] 2)) :: FsmEvent)+      )+    , ("the state type is unaffected by payloads"+      , show ["Packing", "Shipping" :: Text]+      , show (serializeStateMachine (Shipping Packing))+      )+    ]