Run.hs

-- | 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 (..)
  , 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.Model (StateId)

-- | How to run the callbacks named in @<script>@ elements.
data Hooks m s ev = Hooks
  { runEntry :: Text -> Maybe (s, ev) -> s -> m (Maybe ev)
    -- ^ run the named entry callback with the state the step leaves and the
    -- event that caused it ('Nothing' during 'start'), and the state the
    -- step settles in. Returns an event to raise.
  , runExit :: Text -> s -> ev -> s -> m ()
    -- ^ run the named exit callback with the state the step leaves, the
    -- event that caused it and the state it settles in
  }

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

-- | The event reaching a callback is the one the caller passed in, not a value
-- rebuilt from its name, so whatever payload it carries survives the trip.
toInterp :: Def s ev -> Hooks m s ev -> I.Callbacks m ev
toInterp def@Def {defEventName, defDoneEvent} Hooks {runEntry, runExit} =
  I.Callbacks
    { I.runEntry = \name cause cfg' ->
        runEntry name
          (fmap (\(cfg, ev) -> (state cfg, ev)) cause)
          (state cfg')
    , I.runExit = \name cfg ev cfg' -> runExit name (state cfg) ev (state cfg')
    , I.eventNameOf = defEventName
    , I.doneEvent = defDoneEvent
    }
  where
    state = unsafeFromConfig def

unsafeFromConfig :: Def s ev -> Set.Set StateId -> s
unsafeFromConfig Def {defFromConfig} cfg =
  fromMaybe
    (error ("Statechart: interpreter produced an invalid configuration: " ++ show (map T.unpack (Set.toList cfg))))
    (defFromConfig 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@Def {defChart} h = unsafeFromConfig def <$> I.start defChart (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@Def {defChart, defToConfig} h s e =
  maybe s (unsafeFromConfig def)
    <$> I.macrostep defChart (toInterp def h) (defToConfig s) e