diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 `` + 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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ``. 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 + + + +``` + +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 `` 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 `` 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 `` sibling, which completes their parent and diff --git a/scxml-statecharts.cabal b/scxml-statecharts.cabal --- a/scxml-statecharts.cabal +++ b/scxml-statecharts.cabal @@ -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 () in SCXML inside a Haskell module and get typed states, events and a step function out of it. - . + > [scxml| > > @@ -16,7 +16,7 @@ > > > |] - . + 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, diff --git a/src/Scxml/Statechart/Def.hs b/src/Scxml/Statechart/Def.hs --- a/src/Scxml/Statechart/Def.hs +++ b/src/Scxml/Statechart/Def.hs @@ -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 } diff --git a/src/Scxml/Statechart/Interpret.hs b/src/Scxml/Statechart/Interpret.hs --- a/src/Scxml/Statechart/Interpret.hs +++ b/src/Scxml/Statechart/Interpret.hs @@ -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) diff --git a/src/Scxml/Statechart/Model.hs b/src/Scxml/Statechart/Model.hs --- a/src/Scxml/Statechart/Model.hs +++ b/src/Scxml/Statechart/Model.hs @@ -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 @@; 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) diff --git a/src/Scxml/Statechart/Parse.hs b/src/Scxml/Statechart/Parse.hs --- a/src/Scxml/Statechart/Parse.hs +++ b/src/Scxml/Statechart/Parse.hs @@ -26,6 +26,12 @@ -- @done.state.X@ event, which becomes the constructor @DoneX@. The @name@ -- attribute on @@ 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 @@ 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 , 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 " 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 @@ 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 @@ 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 +-- @@ 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 callback that raises an event instead") unless (null (childrenNamed ["script"] el)) $ throwP (label ++ ": + + + + + + + + + + + + + + + + + + + + + + + + + + +|] + +-- 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)) + ) + ]