scxml-statecharts (empty) → 0.1.0.0

raw patch · 14 files changed

+2132/−0 lines, 14 filesdep +basedep +containersdep +scxml-statecharts

Dependencies added: base, containers, scxml-statecharts, template-haskell, text, transformers, xml-conduit

Files

• CHANGELOG.md +57/−0
• LICENSE +30/−0
• README.md +288/−0
• scxml-statecharts.cabal +90/−0
• src/Scxml/Statechart.hs +28/−0
• src/Scxml/Statechart/Def.hs +23/−0
• src/Scxml/Statechart/Interpret.hs +284/−0
• src/Scxml/Statechart/Model.hs +103/−0
• src/Scxml/Statechart/Parse.hs +385/−0
• src/Scxml/Statechart/Run.hs +72/−0
• src/Scxml/Statechart/TH.hs +373/−0
• test/Main.hs +294/−0
• test/Overrides.hs +58/−0
• test/Reordered.hs +47/−0

@@ -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),+  `<onentry>` and `<onexit>` 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+  `<parallel>`. `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 `<final>` state is rejected as a direct region of a `<parallel>`. 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 `<final>` 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 `<parallel>`+  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.

@@ -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.

@@ -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|+<scxml initial="Idle">+  <state id="Idle">+    <transition event="Check" target="Polling"/>+  </state>+  <state id="Polling" initial="Fetching">+    <onexit><script>recordRun</script></onexit>+    <state id="Fetching">+      <onentry><script>fetchStatus</script></onentry>+      <transition event="Ok" target="Reporting"/>+    </state>+    <state id="Reporting">+      <onentry><script>sendReport</script></onentry>+    </state>+    <transition event="Done" target="Idle"/>+    <transition event="Failed" target="Idle"/>+  </state>+</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 <script>. They must share one monad, and the type+-- checker enforces it.+fetchStatus, sendReport :: FsmState -> Maybe FsmEvent -> StateT Monitor IO (Maybe FsmEvent)+fetchStatus _ _ = gets (\m -> Just (if healthy m then Ok else Failed))+sendReport _ _ = modify' (\m -> m {reports = reports m + 1}) >> pure (Just Done)++recordRun :: FsmState -> Maybe FsmEvent -> StateT Monitor IO ()+recordRun _ _ = modify' (\m -> m {runs = runs m + 1})+```++The quasiquote generates:++```haskell+data FsmState = Idle | Polling Polling+data Polling  = Fetching | Reporting+data FsmEvent = Check | Ok | Done | Failed++initiateStateMachine    -- enter the initial state, running its entry callbacks+notifyStateMachine      -- deliver one event+serializeStateMachine   :: FsmState -> [Text]+deserializeStateMachine :: [Text] -> Maybe FsmState+```++A compound state becomes a constructor carrying a sum type of the same name,+which Haskell allows since types and constructors live in separate namespaces.+Names in the XML are used verbatim, so they must be valid constructor names+(`PaymentAuthorized`, not `payment.authorized`).++A compound state's initial child is always its first constructor, whether or+not you wrote it first, so derived `Ord` follows that rather than document+order. Use `Ord` for `Map` keys and sorting, not for anything you store.++Do not give a chart module an explicit export list, or the generated functions+you do not call will draw unused-binding warnings.++One `Check` runs the whole cycle. The chart enters `Polling` and `Fetching`,+whose entry callback raises `Ok` or `Failed`, and either way it returns to+`Idle` before `notifyStateMachine` hands back. Anything the callbacks need+lives in the monad, which plays the role of the SCXML datamodel.++## Callbacks++`<script>name</script>` inside `<onentry>` or `<onexit>` 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 `<raise>`. 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 `<onexit>` callbacks of exited states, innermost+first, then `<onentry>` 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+<state id="Processing" initial="Authorizing">+  <state id="Authorizing">...</state>+  <parallel id="Fulfilment">+    ...+    <transition event="Cancel" target="Refunding"/>   <!-- wins while fulfilling -->+  </parallel>+  <state id="Refunding">...</state>+  <transition event="Cancel" target="Cancelled"/>     <!-- applies elsewhere inside -->+</state>+```++`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 `<final>` 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|+<scxml initial="Fulfilment">+  <parallel id="Fulfilment">+    <state id="Parcel" initial="Packing">+      <state id="Packing"><transition event="Packed" target="Shipped"/></state>+      <final id="Shipped"/>+    </state>+    <state id="Invoice" initial="Unpaid">+      <state id="Unpaid"><transition event="Paid" target="Settled"/></state>+      <final id="Settled"/>+    </state>+    <transition event="done.state.Fulfilment" target="Complete"/>+  </parallel>+  <final id="Complete"/>+</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 `<parallel>` 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 `<final>` 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 `<onentry>` 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 `<final>` may not be a direct region of a `<parallel>`.** SCXML forbids+  it, and a region must be something that can be in progress.+- **Not supported yet:** `<history>` states, wildcard event descriptors,+  executable content other than `<script>`, and a `<parallel>` directly inside+  another `<parallel>`, which can almost always be flattened into one.++## Building++```+cabal build+cabal test+```++The toolchain comes from a Nix flake. With direnv, `direnv allow` puts GHC+9.10.3, cabal and haskell-language-server on the path on entering the+directory; without it, `nix develop`. Two further shells hold the GHCs a+Hackage or Stackage builder is likely to pick, for checking a release:++```+nix develop .#ghc9124 --command cabal test+nix develop .#ghc9141 --command cabal test+```

@@ -0,0 +1,90 @@+cabal-version:      3.0+name:               scxml-statecharts+version:            0.1.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>+    >   <state id="Review">+    >     <onentry><script>notifyReviewers</script></onentry>+    >     <transition event="Approve" target="Done"/>+    >   </state>+    >   <final id="Done"/>+    > </scxml>+    > |]+    .+    generates @FsmState@, @FsmEvent@ and the functions+    @initiateStateMachine :: m FsmState@ and+    @notifyStateMachine :: FsmState -> FsmEvent -> m FsmState@, which call the+    callbacks named in the @\<script\>@ 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

@@ -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)

@@ -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+  }

@@ -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)

@@ -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 @<onentry><script>@ callbacks+  , nodeOnExit      :: [Text]        -- ^ names of @<onexit><script>@ callbacks+  }+  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+  }+  deriving (Eq, Show, Lift)++-- | Children of a state, the first being its initial child when it has one.+nodeChildren :: Node -> [Node]+nodeChildren = childrenOfKind . nodeKind++-- | Children of a kind, the first being its initial child when it has one.+childrenOfKind :: Kind -> [Node]+childrenOfKind Atomic = []+childrenOfKind Final = []+childrenOfKind (Compound cs) = NE.toList cs+childrenOfKind (Parallel rs) = NE.toList rs++-- | The child that entering a compound state leads to.+initialChild :: Kind -> Maybe Node+initialChild (Compound (c :| _)) = Just c+initialChild _ = Nothing++-- | Whether every child is active at once.+isParallel :: Kind -> Bool+isParallel (Parallel _) = True+isParallel _ = False++-- | Can this state ever raise its @done.state@ event? A parallel state can,+-- once every region is final; a compound state needs a @<final>@ child.+completes :: Node -> Bool+completes n = case nodeKind n of+  Parallel _ -> True+  Compound cs -> any ((== Final) . nodeKind) (NE.toList cs)+  _ -> False++-- | Every state in the chart, in document order. Needs no index: it is the+-- pre-order walk of the tree.+chartStates :: Chart -> [Node]+chartStates = concatMap preorder . NE.toList . chartRoot+  where+    preorder n = n : concatMap preorder (nodeChildren n)

@@ -0,0 +1,385 @@+-- | Parse SCXML into the untyped chart model.+--+-- Supported: @<state>@, @<parallel>@, @<final>@, @<transition>@ (event,+-- target), @initial@ attributes and @<initial>@ elements, and+-- @<script>@ inside @<onentry>@ and @<onexit>@ whose content is the name of a+-- Haskell function to run.+--+-- Deliberately unsupported: @cond@ guards, eventless transitions and+-- transitions without a target (make the decision in an @<onentry>@ callback+-- that raises an event instead), @<script>@ on a transition (put it in the+-- @<onentry>@ of the target, which receives the triggering event), and+-- @type="internal"@ (it can only differ from an external transition for a+-- target inside the source, which the level rule below forbids).+--+-- A transition must target a sibling of its source: events never cross+-- levels. To leave an enclosing state, put the transition on that state.+-- @initial@ follows the same rule and is required on every compound state:+-- it must name a direct child.+--+-- Not yet supported: @<history>@, wildcard event descriptors, other+-- executable content (@<assign>@, @<raise>@, @<send>@, ...).+--+-- State ids and event names are used verbatim as Haskell constructor and type+-- names, so they must be valid ones (@PaymentAuthorized@, not+-- @payment.authorized@). The one exception is SCXML's automatic+-- @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.+module Scxml.Statechart.Parse (parseScxml) where++import Control.Monad (ap, forM_, unless, when)+import Data.Char (isAlphaNum, isUpper)+import Data.List (group, intercalate, sort, stripPrefix)+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.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Text.XML (Element, Name (nameLocalName))+import qualified Text.XML as X++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])}++instance Functor P where+  fmap f (P g) = P $ \st -> fmap (\(a, st') -> (f a, st')) (g st)++instance Applicative P where+  pure a = P $ \st -> Right (a, st)+  (<*>) = ap++instance Monad P where+  P g >>= k = P $ \st -> g st >>= \(a, st') -> runP (k a) st'++throwP :: String -> P a+throwP msg = P $ \_ -> Left msg++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])++-- | 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.+parseScxml :: String -> Either String Chart+parseScxml src = do+  root <- parseXml src+  unless (localName root == "scxml") $+    Left ("root element must be <scxml>, found <" ++ localName root ++ ">")+  (kids, events) <- runP (mapM buildNode (stateChildren root)) []+  rootKids <- case NE.nonEmpty kids of+    Just ks -> Right ks+    Nothing -> Left "<scxml> contains no states"+  initial <- initialOf "<scxml>" root (map nodeId kids)+  ordered <- initialFirst "<scxml>" initial rootKids+  checkUniqueIds (concatMap flatten kids)+  let ch =+        Chart+          { chartName = T.pack <$> attr "name" root+          , chartRoot = ordered+          , chartEvents = events+          }+  validate ch+  pure ch+  where+    flatten n = n : concatMap flatten (nodeChildren n)++-- | Put the initial child first, which is how the tree records it.+initialFirst :: String -> StateId -> NonEmpty Node -> Either String (NonEmpty Node)+initialFirst label initial kids =+  case NE.partition ((== initial) . nodeId) kids of+    ([i], rest) -> Right (i :| rest)+    _ -> Left (label ++ ": internal error, initial state " ++ T.unpack initial ++ " is not a unique child")++-- | Ids become Haskell constructors, so they must be unique chart-wide, which+-- is also what SCXML requires of them.+checkUniqueIds :: [Node] -> Either String ()+checkUniqueIds nodes = case dups of+  [] -> Right ()+  _ ->+    Left $+      "duplicate state ids: " ++ intercalate "; " (map describe dups)+        ++ ". State ids must be unique across the whole chart, whatever their parents:"+        ++ " SCXML ids are XML IDs, and each one becomes a Haskell constructor"+  where+    dups = [d | (d : _ : _) <- group (sort (map nodeId nodes))]+    parentOfId d = [nodeId p | p <- nodes, d `elem` map nodeId (nodeChildren p)]+    describe d =+      show (T.unpack d) ++ " is used by "+        ++ intercalate " and "+             (case parentOfId d of+                [] -> ["the chart root"]+                ps -> map (\p -> "a child of " ++ T.unpack p) ps)++-- | Parse strictly: anything that is not well-formed XML is rejected, so a+-- typo cannot quietly become a different chart.+parseXml :: String -> Either String Element+parseXml src = case X.parseText X.def (TL.pack src) of+  Right doc -> Right (X.documentRoot doc)+  Left err ->+    Left ("document is not well-formed XML: " ++ tidy (unwords (words (show err))))+  where+    -- xml-conduit prints namespace-qualified Name records and Event+    -- constructors, which are noise in a compile error.+    tidy = replace "EventEndElement (" "" . replace ">)" ">"+         . replace "EventEndDocument" "the end of the document" . tidyNames+    tidyNames [] = []+    tidyNames str@(c : cs) = case stripPrefix "Name {nameLocalName = \"" str of+      Just rest ->+        let (nm, rest') = break (== '"') rest+         in case dropWhile (/= '}') rest' of+              '}' : rest'' -> "<" ++ nm ++ ">" ++ tidyNames rest''+              _ -> str+      Nothing -> c : tidyNames cs+    replace from to = go+      where+        go [] = []+        go str@(c : cs) = case stripPrefix from str of+          Just rest -> to ++ go rest+          Nothing -> c : go cs++localName :: Element -> String+localName = T.unpack . nameLocalName . X.elementName++-- Match attributes by local name only, ignoring namespaces.+attr :: String -> Element -> Maybe String+attr k el =+  T.unpack+    <$> listToMaybe [v | (n, v) <- Map.toList (X.elementAttributes el), nameLocalName n == T.pack k]++elChildren :: Element -> [Element]+elChildren el = [e | X.NodeElement e <- X.elementNodes el]++strContent :: Element -> String+strContent el = T.unpack (T.concat [t | X.NodeContent t <- X.elementNodes el])++childrenNamed :: [String] -> Element -> [Element]+childrenNamed names el = [c | c <- elChildren el, localName c `elem` names]++stateChildren :: Element -> [Element]+stateChildren = childrenNamed ["state", "parallel", "final", "history"]++hasInitial :: Element -> Bool+hasInitial el = attr "initial" el /= Nothing || not (null (childrenNamed ["initial"] el))++allowedChildren :: [String]+allowedChildren =+  [ "state", "parallel", "final", "history", "transition", "initial"+  , "onentry", "onexit", "datamodel", "invoke", "donedata"+  ]++-- | 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 ')")++-- | The prefix of SCXML's automatic completion events.+donePrefix :: Text+donePrefix = T.pack "done.state."++-- | The function names in @<script>@ children of an @<onentry>@, @<onexit>@ or+-- @<transition>@ element, in document order.+scriptsOf :: String -> Element -> Either String [Text]+scriptsOf label el = concat <$> mapM one (elChildren el)+  where+    one c+      | localName c == "script" = case words (strContent c) of+          [name] -> Right [T.pack name]+          _ -> Left (label ++ ": <script> must contain exactly one Haskell function name, got " ++ show (strContent c))+      | localName c `elem` ["raise", "if", "foreach", "log", "assign", "send", "cancel"] =+          Left (label ++ ": executable content <" ++ localName c ++ "> is not supported; use <script>functionName</script>")+      | otherwise = Right []++-- | The child state that entering a compound state (or the @<scxml>@ 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 "<initial> transition target" tg+      _ -> Left (label ++ ": <initial> must contain exactly one <transition target=...>")+    (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 <initial> element")+    (Nothing, _ : _ : _) -> Left (label ++ ": has more than one <initial> 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 "<history> 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 ++ " <onentry>")) (childrenNamed ["onentry"] el))+  onExit <- liftE (concat <$> mapM (scriptsOf (label ++ " <onexit>")) (childrenNamed ["onexit"] el))+  kind <- case (tag, NE.nonEmpty children) of+    ("parallel", Nothing) -> throwP (label ++ ": <parallel> must contain at least one region")+    ("parallel", Just regions) -> do+      when (hasInitial el) $ throwP (label ++ ": <parallel> 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 <final> state, which SCXML does not allow"+              ++ " inside <parallel> and which would report the whole <parallel> 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 <parallel> " ++ 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 @<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)]+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 <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")+  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")+    ts ->+      throwP $+        label ++ ": transition names several targets (" ++ unwords (map T.unpack ts)+          ++ "); a transition enters exactly one state, and entering siblings at once is only meaningful inside a <parallel>, whose regions cannot have transitions"+  case attr "type" el of+    Nothing -> pure ()+    Just "external" -> pure ()+    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]++-- | One transition per event, so selection never has to break a tie.+transitionMap :: String -> [(Text, StateId)] -> Either String (Map.Map Text StateId)+transitionMap label pairs = case dups of+  [] -> Right (Map.fromList pairs)+  (e : _) ->+    Left $+      label ++ ": two transitions for the event " ++ show (T.unpack e) ++ " (to "+        ++ intercalate " and " [T.unpack t | (e', t) <- pairs, e' == e]+        ++ "); with no cond there is nothing to choose between them"+  where+    dups = [e | (e : _ : _) <- group (sort (map fst pairs))]++-- | Everything that needs more than one node at a time, which after the level+-- rules is very little: a transition target must be one of the source's+-- siblings, and @done.state.X@ may only be handled on @X@ itself. Both are+-- local to a state and its neighbours, so this is a plain walk.+validate :: Chart -> Either String ()+validate ch = mapM_ (checkNode roots) (NE.toList (chartRoot ch))+  where+    roots = NE.toList (chartRoot ch)+    checkNode siblings n = do+      mapM_ (checkTransition siblings n) (Map.toList (nodeTransitions n))+      let kids = nodeChildren n+      mapM_ (checkNode kids) kids+    checkTransition siblings n (e, tgt) = do+      unless (tgt `elem` map nodeId siblings) $+        Left $+          "transition from " ++ T.unpack (nodeId n) ++ " to " ++ T.unpack tgt+            ++ " crosses levels: a transition must target a sibling of its source, and "+            ++ T.unpack (nodeId n) ++ "'s siblings are "+            ++ intercalate ", " (map (T.unpack . nodeId) siblings)+            ++ ". To leave an enclosing state, declare the transition on that state instead"+      forM_ (T.stripPrefix donePrefix e) $ \target ->+        if target /= nodeId n+          then+            Left $+              T.unpack e ++ " on " ++ T.unpack (nodeId n) ++ ": only " ++ T.unpack target+                ++ " may react to its own completion, so declare this transition on "+                ++ T.unpack target+                ++ ". To carry the completion further out, have " ++ T.unpack target+                ++ " move to a <final> sibling, which completes their parent and raises its own done event"+          else+            unless (completes n) $+              Left $+                T.unpack e ++ " can never fire: " ++ T.unpack target+                  ++ " is not a <parallel> or a <state> with a <final> child"

@@ -0,0 +1,72 @@+-- | Running a chart against a t'Def'. The functions generated by the @scxml@+-- quasiquoter are thin wrappers over these with t'Hooks' dispatching to the+-- callbacks named in the SCXML.+module Scxml.Statechart.Run+  ( Hooks (..)+  , Phase (..)+  , entryAction+  , exitAction+  , start+  , stepOrStay+  ) where++import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T++import Scxml.Statechart.Def+import qualified Scxml.Statechart.Interpret as I+import Scxml.Statechart.Interpret (Phase (..))+import Scxml.Statechart.Model (StateId)++-- | How to run the callbacks named in @<script>@ elements.+newtype Hooks m s ev = Hooks+  { runAction :: Phase -> Text -> s -> Maybe ev -> m (Maybe ev)+    -- ^ run the named callback with the state it observes (the state being+    -- left for 'OnExit', the state being entered otherwise) and the event+    -- being processed ('Nothing' during 'start'); returns an event to raise+  }++-- | Marks an entry callback, which returns the event it raises, if any.+-- Raised events are queued and processed before the current step returns,+-- like SCXML's @<raise>@. Only here so that a callback with the wrong type+-- gets an error pointing at it.+entryAction :: m (Maybe ev) -> m (Maybe ev)+entryAction = id++-- | Marks an exit callback, which may not raise events. Only here so that a+-- callback with the wrong type gets an error pointing at it.+exitAction :: m () -> m ()+exitAction = id++toInterp :: Monad m => Def s ev -> Hooks m s ev -> I.Callbacks m+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)++unsafeFromConfig :: Def s ev -> Set.Set StateId -> s+unsafeFromConfig def cfg =+  fromMaybe+    (error ("Statechart: interpreter produced an invalid configuration: " ++ show (map T.unpack (Set.toList cfg))))+    (defFromConfig def cfg)++-- | Enter the initial state, running entry callbacks and any events they raise.+start :: Monad m => Def s ev -> Hooks m s ev -> m s+start def h = unsafeFromConfig def <$> I.start (defChart def) (toInterp def h)++-- | Deliver one event, staying in the current state when no transition is+-- enabled for it, which is SCXML's behaviour for an unmatched event.+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)

@@ -0,0 +1,373 @@+{-# LANGUAGE TemplateHaskell #-}+-- | The @scxml@ quasiquoter. Used at the top level of a module:+--+-- @+-- [scxml| <scxml initial="Draft"> ... </scxml> |]+-- @+--+-- The generated names are fixed, so a module holds one chart:+--+-- * @data FsmState@: one constructor per child of @<scxml>@, named exactly as+--   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.+-- * @fsmChart :: Def FsmState FsmEvent@, for "Scxml.Statechart.Run".+-- * @serializeStateMachine :: FsmState -> [Text]@ and+--   @deserializeStateMachine :: [Text] -> Maybe FsmState@, which store a state+--   as the set of active state ids and read it back, rejecting anything that+--   is not a configuration of this chart.+-- * @initiateStateMachine@ and @notifyStateMachine@, which run the chart+--   calling the callbacks named in @<script>@ elements. Callbacks are looked+--   up by name in the module containing the quasiquote (they may be defined+--   after it) and must share one monad, which the type checker enforces:+--+-- @+-- initiateStateMachine :: m FsmState+-- notifyStateMachine   :: FsmState -> FsmEvent -> m FsmState+--+-- entryCallback :: FsmState -> Maybe FsmEvent -> m (Maybe FsmEvent)+-- exitCallback  :: FsmState -> Maybe FsmEvent -> m ()+-- @+--+-- Every generated type derives @Show@, @Read@, @Eq@ and @Ord@, and the event+-- type also derives @Enum@ and @Bounded@. For storing a state outside+-- Haskell, prefer the generated @serializeStateMachine@ over @Show@.+module Scxml.Statechart.TH (scxml) where++import Control.Monad (forM, unless)+import Data.Char (isAlphaNum, isLower, isUpper)+import Data.List (nub)+import qualified Data.Map.Strict as Map+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax (lift)++import Scxml.Statechart.Def+import qualified Scxml.Statechart.Interpret as I+import Scxml.Statechart.Model+import Scxml.Statechart.Parse+import qualified Scxml.Statechart.Run as Run++-- | Turns SCXML into a statechart. Usable only at the top level of a module,+-- where it declares the state and event types and the functions that run the+-- chart. A light switch, whose two states each announce themselves on entry:+--+-- > {-# LANGUAGE QuasiQuotes #-}+-- > module LightSwitch where+-- >+-- > import Scxml.Statechart (scxml)+-- >+-- > [scxml|+-- > <scxml initial="Off">+-- >   <state id="Off">+-- >     <onentry><script>report</script></onentry>+-- >     <transition event="Flip" target="On"/>+-- >   </state>+-- >   <state id="On">+-- >     <onentry><script>report</script></onentry>+-- >     <transition event="Flip" target="Off"/>+-- >   </state>+-- > </scxml>+-- > |]+-- >+-- > 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 @\<script\>@:+--+-- > 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| <scxml ...> |]"++-- | A compound-like node (the root or a @<state>@ 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: <parallel> " ++ T.unpack (nodeId rn) ++ " is directly inside another <parallel>, which is not supported."+                  ++ " Flatten it: its regions can become regions of the outer <parallel>, 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 @<script>@ must be Haskell variable names, optionally+-- qualified (@Inventory.reserve@).+checkVarName :: Text -> Either String ()+checkVarName raw+  | ok = Right ()+  | otherwise = Left ("<script> callback " ++ show (T.unpack raw) ++ " is not a Haskell function name (expected something like reserveStock or Inventory.reserve)")+  where+    segments = T.splitOn (T.pack ".") raw+    ok = not (null segments) && all isModulePart (init segments) && isVar (last segments)+    isVar t = case T.unpack t of+      c : cs -> (isLower c || c == '_') && all (\x -> isAlphaNum x || x == '_' || x == '\'') cs+      [] -> False+    isModulePart t = case T.unpack t of+      c : cs -> isUpper c && all (\x -> isAlphaNum x || x == '_' || x == '\'') cs+      [] -> False++orFail :: Either String a -> Q a+orFail = either (fail . ("scxml: " ++)) pure

@@ -0,0 +1,294 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Main (main) where++import Control.Monad (unless, when)+import Control.Monad.Trans.State.Strict (StateT, gets, modify', runStateT)+import Data.IORef+import Data.Text (Text)+import qualified Data.Text as T+import System.Exit (exitFailure)++-- The library's entire public API.+import Scxml.Statechart (scxml)+import qualified Overrides+import qualified Reordered++-- An order process: compound states, a parallel state that completes via+-- SCXML's automatic done.state event, a choice state whose entry callback+-- decides where to go by raising an event, a self-transition used for+-- polling, and effects named in the SCXML. State ids and event names are+-- Haskell constructor names, used verbatim. The name attribute is optional+-- metadata and does not affect the generated names.+[scxml|+<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"/>+  </state>++  <state id="Validating">+    <onentry><script>validate</script></onentry>+    <transition event="Valid" target="Processing"/>+    <transition event="Invalid" target="Rejected"/>+  </state>++  <state id="Processing" initial="Authorizing">+    <onentry><script>reserveStock</script></onentry>+    <onexit><script>releaseStock</script></onexit>+    <state id="Authorizing">+      <onentry><script>checkPrepayment</script></onentry>+      <!-- Polling: re-enter this state to re-run its entry callback. -->+      <transition event="Poll" target="Authorizing"/>+      <transition event="PaymentAuthorized" target="Fulfilment"/>+    </state>+    <parallel id="Fulfilment">+      <state id="Shipping" initial="Packing">+        <state id="Packing">+          <transition event="Packed" target="Shipped"/>+        </state>+        <final id="Shipped"/>+      </state>+      <state id="Invoicing" initial="Unpaid">+        <state id="Unpaid">+          <transition event="Paid" target="Settled"/>+        </state>+        <final id="Settled"/>+      </state>+      <!-- Only Fulfilment may react to its own completion, and it can only+           reach a sibling, so it moves to a final state of Processing. That+           completes Processing, whose own done event carries it further out. -->+      <transition event="done.state.Fulfilment" target="Fulfilled"/>+    </parallel>+    <final id="Fulfilled"/>+    <!-- Leaving Processing is declared on Processing: transitions never+         cross levels, so these apply anywhere inside it. -->+    <transition event="PaymentDeclined" target="Rejected"/>+    <transition event="done.state.Processing" target="Completed"/>+    <transition event="Cancel" target="Cancelled"/>+  </state>++  <final id="Completed">+    <onentry><script>notifyCustomer</script></onentry>+  </final>+  <final id="Rejected"/>+  <final id="Cancelled"/>+</scxml>+|]++-- 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"

@@ -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|+<scxml initial="Outer">+  <state id="Outer" initial="Inner">+    <state id="Inner">+      <!-- Overrides Outer's Poke while Inner is active. -->+      <transition event="Poke" target="Middle"/>+    </state>+    <state id="Middle">+      <onentry><script>noteEntry</script><script>raiseYes</script><script>raiseNo</script></onentry>+      <transition event="Yes" target="Yeah"/>+      <transition event="No" target="Nope"/>+    </state>+    <state id="Yeah"/>+    <state id="Nope"/>+    <!-- The default, taken wherever nothing inner handles Poke. -->+    <transition event="Poke" target="Away"/>+  </state>+  <state id="Away"/>+</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+      )+    ]

@@ -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|+<scxml initial="Job">+  <final id="Done"/>+  <state id="Job" initial="Third">+    <state id="First"><transition event="Go" target="Third"/></state>+    <state id="Second"/>+    <state id="Third"><transition event="Back" target="First"/></state>+  </state>+</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))+    ]