diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,57 @@ +# Changelog + +## 0.1.0.0 -- unreleased + +First release. + +- `scxml` declaration quasiquoter generating `FsmState`, `FsmEvent`, + `fsmChart`, `initiateStateMachine` and `notifyStateMachine`. +- Hierarchy (compound states as sum types), parallel regions (as products), + `` and `` callbacks named in the XML, entry callbacks that + raise events, and SCXML `done.state.X` completion events. +- Unmatched events leave the state unchanged, as in SCXML. +- Compile-time validation: strict XML (via `xml-conduit`), state ids, event + names, callback names, a level rule requiring a transition to target a + sibling of its source, and a rule forbidding transitions on a region of a + ``. `initial` is required on every compound state and must name a + direct child; SCXML's "first child in document order" default is not + supported. +- The evaluator is a single recursive pass over the tree. Because a transition + may only target a sibling, a state only ever rearranges its own children, so + there are no least common ancestors, exit-set filters over the whole + configuration, or conflicts between transitions at different depths. The + derived index is gone, along with lookup by id, parent links and document + order. Innermost-wins is now explicit: children are asked first and a state + acts only if nothing below it did. +- A `` state is rejected as a direct region of a ``. SCXML + does not allow it, and it used to report the whole parallel complete before + the other regions had run. +- The chart is a tree: a state owns its children as `Node`s, and a compound + state keeps its initial child first, so a dangling child, a disagreeing + parent and an initial child that is not one of its own are all + unrepresentable. Parent and document order are derived into an index rather + than stored. A compound state's initial child is therefore its first + generated constructor, which changes derived `Ord` for charts that do not + write the initial state first. + Only the interpreter needs the derived index; the parser and the generator + walk the tree, so a transition target is checked against the source's + siblings rather than by looking up parents. +- `done.state.X` may only be handled on `X` itself, so completion climbs one + level at a time through `` states and validation is entirely local to + a state and its neighbours. +- A transition on an enclosing state acts as a default that an inner state can + override, since the innermost matching transition wins and only it is taken. + Documented rather than warned about: a Template Haskell warning becomes an + error under `-Werror` and cannot be exempted by flag. +- The public API is the `scxml` quasiquoter alone. `serializeStateMachine` and + `deserializeStateMachine` are generated into the calling module, so a chart + needs no other import. The remaining modules are not exposed. +- Transitions are a map from event name to target, so two transitions on one + state for the same event are unrepresentable, and document order never + decides which transition is taken. A transition naming more than one target + is rejected; both previously compiled and silently produced a wrong state. +- `Kind` carries each state's children, so an atomic or final state with + children, a compound state without an initial child, and a `` + without regions are all unrepresentable rather than merely rejected. +- `Show`/`Read` on every generated type, and `toStateIds`/`fromStateIds` for + storing a state outside Haskell as the SCXML configuration. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2026, Axel Ulmestig + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,288 @@ +# scxml-statecharts + +Define a [statechart](https://statecharts.dev/) in SCXML inside a Haskell +module and get typed states, events and a step function out of it. Compound +states become sum types and parallel states become products, so a value of the +state type is exactly one legal configuration: illegal states are +unrepresentable and `case` is exhaustive. + +The library exports one name, the `scxml` quasiquoter. Everything a chart needs +is generated into your own module. + +## Example + +A monitor that polls something and reports when it is healthy: + +```haskell +{-# LANGUAGE QuasiQuotes #-} +module Monitor where + +import Scxml.Statechart (scxml) +import Control.Monad.Trans.State.Strict (StateT, gets, modify') + +[scxml| + + + + + + + + + + + + + + + + + +|] + +data Monitor = Monitor {healthy :: Bool, runs :: Int, reports :: Int} + +-- Signatures for the generated functions are optional and go after the +-- quasiquote, like anything else mentioning the generated types. +initiateStateMachine :: StateT Monitor IO FsmState +notifyStateMachine :: FsmState -> FsmEvent -> StateT Monitor IO FsmState + +-- The callbacks named in ` inside `` or `` names a Haskell +function defined in the same module, after the quasiquote: + +```haskell +-- onentry: may decide where to go next by raising an event +name :: FsmState -> Maybe FsmEvent -> m (Maybe FsmEvent) +-- onexit: cleanup only, enforced by the generated code +name :: FsmState -> Maybe FsmEvent -> m () +``` + +Entry callbacks receive the state being entered, exit callbacks the state being +left. The event is the one being processed, or `Nothing` during +`initiateStateMachine`. + +Returning `Just event` raises it, which is SCXML's ``. Raised events are +queued and processed before `notifyStateMachine` returns. This is how branching +is expressed: 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 as +named events and puts the criterion in Haskell where the data is. + +A top-level splice and the declarations after it form one declaration group, so +callbacks can be defined after the quasiquote. They have to be, since they +mention the generated types. + +Callbacks need not share a constraint, only a monad. Their constraints union +at the generated call site, so one `MonadIO m` callback makes both generated +functions require `MonadIO`, while a `Monad m` callback keeps its own weaker +signature and stays usable elsewhere. Declaring the weakest constraint each +callback needs is therefore still worth it. + +## Semantics + +`notifyStateMachine` runs `` callbacks of exited states, innermost +first, then `` callbacks of entered states, outermost first. It then +processes raised events the same way until none is left, and returns. + +An event with no matching transition in the current state is ignored, as in +SCXML: the state comes back unchanged and nothing runs. A poll result arriving +after the chart moved on is the typical case. A raised event nothing handles is +dropped too. + +### A transition on an enclosing state is a default + +When an event arrives, each active state looks for a transition starting at the +innermost active state and working outward, and the first one found wins. So a +transition on an enclosing state applies everywhere inside it, and an inner +state can override it: + +```xml + + ... + + ... + + + ... + + +``` + +`Cancel` refunds while fulfilment is under way and cancels outright anywhere +else in `Processing`. Only the inner transition is taken, never both, so the +outer one is a fallback rather than an additional step. Writing the same event +on a state and on one of its descendants is therefore meaningful, not a +mistake, but it is worth a comment in the chart since the reader has to know +this rule to see which one applies. + +Entering a `` state raises `done.state.Parent`, and `done.state.G` when +every region of a parallel grandparent `G` has reached a final state. Each done +event is handled on the state it names, so completion climbs one level at a +time. That is how a parallel state completes: + +```haskell +[scxml| + + + + + + + + + + + + + + +|] +``` + +```haskell +data FsmState = Fulfilment Parcel Invoice | Complete +data Parcel = Packing | Shipped +data Invoice = Unpaid | Settled +data FsmEvent = Packed | Paid | DoneFulfilment | DoneParcel | DoneInvoice +``` + +The parallel state is a product, so both regions advance independently and the +type cannot represent one of them being absent. `done.state.X` becomes the +constructor `DoneX`. Whichever region finishes second fires it: + +```haskell +Fulfilment Packing Unpaid --Packed--> Fulfilment Shipped Unpaid --Paid--> Complete +``` + +## Storing a state + +Every generated type derives `Show`, `Read`, `Eq` and `Ord`, so `Show` and +`Read` round-trip exactly and are convenient in tests. For a state that +outlives the process, such as one parked in a database between AWS Lambda +invocations, use the generated pair: + +```haskell +serializeStateMachine (Fulfilment Shipped Unpaid) + == ["Fulfilment","Invoice","Parcel","Shipped","Unpaid"] +``` + +This is SCXML's own notion of a chart's state, so it is portable to another +implementation of the same chart, readable in a log, and queryable as a text or +JSON array in Postgres. + +The array is a set, so nothing positional leaks in. Order and duplicates in the +input do not matter, and reordering the regions of a `` in the SCXML +does not change it, even though the Haskell field order flips. Positional +formats such as `Show` do not survive that edit. + +Deserializing returns `Maybe` and validates by round-tripping, so an incomplete +set, an unknown id, or a list that merely starts like a valid configuration are +rejected rather than decoded into some other state. That matters when a chart is +redeployed while states are in flight: a value stored under the old chart fails +loudly and you migrate it deliberately. + +Two things not to persist: `Ord` on states and `fromEnum` on events. Both are +positional, so adding a state or an event changes them. + +JSON is two lines in your own module, so the library does not depend on +`aeson`: + +```haskell +instance ToJSON FsmState where + toJSON = toJSON . serializeStateMachine +instance FromJSON FsmState where + parseJSON v = parseJSON v >>= maybe (fail "stale FsmState") pure . deserializeStateMachine +``` + +## Differences from SCXML + +The quasiquoter is intolerant by design, and stricter than the specification. +A chart that compiles is a chart that runs. Loosening a rule later is a +compatible change, so the defaults are tight. + +- **No `cond` guards and no eventless transitions.** Raise an event from an + entry callback instead. +- **A transition must target a sibling of its source.** Events never cross + levels. To leave an enclosing state, declare the transition on that state, + where it applies anywhere inside it. +- **`initial` is required on every compound state** and must name a direct + child, which the model records by keeping that child first. The + specification's "first child in document order" default is not supported, + 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. +- **`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 + raises its own done event. Listening for another region's completion from + inside a sibling region is not supported; raise your own event from the final + state's `` if you want that. +- **State ids and event names must be Haskell constructor names**, and ids must + be unique across the whole chart, which SCXML requires anyway. +- **Parsing is strict.** Malformed XML cannot quietly nest one state inside + another. +- **A `` may not be a direct region of a ``.** SCXML forbids + it, and a region must be something that can be in progress. +- **Not supported yet:** `` states, wildcard event descriptors, + executable content other than ` + > + > + > + > + > |] + . + generates @FsmState@, @FsmEvent@ and the functions + @initiateStateMachine :: m FsmState@ and + @notifyStateMachine :: FsmState -> FsmEvent -> m FsmState@, which call the + callbacks named in the @\@ elements. Compound states become sum + types and parallel states become products, so a value of @FsmState@ is + 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. + +homepage: https://github.com/AxelUlmestig/scxml-statecharts +bug-reports: https://github.com/AxelUlmestig/scxml-statecharts/issues +license: BSD-3-Clause +license-file: LICENSE +author: Axel Ulmestig +maintainer: axel.ulmestig@gmail.com +copyright: (c) 2026 Axel Ulmestig +category: Control, Language +build-type: Simple +tested-with: GHC == 9.10.3 || == 9.12.4 +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/AxelUlmestig/scxml-statecharts + +common shared + default-language: GHC2021 + ghc-options: -Wall + +library + import: shared + hs-source-dirs: src + exposed-modules: + Scxml.Statechart + -- Reachable from generated code, which refers to them by names Template + -- Haskell resolved at compile time, so they need not be exposed. + other-modules: + Scxml.Statechart.Def + Scxml.Statechart.Interpret + Scxml.Statechart.Model + Scxml.Statechart.Parse + Scxml.Statechart.Run + Scxml.Statechart.TH + build-depends: + base >=4.18 && <5, + containers >=0.6.6 && <0.9, + template-haskell >=2.20 && <2.24, + text >=2.0 && <2.2, + xml-conduit >=1.9 && <1.11 + +test-suite spec + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Reordered + Overrides + build-depends: + base >=4.18 && <5, + scxml-statecharts, + text >=2.0 && <2.2, + transformers >=0.6 && <0.7 diff --git a/src/Scxml/Statechart.hs b/src/Scxml/Statechart.hs new file mode 100644 --- /dev/null +++ b/src/Scxml/Statechart.hs @@ -0,0 +1,28 @@ +-- | Typed statecharts generated from SCXML. Write the chart as SCXML in a +-- 'scxml' quasiquote at the top level of a module and get the state and event +-- types, and the functions that run them, generated into that module. See +-- 'scxml' below for a worked example. +-- +-- A compound state becomes a sum type and a parallel state a product, so a +-- value of the generated @FsmState@ is exactly one legal configuration: +-- illegal states are unrepresentable and @case@ is exhaustive. State ids and +-- event names are used verbatim as constructor names, so the generated names +-- are fixed and a module holds one chart. Callbacks are defined in the same +-- module, after the quasiquote, and must all live in the same monad, which the +-- type checker enforces. +-- +-- Signatures for the two generated functions are optional. They are inferred +-- when the callbacks are in a concrete monad; when the callbacks are +-- polymorphic, @initiateStateMachine@ takes no arguments and so needs either +-- a signature or @NoMonomorphismRestriction@. +-- +-- Two more functions are generated for storing a state outside Haskell: +-- +-- > serializeStateMachine :: FsmState -> [Text] +-- > deserializeStateMachine :: [Text] -> Maybe FsmState +-- +-- This module exports only the quasiquoter. Everything a chart needs is +-- generated into your own module, so there is nothing else to import. +module Scxml.Statechart (scxml) where + +import Scxml.Statechart.TH (scxml) diff --git a/src/Scxml/Statechart/Def.hs b/src/Scxml/Statechart/Def.hs new file mode 100644 --- /dev/null +++ b/src/Scxml/Statechart/Def.hs @@ -0,0 +1,23 @@ +-- | The typed chart definition that generated code produces. +module Scxml.Statechart.Def (Def (..)) where + +import Data.Set (Set) +import Data.Text (Text) + +import Scxml.Statechart.Model (Chart, StateId) + +-- | Ties a chart's generated types together with the untyped chart the +-- 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 + -- ^ the set of active state ids described by a typed state + , 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 new file mode 100644 --- /dev/null +++ b/src/Scxml/Statechart/Interpret.hs @@ -0,0 +1,284 @@ +-- | The evaluator. One recursive pass over the chart tree per event. +-- +-- Because a transition may only target a sibling of its source, a transition +-- never moves anything outside its parent. That collapses most of the general +-- SCXML machinery: there are no least common ancestors to find, no exit sets +-- to filter out of the whole configuration, and no conflicts to resolve +-- between transitions at different depths. A state only ever rearranges its +-- own children, so the whole algorithm is a walk down and back up, and nothing +-- needs looking up by id. +-- +-- A configuration is the set of all active states, ancestors included, as in +-- SCXML. The typed state generated for a chart is an isomorphic view of a +-- legal one. +module Scxml.Statechart.Interpret + ( Configuration + , Phase (..) + , Callbacks (..) + , doneEventName + , start + , macrostep + ) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe (listToMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T + +import Scxml.Statechart.Model + +type Configuration = Set StateId + +-- | Where a callback is attached. Exit callbacks may not raise events. +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 +-- 'Scxml.Statechart.Run.Hooks' into one of these. +newtype Callbacks m = Callbacks + { runCallback :: Phase -> Text -> Configuration -> Maybe Text -> m (Maybe Text) + -- ^ run the named callback, given the configuration it observes and the + -- event being processed ('Nothing' during 'start'); returns an event to raise + } + +-- | The event SCXML raises when a state completes. +doneEventName :: StateId -> Text +doneEventName s = T.pack "done.state." <> s + +-- 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. +data Entered = Entered + { enConfig :: Configuration + , enEntered :: [(Node, [Text])] -- ^ outermost first + , enFinal :: Bool + } + +-- | Entering a final child is what completes its parent, so the parent's done +-- event is raised just after that child's own entry callbacks. +completing :: StateId -> Node -> Entered -> Entered +completing parent target e + | nodeKind target /= Final = e + | otherwise = e {enEntered = attach (enEntered e), enFinal = True} + where + attach ((h, ds) : rest) = (h, ds ++ [doneEventName parent]) : rest + attach [] = [] + +-- | Enter a state and everything default entry into it implies. +enter :: Node -> Entered +enter n = case nodeKind n of + Atomic -> leaf False + Final -> leaf True + Compound (c :| _) -> + let below = completing (nodeId n) c (enter c) + in Entered + { enConfig = Set.insert (nodeId n) (enConfig below) + , enEntered = (n, []) : enEntered below + , enFinal = enFinal below + } + Parallel rs -> + let belows = fmap enter rs + allFinal = all enFinal belows + dones = [doneEventName (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) + , enFinal = allFinal + } + where + leaf isFin = + Entered {enConfig = Set.singleton (nodeId n), enEntered = [(n, [])], enFinal = isFin} + +-- | The active states of a subtree, innermost first, which is the order exit +-- callbacks run in. +exiting :: Configuration -> Node -> [Node] +exiting cfg n = concatMap (exiting cfg) (activeChildren cfg n) ++ [n] + +-- | The children of a state that are currently active: one for a compound +-- state, all of them for a parallel state, none for a leaf. +activeChildren :: Configuration -> Node -> [Node] +activeChildren cfg n = case nodeKind n of + Compound kids -> maybe [] pure (activeChild cfg kids) + Parallel rs -> NE.toList rs + _ -> [] + +activeChild :: Configuration -> NonEmpty Node -> Maybe Node +activeChild cfg kids = listToMaybe (NE.filter (\c -> Set.member (nodeId c) cfg) kids) + +-- | A named child. The parser has already checked that every transition +-- target is one of its source's siblings, so this cannot fail for a chart the +-- quasiquoter built. +childNamed :: StateId -> NonEmpty Node -> Node +childNamed tgt kids = case NE.filter ((== tgt) . nodeId) kids of + t : _ -> t + [] -> error ("Statechart: unknown transition target " ++ T.unpack tgt) + +-- Offering an event --------------------------------------------------------- + +-- | What a subtree reports after being offered an event. +data Reply = Reply + { rpMove :: Maybe StateId + -- ^ 'Just' when this state itself has a transition for the event. Its + -- parent performs the switch, since the target is one of the parent's + -- children. + , rpConfig :: Configuration -- ^ meaningful only when 'rpMove' is 'Nothing' + , rpExited :: [Node] -- ^ innermost first + , rpEntered :: [(Node, [Text])] -- ^ outermost first + , rpConsumed :: Bool + , rpFinal :: Bool + } + +-- | Offer an event to a subtree. Children are asked first, and a state only +-- acts on the event if nothing below it did, so the innermost transition wins +-- and a transition on an enclosing state behaves as a default. +offer :: Configuration -> Text -> Node -> Reply +offer cfg ev n = case nodeKind n of + Atomic -> own + Final -> own + Compound kids -> case activeChild cfg kids of + Nothing -> own + Just active -> + let below = offer cfg ev active + in if rpConsumed below then absorb kids active below else own + Parallel rs -> + let belows = fmap (offer cfg ev) rs + in if any rpConsumed belows then absorbRegions belows else own + where + -- This state's own transition, for its parent to perform. + own = case Map.lookup ev (nodeTransitions n) of + Just tgt -> stay {rpMove = Just tgt, rpConsumed = True} + Nothing -> stay + stay = + Reply + { rpMove = Nothing + , rpConfig = subtree cfg n + , rpExited = [] + , rpEntered = [] + , rpConsumed = False + , rpFinal = inFinalState cfg n + } + + -- A compound state whose active child either moved to a sibling or + -- settled internally. Either way this state stays put. + absorb kids active below = case rpMove below of + Nothing -> + stay + { rpConfig = Set.insert (nodeId n) (rpConfig below) + , rpExited = rpExited below + , rpEntered = rpEntered below + , rpConsumed = True + , rpFinal = nodeKind active == Final + } + Just tgt -> + let target = childNamed tgt kids + entered = completing (nodeId n) target (enter target) + in stay + { rpConfig = Set.insert (nodeId n) (enConfig entered) + , rpExited = exiting cfg active + , rpEntered = enEntered entered + , rpConsumed = True + , rpFinal = enFinal entered + } + + -- A parallel state: regions cannot have transitions, so none of them can + -- move, and their subtrees merge unchanged apart from what settled inside. + absorbRegions belows = + let allFinal = all rpFinal belows + justCompleted = allFinal && not (inFinalState cfg n) + in stay + { rpConfig = Set.insert (nodeId n) (Set.unions (fmap rpConfig (NE.toList belows))) + , rpExited = concatMap rpExited (NE.toList belows) + , rpEntered = + concatMap rpEntered (NE.toList belows) + ++ [(n, [doneEventName (nodeId n)]) | justCompleted] + , rpConsumed = True + , rpFinal = allFinal + } + + +-- | The active states of a subtree, as a set. +subtree :: Configuration -> Node -> Configuration +subtree cfg n = Set.fromList (map nodeId (exiting cfg n)) + +-- | Whether a state counts as completed: a final state is, a compound state is +-- when its active child is final, and a parallel state is when every region +-- is. Only a parallel state's own completion consults this. +inFinalState :: Configuration -> Node -> Bool +inFinalState cfg n = case nodeKind n of + Final -> True + Atomic -> False + Compound kids -> maybe False ((== Final) . nodeKind) (activeChild cfg kids) + Parallel rs -> all (inFinalState cfg) (NE.toList rs) + +-- Running ------------------------------------------------------------------- + +-- | Enter the chart's initial state, then process whatever that raises. +start :: Monad m => Chart -> Callbacks m -> m Configuration +start ch cbs = do + let entered = enter (NE.head (chartRoot ch)) + cfg = enConfig entered + raised <- runEntries cbs cfg Nothing (enEntered entered) + 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 ch cbs cfg ev = do + r <- microstep ch cbs cfg ev + case r of + Nothing -> pure Nothing + Just (cfg', raised) -> Just <$> runToCompletion ch cbs cfg' raised + +-- | 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 ch cbs = go (0 :: Int) + where + go _ cfg [] = pure cfg + go n cfg (e : rest) + | n > 1000 = error "Statechart: raised events do not terminate (a callback keeps raising an event that leads back to it)" + | otherwise = do + r <- microstep ch cbs cfg e + case r of + Nothing -> go (n + 1) cfg rest + Just (cfg', raised) -> go (n + 1) cfg' (rest ++ raised) + +-- | 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 ch cbs cfg ev = + case activeChild cfg (chartRoot ch) of + Nothing -> pure Nothing + Just active -> + let below = offer cfg ev active + in if not (rpConsumed below) + then pure Nothing + else do + let (cfg', exited, entered) = case rpMove below of + Nothing -> (rpConfig below, rpExited below, rpEntered below) + Just tgt -> + let e = enter (childNamed tgt (chartRoot ch)) + in (enConfig e, exiting cfg active, enEntered e) + mapM_ (runExits cbs cfg ev) exited + raised <- runEntries cbs cfg' (Just ev) entered + 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 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 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) diff --git a/src/Scxml/Statechart/Model.hs b/src/Scxml/Statechart/Model.hs new file mode 100644 --- /dev/null +++ b/src/Scxml/Statechart/Model.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveLift #-} +-- | The untyped statechart model. This is what the SCXML parser produces and +-- what the evaluator runs on. The Template Haskell layer generates typed +-- wrappers around it. +-- +-- The chart is a tree and nothing else: a state owns its children, so a +-- dangling child cannot be represented, and there is no parent link or +-- document index to disagree with the structure. Since a transition may only +-- target a sibling, every consumer works by walking the tree, so none of that +-- would have a reader anyway. +module Scxml.Statechart.Model + ( -- * The tree + StateId + , Kind (..) + , Node (..) + , Chart (..) + , nodeChildren + , childrenOfKind + , initialChild + , isParallel + , completes + , chartStates + ) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import Data.Text (Text) +import Language.Haskell.TH.Syntax (Lift) + +-- | A state's @id@ attribute, which is also its Haskell constructor name. +type StateId = Text + +-- | What kind of state a node is, together with the children it owns: +-- +-- * 'Atomic' is a leaf and 'Final' is terminal, so neither has children. +-- * 'Compound' has children of which exactly one is active. The first is the +-- one entering it leads to, so a compound state cannot lack an initial +-- child or name one that is not its own. +-- * 'Parallel' has regions, all of which are active at once, so there is no +-- initial one to choose. Their order is document order. +data Kind + = Atomic + | Compound (NonEmpty Node) + | Parallel (NonEmpty Node) + | Final + deriving (Eq, Show, Lift) + +-- | One state and everything inside it. +data Node = Node + { nodeId :: StateId + , nodeKind :: Kind + , nodeTransitions :: Map Text StateId + -- ^ event name to the sibling state it enters. At most one transition per + -- event, so nothing has to break a tie. + , nodeOnEntry :: [Text] -- ^ names of @") + | otherwise = Right [] + +-- | The child state that entering a compound state (or the @@ root) +-- leads to. Required, exactly one, and a direct child: entering must not +-- reach into another state's interior, the same rule transitions follow. +initialOf :: String -> Element -> [StateId] -> Either String StateId +initialOf label el children = + case (attr "initial" el, childrenNamed ["initial"] el) of + (Just i, []) -> one "initial attribute" i + (Nothing, [ie]) -> case childrenNamed ["transition"] ie of + [t] | Just tg <- attr "target" t -> one " transition target" tg + _ -> Left (label ++ ": must contain exactly one ") + (Nothing, []) -> + Left $ + label ++ ": needs an initial attribute naming the child state to enter, for example initial=" + ++ show (maybe "..." T.unpack (listToMaybe children)) + (Just _, _ : _) -> Left (label ++ ": has both an initial attribute and an element") + (Nothing, _ : _ : _) -> Left (label ++ ": has more than one element") + where + one what s = case map T.pack (words s) of + [c] + | c `elem` children -> Right c + | otherwise -> + Left $ + label ++ ": " ++ what ++ " " ++ show (T.unpack c) ++ " must name one of its direct child states (" + ++ intercalate ", " (map T.unpack children) + ++ "); entering a state may not reach into another state's interior" + [] -> Left (label ++ ": empty " ++ what) + cs -> + Left $ + label ++ ": " ++ what ++ " names several states (" ++ unwords (map T.unpack cs) + ++ "); exactly one child state is required" + +buildNode :: Element -> P Node +buildNode el = do + let tag = localName el + when (tag == "history") $ throwP " states are not supported yet" + unless (tag `elem` ["state", "parallel", "final"]) $ + throwP ("unexpected element <" ++ tag ++ "> where a state was expected") + sid <- case attr "id" el of + Just i -> liftE (checkConName ("<" ++ tag ++ "> id") i) >> pure (T.pack i) + Nothing -> throwP ("<" ++ tag ++ "> without an id attribute") + let label = "<" ++ tag ++ " id=\"" ++ T.unpack sid ++ "\">" + forM_ (elChildren el) $ \c -> + unless (localName c `elem` allowedChildren) $ + throwP (label ++ ": unexpected child element <" ++ localName c ++ ">") + (pairs, children) <- buildChildren label el + trans <- liftE (transitionMap label pairs) + onEntry <- liftE (concat <$> mapM (scriptsOf (label ++ " ")) (childrenNamed ["onentry"] el)) + onExit <- liftE (concat <$> mapM (scriptsOf (label ++ " ")) (childrenNamed ["onexit"] el)) + kind <- case (tag, NE.nonEmpty children) of + ("parallel", Nothing) -> throwP (label ++ ": must contain at least one region") + ("parallel", Just regions) -> do + when (hasInitial el) $ throwP (label ++ ": cannot specify an initial state; every region is entered") + forM_ regions $ \r -> + when (nodeKind r == Final) $ + throwP $ + label ++ ": region " ++ T.unpack (nodeId r) ++ " is a state, which SCXML does not allow" + ++ " inside and which would report the whole complete before the other" + ++ " regions had run. A region must be a state that can be in progress." + forM_ regions $ \r -> + unless (Map.null (nodeTransitions r)) $ + throwP $ + T.unpack (nodeId r) ++ " is a region of the " ++ T.unpack sid + ++ " and cannot have transitions: its sibling regions are active at the same time, so leaving it would leave them behind." + ++ " Declare the transition on " ++ T.unpack sid ++ " or on a state inside " ++ T.unpack (nodeId r) ++ "." + pure (Parallel regions) + ("final", _) -> do + unless (null children) $ throwP (label ++ ": final states cannot contain states") + unless (Map.null trans) $ throwP (label ++ ": final states cannot have transitions") + when (hasInitial el) $ throwP (label ++ ": final states cannot specify an initial state") + pure Final + (_, Nothing) -> do + when (hasInitial el) $ throwP (label ++ ": atomic states cannot specify an initial state") + pure Atomic + (_, Just kids) -> do + initial <- liftE (initialOf label el (map nodeId children)) + Compound <$> liftE (initialFirst label initial kids) + pure + Node + { nodeId = sid + , nodeKind = kind + , nodeTransitions = trans + , nodeOnEntry = onEntry + , nodeOnExit = onExit + } + +-- | Transitions and descendant nodes of an element, numbered in textual order. +buildChildren :: String -> Element -> P ([(Text, StateId)], [Node]) +buildChildren label el = go (elChildren el) + where + go [] = pure ([], []) + go (c : rest) + | localName c == "transition" = do + t <- buildTransition label c + (ts, ns) <- go rest + 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)] +buildTransition label el = do + let events = 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 ++ ": +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > |] +-- > +-- > report :: FsmState -> Maybe FsmEvent -> IO (Maybe FsmEvent) +-- > report st _ = print st >> pure Nothing +-- +-- State ids and event names are used verbatim, so that declares @FsmState@ +-- with constructors @Off@ and @On@, @FsmEvent@ with @Flip@, and: +-- +-- > initiateStateMachine :: IO FsmState +-- > notifyStateMachine :: FsmState -> FsmEvent -> IO FsmState +-- +-- Callbacks are ordinary functions in the same module, written after the +-- quasiquote, and are found by the name in @\@: +-- +-- > ghci> off <- initiateStateMachine +-- > Off +-- > ghci> on <- notifyStateMachine off Flip +-- > On +-- +-- The callbacks all share one monad, which the type checker enforces. @IO@ is +-- enough to print; when a chart has to carry something along, put the +-- callbacks in a @StateT@ over it and the generated functions follow suit: +-- +-- > record :: FsmState -> Maybe FsmEvent -> StateT [FsmState] IO (Maybe FsmEvent) +-- > record st _ = modify (st :) >> pure Nothing +-- > +-- > -- initiateStateMachine :: StateT [FsmState] IO FsmState +-- > -- 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. +scxml :: QuasiQuoter +scxml = + QuasiQuoter + { quoteExp = const unsupported + , quotePat = const unsupported + , quoteType = const unsupported + , quoteDec = generate + } + where + unsupported = fail "scxml: only usable as a top-level declaration, e.g. [scxml| |]" + +-- | A compound-like node (the root or a @@ with children) becomes its +-- own data type with helpers converting to and from configurations. +data Group = Group + { gType :: Name + , gChildren :: [Node] + , gTo :: Name + , gFrom :: Name + } + +generate :: String -> Q [Dec] +generate src = do + ch <- orFail (parseScxml src) + -- Everything here is a walk of the tree: a node carries its own children, + -- so nothing needs looking up by id. + let states = chartStates ch + let stateT = mkName "FsmState" + eventT = mkName "FsmEvent" + defName = mkName "fsmChart" + startName = mkName "initiateStateMachine" + stepName = mkName "notifyStateMachine" + toIdsName = mkName "serializeStateMachine" + fromIdsName = mkName "deserializeStateMachine" + -- A compound state's type has the same name as its constructor; Haskell + -- keeps types and constructors in separate namespaces. + nameFor sid = mkName (T.unpack sid) + compounds = [n | n <- states, Compound _ <- [nodeKind n]] + + -- Callback names + let entryActions = nub (concatMap nodeOnEntry states) + exitActions = nub (concatMap nodeOnExit states) + mapM_ (orFail . checkVarName) (nub (entryActions ++ exitActions)) + + -- 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 + + groups <- forM (Nothing : map Just compounds) $ \g -> do + let ty = maybe stateT (nameFor . nodeId) g + to <- newName ("toCfg_" ++ nameBase ty) + from <- newName ("fromCfg_" ++ nameBase ty) + let children = maybe (NE.toList (chartRoot ch)) nodeChildren g + pure (g, Group ty children to from) + let groupMap = Map.fromList [(nodeId n, grp) | (Just n, grp) <- groups] + rootGroup <- case groups of + (_, g) : _ -> pure g + [] -> fail "scxml: internal error, no root group" + let groupOf sid = case Map.lookup sid groupMap of + Just grp -> pure grp + Nothing -> fail ("scxml: internal error, no group for " ++ T.unpack sid) + + -- Every generated constructor and type, with its origin, so clashes give a + -- readable error instead of "Multiple declarations". + let stateCons = + [ (nameFor (nodeId n), "state " ++ show (T.unpack (nodeId n))) + | n <- concatMap (gChildren . snd) groups + ] + typeNames = + [(stateT, "the state type"), (eventT, "the event type")] + ++ [(gType grp, "compound state " ++ show (T.unpack (nodeId n))) | (Just n, grp) <- groups] + checkClashes "constructor" (stateCons ++ eventCons) + checkClashes "type" typeNames + + 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]))] + + 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) $ + foldr + (\((c, _), e) rest -> [| if $(varE t) == $(lift e) then Just $(conE c) else $rest |]) + [| Nothing |] + (zip eventCons events) + + defSig <- sigD defName [t| Def $(conT stateT) $(conT eventT) |] + defDec <- + valD (varP defName) + (normalB + [| Def + { defChart = $(lift ch) + , defEventName = $eventNameE + , defEventFromName = $eventFromNameE + , defToConfig = $(varE (gTo rootGroup)) + , defFromConfig = $(varE (gFrom rootGroup)) + } |]) + [] + + -- Hooks dispatching to the callbacks named in the SCXML. Entry callbacks + -- return m (Maybe FsmEvent), exit callbacks m (). Inlined into each + -- generated function rather than shared, so a polymorphic monad does not + -- hit the monomorphism restriction. + -- Underscore-prefixed so that a chart with no callbacks of some phase does + -- not emit an unused-match warning in the user's module. + let hooksE = do + phase <- newName "_phase" + name <- newName "_name" + st <- newName "_st" + ev <- newName "_ev" + let call fn = [| $(varE (mkName (T.unpack fn))) $(varE st) $(varE ev) |] + entryChain = + foldr (\fn rest -> [| if $(varE name) == $(lift fn) then Run.entryAction $(call fn) else $rest |]) + [| pure Nothing |] entryActions + exitChain = + foldr (\fn rest -> [| if $(varE name) == $(lift fn) then Run.exitAction $(call fn) else $rest |]) + [| pure () |] exitActions + body <- caseE (varE phase) + [ match (conP 'Run.OnExit []) (normalB [| $exitChain >> pure Nothing |]) [] + , match (conP 'Run.OnEntry []) (normalB entryChain) [] + ] + [| Run.Hooks $(lamE [varP phase, varP name, varP st, varP ev] (pure body)) |] + startDec <- valD (varP startName) (normalB [| Run.start $(varE defName) $hooksE |]) [] + stepDec <- do + st <- newName "st" + ev <- newName "ev" + funD stepName [clause [varP st, varP ev] (normalB [| Run.stepOrStay $(varE defName) $hooksE $(varE st) $(varE ev) |]) []] + + -- Storing a state outside Haskell, as the set of active state ids. Generated + -- rather than exported so that a chart needs no imports beyond the + -- quasiquoter itself. + let toCfg = varE (gTo rootGroup) + fromCfg = varE (gFrom rootGroup) + toIdsSig <- sigD toIdsName [t| $(conT stateT) -> [Text] |] + toIdsDec <- do + x <- newName "st" + funD toIdsName [clause [varP x] (normalB [| Set.toAscList ($toCfg $(varE x)) |]) []] + fromIdsSig <- sigD fromIdsName [t| [Text] -> Maybe $(conT stateT) |] + fromIdsDec <- do + ids <- newName "ids" + given <- newName "given" + st <- newName "st" + let body = + [| let $(varP given) = Set.fromList $(varE ids) + in case $fromCfg $(varE given) of + -- Round-trip so that a set which merely starts like a valid + -- one, or is missing part of a configuration, is rejected. + Just $(varP st) | $toCfg $(varE st) == $(varE given) -> Just $(varE st) + _ -> Nothing |] + funD fromIdsName [clause [varP ids] (normalB body) []] + + pure (stateDecs ++ [eventDec, defSig, defDec, startDec, stepDec, toIdsSig, toIdsDec, fromIdsSig, fromIdsDec]) + +-- | Data type plus configuration conversions for one compound-like node. +groupDecs :: (StateId -> Name) -> (StateId -> Q Group) -> Group -> Q [Dec] +groupDecs nameFor groupOf grp = do + shapes <- mapM childShape (gChildren grp) + let dataDec = + dataD (cxt []) (gType grp) [] Nothing + [normalC con [bangType (bang noSourceUnpackedness noSourceStrictness) (conT f) | f <- fields] | (con, fields, _, _) <- shapes] + [derivClause Nothing (map conT [''Show, ''Read, ''Eq, ''Ord])] + toDec = do + x <- newName "x" + alts <- forM shapes $ \(con, fields, toE, _) -> do + vars <- mapM (const (newName "r")) fields + match (conP con (map varP vars)) (normalB (toE vars)) [] + funD (gTo grp) [clause [varP x] (normalB (caseE (varE x) (map pure alts))) []] + fromDec = do + cfg <- newName "cfg" + let body = + foldr + (\(n, (_, _, _, rebuild)) rest -> [| if Set.member $(lift (nodeId n)) $(varE cfg) then $(rebuild cfg) else $rest |]) + [| Nothing |] + (zip (gChildren grp) shapes) + funD (gFrom grp) [clause [varP cfg] (normalB body) []] + sequence + [ dataDec + , sigD (gTo grp) [t| $(conT (gType grp)) -> Set.Set Text |] + , toDec + , sigD (gFrom grp) [t| Set.Set Text -> Maybe $(conT (gType grp)) |] + , fromDec + ] + where + -- For one child: (constructor, field types, config-of-fields, rebuild-from-config) + childShape :: Node -> Q (Name, [Name], [Name] -> Q Exp, Name -> Q Exp) + childShape node = do + let sid = nodeId node + con = nameFor sid + case nodeKind node of + Compound _ -> do + sub <- groupOf sid + pure + ( con + , [gType sub] + , \vs -> case vs of + [v] -> [| Set.insert $(lift sid) ($(varE (gTo sub)) $(varE v)) |] + _ -> fail "scxml: internal error, compound state expects exactly one field" + , \cfg -> [| fmap $(conE con) ($(varE (gFrom sub)) $(varE cfg)) |] + ) + Parallel regionNodes -> do + regions <- forM (NE.toList regionNodes) $ \rn -> case nodeKind rn of + Compound _ -> Just <$> groupOf (nodeId rn) + Parallel _ -> + fail $ + "scxml: " ++ T.unpack (nodeId rn) ++ " is directly inside another , which is not supported." + ++ " Flatten it: its regions can become regions of the outer , since all of them are active at once either way." + ++ " The only thing flattening loses is a done.state event for the inner one on its own." + _ -> pure Nothing + let regionIds = map nodeId (NE.toList regionNodes) + fieldTypes = [gType g | Just g <- regions] + toE vs = + let go [] _ = [] + go ((r, Nothing) : rest) vars = [| Set.singleton $(lift r) |] : go rest vars + go ((r, Just g) : rest) (v : vars) = [| Set.insert $(lift r) ($(varE (gTo g)) $(varE v)) |] : go rest vars + go _ [] = error "scxml: internal error, region/field mismatch" + in [| Set.insert $(lift sid) (Set.unions $(listE (go (zip regionIds regions) vs))) |] + rebuild cfg = foldl (\acc g -> [| $acc <*> $(varE (gFrom g)) $(varE cfg) |]) [| pure $(conE con) |] [g | Just g <- regions] + pure (con, fieldTypes, toE, rebuild) + _ -> + pure + ( con + , [] + , \_ -> [| Set.singleton $(lift sid) |] + , \_ -> [| Just $(conE con) |] + ) + +checkClashes :: String -> [(Name, String)] -> Q () +checkClashes what named = do + let byName = Map.fromListWith (++) [(nameBase n, [origin]) | (n, origin) <- named] + clashes = [(n, os) | (n, os) <- Map.toList byName, length os > 1] + unless (null clashes) $ + fail $ unlines $ + ("scxml: generated " ++ what ++ " names clash; rename one of the SCXML identifiers:") + : [" " ++ n ++ " would be generated for " ++ commaList (reverse os) | (n, os) <- clashes] + where + commaList [a, b] = a ++ " and " ++ b + commaList xs = foldr1 (\a b -> a ++ ", " ++ b) xs + +-- | Callback names in @ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +|] + +-- The quasiquote above generates: +-- +-- data FsmState = Draft | Validating | Processing Processing +-- | Completed | Rejected | Cancelled +-- data Processing = Authorizing | Fulfilment Shipping Invoicing | Fulfilled +-- data Shipping = Packing | Shipped +-- data Invoicing = Unpaid | Settled +-- data FsmEvent = Submit | Discard | Abandon | Valid | Invalid | Poll +-- | PaymentAuthorized | Packed | Paid | DoneFulfilment +-- | PaymentDeclined | DoneProcessing | Cancel +-- | DoneShipping | DoneInvoicing +-- initiateStateMachine, notifyStateMachine -- signatures below are ours +-- serializeStateMachine :: FsmState -> [Text] +-- deserializeStateMachine :: [Text] -> Maybe FsmState + +-- | The "datamodel": whatever the callbacks need lives in the monad. +data Shop = Shop + { items :: [Text] + , prepaid :: Bool + , reserved :: Int + , log_ :: [Text] + } + deriving (Show) + +type M = StateT Shop IO + +initiateStateMachine :: M FsmState +notifyStateMachine :: FsmState -> FsmEvent -> M FsmState + +-- Callbacks named in the SCXML. Entry callbacks return m (Maybe FsmEvent), +-- raising an event with Just; exit callbacks return m (). All in one monad, +-- or it does not compile. + +-- | A choice state's entry callback: decide by raising an event. +validate :: FsmState -> Maybe FsmEvent -> M (Maybe FsmEvent) +validate _ _ = do + ok <- gets (not . null . items) + pure (Just (if ok then Valid else Invalid)) + +-- | Poll something on entry; move on immediately if it is already settled. +-- Re-entered by the Poll self-transition, which is how polling replaces a +-- transition script. +checkPrepayment :: FsmState -> Maybe FsmEvent -> M (Maybe FsmEvent) +checkPrepayment _ _ = do + say "checked prepayment" + paid <- gets prepaid + pure (if paid then Just PaymentAuthorized else Nothing) + +-- Entry callbacks that raise nothing still say so, with pure Nothing. +reserveStock, notifyCustomer :: FsmState -> Maybe FsmEvent -> M (Maybe FsmEvent) +reserveStock _ _ = do + n <- gets (length . items) + modify' (\s -> s {reserved = n}) + say "reserved stock" + pure Nothing +-- Entry callbacks see the state entered and the event that caused it. +notifyCustomer s ev = do + say ("notified customer: " <> tshow s <> " after " <> maybe "start" tshow ev) + pure Nothing + +-- Exit callbacks see the state being left, and cannot raise. +releaseStock :: FsmState -> Maybe FsmEvent -> M () +releaseStock s _ = modify' (\s' -> s' {reserved = 0}) >> say ("released stock leaving " <> tshow s) + +say :: Text -> M () +say t = modify' (\s -> s {log_ = log_ s ++ [t]}) + +tshow :: Show a => a -> Text +tshow = T.pack . show + +-- | Deliver one event from a given state, discarding the datamodel. +stepFrom :: Shop -> FsmState -> FsmEvent -> IO FsmState +stepFrom shop s e = fst <$> runStateT (notifyStateMachine s e) shop + +-- | Start the chart and feed events. Returns the final state and the datamodel. +runEvents :: Shop -> [FsmEvent] -> IO (FsmState, Shop) +runEvents shop evs = runStateT (initiateStateMachine >>= go evs) shop + where + go [] s = pure s + go (e : rest) s = notifyStateMachine s e >>= go rest + +shopWith :: [Text] -> Shop +shopWith is = Shop {items = is, prepaid = False, reserved = 0, log_ = []} + +main :: IO () +main = do + failures <- newIORef (0 :: Int) + let check :: (Eq a, Show a) => String -> a -> a -> IO () + check label expected actual = + unless (expected == actual) $ do + putStrLn ("FAIL " ++ label ++ "\n expected: " ++ show expected ++ "\n actual: " ++ show actual) + modifyIORef failures (+ 1) + + -- Happy path. Submit passes through Validating (its callback raises Valid), + -- both regions reach final states, done.state.Fulfilment fires, and the + -- callbacks run in SCXML order with the state and event they observe. + (end, shop) <- runEvents (shopWith ["book"]) [Submit, PaymentAuthorized, Paid, Packed] + check "happy path reaches Completed" Completed end + -- Completion climbs one level at a time: Fulfilment finishing moves it to + -- the final state Fulfilled, which completes Processing, whose own done + -- event leaves it. All inside one call, so the caller sees only Completed. + check "callbacks in order, with state and event" + [ "reserved stock" + , "checked prepayment" + , "released stock leaving Processing Fulfilled" + , "notified customer: Completed after DoneProcessing" + ] + (log_ shop) + check "release resets the reservation" 0 (reserved shop) + + -- The choice state decides from the datamodel: no items, so Invalid is + -- raised and nothing else runs. + (end2, shopEmpty) <- runEvents (shopWith []) [Submit] + check "empty order is rejected" Rejected end2 + check "no effects for a rejected order" [] (log_ shopEmpty) + + -- The choice state is transient: one Submit lands in Processing. + (end2b, _) <- runEvents (shopWith ["book"]) [Submit] + check "validating never rests" (Processing Authorizing) end2b + + -- Polling via a self-transition, the replacement for a transition script. + -- Re-entering Authorizing re-runs its entry callback, which now sees the + -- payment as settled and raises the event that moves the chart on. + (end2c, shopPoll) <- runStateT + ( do + s0 <- initiateStateMachine + s1 <- notifyStateMachine s0 Submit + s2 <- notifyStateMachine s1 Poll + modify' (\sh -> sh {prepaid = True}) -- the third party settles + notifyStateMachine s2 Poll + ) + (shopWith ["book"]) + check "polling moves on once the check succeeds" (Processing (Fulfilment Packing Unpaid)) end2c + check "each poll re-runs the entry callback" + ["reserved stock", "checked prepayment", "checked prepayment", "checked prepayment"] + (log_ shopPoll) + + -- Moving a transition up a level widens where it applies: PaymentDeclined + -- is declared on Processing, so it now rejects from inside Fulfilment too, + -- where before (declared on Authorizing) it was ignored. + (end2d, _) <- runEvents (shopWith ["book"]) [Submit, PaymentAuthorized, PaymentDeclined] + check "a transition on the enclosing state applies anywhere inside it" Rejected end2d + (end2e, _) <- runEvents (shopWith ["book"]) [Submit, PaymentDeclined] + check "and still applies at the level it used to be on" Rejected end2e + + -- A transition on the parent applies anywhere inside it, and runs its onexit. + (end3, shop3) <- runEvents (shopWith ["book"]) [Submit, PaymentAuthorized, Packed, Cancel] + check "cancel from inside Fulfilment" Cancelled end3 + check "cancel releases stock" + ["reserved stock", "checked prepayment", "released stock leaving Processing (Fulfilment Shipped Unpaid)"] + (log_ shop3) + + -- An event with no transition in the current state is ignored: same state, + -- no effects. + (end4, shop4) <- runEvents (shopWith ["book"]) [Submit, Packed, Paid, Cancel, Cancel] + check "unhandled events leave the state alone" Cancelled end4 + check "unhandled events run nothing" + ["reserved stock", "checked prepayment", "released stock leaving Processing Authorizing"] + (log_ shop4) + + -- An entry callback raising an event: processed before the step returns. + (end5, shop5) <- runEvents (shopWith ["book"]) {prepaid = True} [Submit] + check "raised event is processed in the same step" (Processing (Fulfilment Packing Unpaid)) end5 + check "raised event effects" ["reserved stock", "checked prepayment"] (log_ shop5) + + -- Regions are independent; one region completing does not complete the parallel. + (end6, _) <- runEvents (shopWith ["book"]) [Submit, PaymentAuthorized, Packed] + check "one region done" (Processing (Fulfilment Shipped Unpaid)) end6 + + -- Behaviour reachable only through the generated functions, since the + -- library exports nothing but the quasiquoter. + (started, _) <- runStateT initiateStateMachine (shopWith ["book"]) + check "the chart starts in its initial state" Draft started + doneFired <- stepFrom (shopWith ["book"]) (Processing (Fulfilment Shipped Unpaid)) Paid + check "the last region completing fires the done event" Completed doneFired + ignored <- stepFrom (shopWith ["book"]) Draft Paid + check "an event with no transition here leaves the state alone" Draft ignored + stayed <- stepFrom (shopWith ["book"]) (Processing Authorizing) Poll + 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" + (Cancelled, Cancelled) (viaDiscard, viaAbandon) + check "all events, in document order" + [ Submit, Discard, Abandon, Valid, Invalid, Poll, PaymentAuthorized, Packed + , Paid, DoneFulfilment, PaymentDeclined, DoneProcessing, Cancel + , DoneShipping, DoneInvoicing ] + [minBound .. maxBound :: FsmEvent] + + -- Serialization. Show/Read round-trips exactly; the id list is the portable + -- form, and rejects anything that is not a configuration of this chart. + let deep = Processing (Fulfilment Shipped Unpaid) + check "Read round-trips" deep (read (show deep)) + check "state ids" ["Fulfilment", "Invoicing", "Processing", "Shipped", "Shipping", "Unpaid"] + (serializeStateMachine deep) + check "id round-trip, nested" (Just deep) (deserializeStateMachine (serializeStateMachine deep)) + check "id round-trip, atomic" (Just Draft) (deserializeStateMachine (serializeStateMachine Draft)) + check "id order and duplicates do not matter" (Just deep) + (deserializeStateMachine (reverse (serializeStateMachine deep) ++ ["Processing"])) + check "an id list that merely starts valid is rejected" Nothing + (deserializeStateMachine ["Draft", "Processing"]) + check "an incomplete configuration is rejected" Nothing + (deserializeStateMachine ["Processing"]) + check "an unknown id is rejected" Nothing (deserializeStateMachine ["Archived"]) + check "an empty list is rejected" Nothing (deserializeStateMachine []) + + -- 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) + + n <- readIORef failures + when (n > 0) exitFailure + putStrLn "all checks passed" diff --git a/test/Overrides.hs b/test/Overrides.hs new file mode 100644 --- /dev/null +++ b/test/Overrides.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE QuasiQuotes #-} +-- | Two behaviours nothing else covers: a transition on an enclosing state +-- acting as a default that an inner state overrides, and several entry +-- callbacks on one state each raising an event. +module Overrides where + +import Control.Monad.Trans.State.Strict (StateT, modify', runStateT) +import Scxml.Statechart (scxml) + +[scxml| + + + + + + + + + + + + + + + + + + +|] + +initiateStateMachine :: StateT [String] IO FsmState +notifyStateMachine :: FsmState -> FsmEvent -> StateT [String] IO FsmState + +noteEntry, raiseYes, raiseNo :: FsmState -> Maybe FsmEvent -> StateT [String] IO (Maybe FsmEvent) +noteEntry _ _ = modify' (++ ["entered Middle"]) >> pure Nothing +raiseYes _ _ = modify' (++ ["raising Yes"]) >> pure (Just Yes) +raiseNo _ _ = modify' (++ ["raising No"]) >> pure (Just No) + +-- | Checks to run, as (label, expected, actual) triples. +spec :: IO [(String, String, String)] +spec = do + -- Poke while Inner is active: the inner transition wins, so we do not leave + -- Outer. Middle's three entry callbacks all run, and the first event raised + -- decides where we land; the second arrives in Yeah, which ignores it. + (afterPoke, lg) <- runStateT (initiateStateMachine >>= \s -> notifyStateMachine s Poke) [] + -- Poke again from Yeah, which has no Poke of its own, so Outer's applies. + (afterAgain, _) <- runStateT (notifyStateMachine afterPoke Poke) [] + pure + [ ("an inner transition overrides the enclosing default", show (Outer Yeah), show afterPoke) + , ("every entry callback runs, in document order" + , show ["entered Middle", "raising Yes", "raising No"] + , show lg + ) + , ("the enclosing default applies where nothing inner handles the event" + , show Away + , show afterAgain + ) + ] diff --git a/test/Reordered.hs b/test/Reordered.hs new file mode 100644 --- /dev/null +++ b/test/Reordered.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE QuasiQuotes #-} +-- | A chart whose initial states are deliberately not written first, to pin +-- what that does to the generated types. The model keeps a compound state's +-- children with the initial one first, so a compound state cannot name an +-- initial child that is not its own. That order shows up in the generated +-- constructors, and therefore in derived 'Ord'. +-- A chart module should not use an explicit export list, or it will get +-- unused-binding warnings for the generated functions it does not call. +module Reordered where + +import Scxml.Statechart (scxml) + +[scxml| + + + + + + + + +|] + +-- Generated, with the initial child first in each: +-- +-- data FsmState = Job Job | Done +-- data Job = Third | First | Second + +initiateStateMachine :: IO FsmState +notifyStateMachine :: FsmState -> FsmEvent -> IO FsmState + +-- | Checks to run, as (label, expected, actual) triples. +spec :: IO [(String, String, String)] +spec = do + started <- initiateStateMachine + back <- notifyStateMachine started Back + forth <- notifyStateMachine back Go + pure + [ ("the initial child is entered even when written last", show (Job Third), show started) + , ("transitions between siblings still work", show (Job First), show back) + , ("and back again", show (Job Third), show forth) + , -- Third is the initial child so it is the first constructor, which makes + -- it compare less than the states written before it in the XML. + ("Ord follows the initial-first constructor order", show GT, show (compare (Job First) (Job Third))) + , ("Done sorts after Job, though written before it", show LT, show (compare (Job Second) Done)) + , ("serializing is unaffected by the reordering", show ["Job", "Third"], show (serializeStateMachine started)) + ]