module GHC.RTS.Events.Analysis
  ( Machine (..)
  , validate
  , validates
  , simulate
  , Profile (..)
  , profile
  , profileIndexed
  , profileRouted
  , extractIndexed
  , refineM
  , profileM
  , indexM
  , toList
  , toMaybe
  , Process (..)
  , routeM
  )
 where

import GHC.RTS.Events

import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)

--------------------------------------------------------------------------------
-- | This is based on a simple finite state machine hence the names `delta`
-- for the state transition function.
-- Since states might be more than simple pattern matched constructors, we
-- use `finals :: state -> Bool`, rather than `Set state`, to indicate that
-- the machine is in some final state. Similarly for `alpha`, which
-- indicates the alphabet of inputs to a machine.
-- The function `delta` returns `Maybe` values, where `Nothing`
-- indicates that no valid transition is possible: ie, there has been an
-- error.
data Machine s i = Machine
  { Machine s i -> s
initial :: s                 -- ^ Initial state
  , Machine s i -> s -> Bool
final   :: s -> Bool         -- ^ Valid final states
  , Machine s i -> i -> Bool
alpha   :: i -> Bool         -- ^ Valid input alphabet
  , Machine s i -> s -> i -> Maybe s
delta   :: s -> i -> Maybe s -- ^ State transition function
  }

-- | The `step` function runs a machine in a state against a single input.
-- The state remains fixed once a final state is encountered. The
-- result is `Left state input` if some `state` failed for an `ìnput`, and
-- `Right state` for a successful state.
step :: Machine s i -> s -> i -> Either (s, i) s
step :: Machine s i -> s -> i -> Either (s, i) s
step Machine s i
m s
s i
i
  | Machine s i -> s -> Bool
forall s i. Machine s i -> s -> Bool
final Machine s i
m s
s = s -> Either (s, i) s
forall a b. b -> Either a b
Right s
s
  | Machine s i -> i -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine s i
m i
i = case Machine s i -> s -> i -> Maybe s
forall s i. Machine s i -> s -> i -> Maybe s
delta Machine s i
m s
s i
i of
      Just s
s' -> s -> Either (s, i) s
forall a b. b -> Either a b
Right s
s'
      Maybe s
Nothing -> (s, i) -> Either (s, i) s
forall a b. a -> Either a b
Left (s
s, i
i)
  | Bool
otherwise = s -> Either (s, i) s
forall a b. b -> Either a b
Right s
s

-- | The `validate` function takes a machine and a list of inputs. The machine
-- is started from its initial state and run against the inputs in turn.
-- It returns the state and input on failure, and just the state on success.
validate :: Machine s i -> [i] -> Either (s, i) s
validate :: Machine s i -> [i] -> Either (s, i) s
validate Machine s i
m = (Either (s, i) s -> (s -> Either (s, i) s) -> Either (s, i) s)
-> Either (s, i) s -> [s -> Either (s, i) s] -> Either (s, i) s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Either (s, i) s -> (s -> Either (s, i) s) -> Either (s, i) s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) (s -> Either (s, i) s
forall a b. b -> Either a b
Right (Machine s i -> s
forall s i. Machine s i -> s
initial Machine s i
m)) ([s -> Either (s, i) s] -> Either (s, i) s)
-> ([i] -> [s -> Either (s, i) s]) -> [i] -> Either (s, i) s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> s -> Either (s, i) s) -> [i] -> [s -> Either (s, i) s]
forall a b. (a -> b) -> [a] -> [b]
map ((s -> i -> Either (s, i) s) -> i -> s -> Either (s, i) s
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Machine s i -> s -> i -> Either (s, i) s
forall s i. Machine s i -> s -> i -> Either (s, i) s
step Machine s i
m))

-- | This function is similar to `validate`, but outputs each intermediary
-- state as well. For an incremental version, use `simulate`.
validates :: Machine s i -> [i] -> [Either (s, i) s]
validates :: Machine s i -> [i] -> [Either (s, i) s]
validates Machine s i
m = (Either (s, i) s -> (s -> Either (s, i) s) -> Either (s, i) s)
-> Either (s, i) s -> [s -> Either (s, i) s] -> [Either (s, i) s]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Either (s, i) s -> (s -> Either (s, i) s) -> Either (s, i) s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) (s -> Either (s, i) s
forall a b. b -> Either a b
Right (Machine s i -> s
forall s i. Machine s i -> s
initial Machine s i
m)) ([s -> Either (s, i) s] -> [Either (s, i) s])
-> ([i] -> [s -> Either (s, i) s]) -> [i] -> [Either (s, i) s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> s -> Either (s, i) s) -> [i] -> [s -> Either (s, i) s]
forall a b. (a -> b) -> [a] -> [b]
map ((s -> i -> Either (s, i) s) -> i -> s -> Either (s, i) s
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Machine s i -> s -> i -> Either (s, i) s
forall s i. Machine s i -> s -> i -> Either (s, i) s
step Machine s i
m))

--------------------------------------------------------------------------------
-- A Process is a list of successful values, followed by an error if one
-- occured. This captures the idea that a computation may produce a list of
-- elements before possibly failing. This gives us an incremental interface
-- to data processed from machine transitions.
data Process e a
  = Done
  | Fail e
  | Prod a (Process e a)
 deriving Int -> Process e a -> ShowS
[Process e a] -> ShowS
Process e a -> String
(Int -> Process e a -> ShowS)
-> (Process e a -> String)
-> ([Process e a] -> ShowS)
-> Show (Process e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show e, Show a) => Int -> Process e a -> ShowS
forall e a. (Show e, Show a) => [Process e a] -> ShowS
forall e a. (Show e, Show a) => Process e a -> String
showList :: [Process e a] -> ShowS
$cshowList :: forall e a. (Show e, Show a) => [Process e a] -> ShowS
show :: Process e a -> String
$cshow :: forall e a. (Show e, Show a) => Process e a -> String
showsPrec :: Int -> Process e a -> ShowS
$cshowsPrec :: forall e a. (Show e, Show a) => Int -> Process e a -> ShowS
Show

toList :: Process e a -> [a]
toList :: Process e a -> [a]
toList (Fail e
_)    = []
toList Process e a
Done        = []
toList (Prod a
a Process e a
as) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Process e a -> [a]
forall e a. Process e a -> [a]
toList Process e a
as

toMaybe :: Process e a -> Maybe e
toMaybe :: Process e a -> Maybe e
toMaybe (Fail e
e)    = e -> Maybe e
forall a. a -> Maybe a
Just e
e
toMaybe Process e a
Done        = Maybe e
forall a. Maybe a
Nothing
toMaybe (Prod a
_ Process e a
as) = Process e a -> Maybe e
forall e a. Process e a -> Maybe e
toMaybe Process e a
as

-- | A machine can be analysed while it is accepting input in order to extract
-- some information. This function takes a machine and a function that extracts
-- data and produces output. On failure, the machine state and input are
-- produced. Note that when an input is not in the machine's alphabet,
-- then there is no transition, and so no output is produced in response
-- to that input.
analyse :: Machine s i          -- ^ The machine used
        -> (s -> i -> Maybe o)  -- ^ An extraction function that may produce output
        -> [i]                  -- ^ A list of input
        -> Process (s, i) o     -- ^ A process that produces output
analyse :: Machine s i -> (s -> i -> Maybe o) -> [i] -> Process (s, i) o
analyse Machine s i
machine s -> i -> Maybe o
extract = s -> [i] -> Process (s, i) o
go (Machine s i -> s
forall s i. Machine s i -> s
initial Machine s i
machine)
 where
  -- go :: s -> [i] -> Process (s, i) o
  go :: s -> [i] -> Process (s, i) o
go s
_ [] = Process (s, i) o
forall e a. Process e a
Done
  go s
s (i
i:[i]
is)
    | Machine s i -> s -> Bool
forall s i. Machine s i -> s -> Bool
final Machine s i
machine s
s = Process (s, i) o
forall e a. Process e a
Done
    | Machine s i -> i -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine s i
machine i
i =
        case Machine s i -> s -> i -> Maybe s
forall s i. Machine s i -> s -> i -> Maybe s
delta Machine s i
machine s
s i
i of
          Maybe s
Nothing -> (s, i) -> Process (s, i) o
forall e a. e -> Process e a
Fail (s
s, i
i)
          Just s
s' ->
            case s -> i -> Maybe o
extract s
s i
i of
              Maybe o
Nothing -> s -> [i] -> Process (s, i) o
go s
s' [i]
is
              Just o
o  -> o -> Process (s, i) o -> Process (s, i) o
forall e a. a -> Process e a -> Process e a
Prod o
o (s -> [i] -> Process (s, i) o
go s
s' [i]
is)
    | Bool
otherwise = s -> [i] -> Process (s, i) o
go s
s [i]
is

-- | Machines sometimes need to operate on coarser input than they are defined
-- for. This function takes a function that refines input and a machine that
-- works on refined input, and produces a machine that can work on coarse input.
refineM :: (i -> j) -> Machine s j -> Machine s i
refineM :: (i -> j) -> Machine s j -> Machine s i
refineM i -> j
refine Machine s j
machine = Machine :: forall s i.
s
-> (s -> Bool) -> (i -> Bool) -> (s -> i -> Maybe s) -> Machine s i
Machine
  { initial :: s
initial = Machine s j -> s
forall s i. Machine s i -> s
initial Machine s j
machine
  , final :: s -> Bool
final   = Machine s j -> s -> Bool
forall s i. Machine s i -> s -> Bool
final Machine s j
machine
  , alpha :: i -> Bool
alpha   = Machine s j -> j -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine s j
machine (j -> Bool) -> (i -> j) -> i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> j
refine
  , delta :: s -> i -> Maybe s
delta   = \s
s -> Machine s j -> s -> j -> Maybe s
forall s i. Machine s i -> s -> i -> Maybe s
delta Machine s j
machine s
s (j -> Maybe s) -> (i -> j) -> i -> Maybe s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> j
refine
  }

--------------------------------------------------------------------------------
-- | This function produces a process that outputs all the states that a
-- machine goes through.
simulate :: Machine s i -> [i] -> Process (s, i) (s, i)
simulate :: Machine s i -> [i] -> Process (s, i) (s, i)
simulate Machine s i
machine = Machine s i
-> (s -> i -> Maybe (s, i)) -> [i] -> Process (s, i) (s, i)
forall s i o.
Machine s i -> (s -> i -> Maybe o) -> [i] -> Process (s, i) o
analyse Machine s i
machine (\s
s i
i -> Machine s i -> s -> i -> Maybe s
forall s i. Machine s i -> s -> i -> Maybe s
delta Machine s i
machine s
s i
i Maybe s -> (s -> Maybe (s, i)) -> Maybe (s, i)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s
s' -> (s, i) -> Maybe (s, i)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s', i
i))

--------------------------------------------------------------------------------
-- | A state augmented by Timestamp information is held in `profileState`.
-- When the state changes, `profileMap` stores a map between each state
-- and its cumulative time.
data Profile s = Profile
  { Profile s -> s
profileState :: s               -- ^ The current state
  , Profile s -> Timestamp
profileTime  :: Timestamp       -- ^ The entry time of the state
  } deriving (Int -> Profile s -> ShowS
[Profile s] -> ShowS
Profile s -> String
(Int -> Profile s -> ShowS)
-> (Profile s -> String)
-> ([Profile s] -> ShowS)
-> Show (Profile s)
forall s. Show s => Int -> Profile s -> ShowS
forall s. Show s => [Profile s] -> ShowS
forall s. Show s => Profile s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Profile s] -> ShowS
$cshowList :: forall s. Show s => [Profile s] -> ShowS
show :: Profile s -> String
$cshow :: forall s. Show s => Profile s -> String
showsPrec :: Int -> Profile s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> Profile s -> ShowS
Show)

-- | This function takes a machine and profiles its state.
profileM :: Ord s
         => (i -> Timestamp)
         -> Machine s i
         -> Machine (Profile s) i
profileM :: (i -> Timestamp) -> Machine s i -> Machine (Profile s) i
profileM i -> Timestamp
timer Machine s i
machine = Machine :: forall s i.
s
-> (s -> Bool) -> (i -> Bool) -> (s -> i -> Maybe s) -> Machine s i
Machine
  { initial :: Profile s
initial = s -> Timestamp -> Profile s
forall s. s -> Timestamp -> Profile s
Profile (Machine s i -> s
forall s i. Machine s i -> s
initial Machine s i
machine) Timestamp
0
  , final :: Profile s -> Bool
final   = Machine s i -> s -> Bool
forall s i. Machine s i -> s -> Bool
final Machine s i
machine (s -> Bool) -> (Profile s -> s) -> Profile s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Profile s -> s
forall s. Profile s -> s
profileState
  , alpha :: i -> Bool
alpha   = Machine s i -> i -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine s i
machine
  , delta :: Profile s -> i -> Maybe (Profile s)
delta   = Profile s -> i -> Maybe (Profile s)
profileMDelta
  }
 where
  profileMDelta :: Profile s -> i -> Maybe (Profile s)
profileMDelta (Profile s
s Timestamp
_) i
i = do
    s
s' <- Machine s i -> s -> i -> Maybe s
forall s i. Machine s i -> s -> i -> Maybe s
delta Machine s i
machine s
s i
i
    Profile s -> Maybe (Profile s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Profile s -> Maybe (Profile s)) -> Profile s -> Maybe (Profile s)
forall a b. (a -> b) -> a -> b
$ s -> Timestamp -> Profile s
forall s. s -> Timestamp -> Profile s
Profile s
s' (i -> Timestamp
timer i
i)

-- | extractProfile returns the state, the time this state was made,
-- and the time spent in this state.
extractProfile :: (i -> Timestamp)                -- ^ Extracts current timestamp
               -> Profile s                       -- ^ A profiled state
               -> i                               -- ^ Some input
               -> Maybe (s, Timestamp, Timestamp) -- ^ (state, currentTime, elapsedTime)
extractProfile :: (i -> Timestamp)
-> Profile s -> i -> Maybe (s, Timestamp, Timestamp)
extractProfile i -> Timestamp
timer Profile s
p i
i = (s, Timestamp, Timestamp) -> Maybe (s, Timestamp, Timestamp)
forall a. a -> Maybe a
Just (Profile s -> s
forall s. Profile s -> s
profileState Profile s
p, Profile s -> Timestamp
forall s. Profile s -> Timestamp
profileTime Profile s
p, i -> Timestamp
timer i
i Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
- Profile s -> Timestamp
forall s. Profile s -> Timestamp
profileTime Profile s
p)

profile :: (Ord s, Eq s)
        => Machine s i       -- ^ A machine to profile
        -> (i -> Timestamp)  -- ^ Converts input to timestamps
        -> [i]               -- ^ The list of input
        -> Process (Profile s, i) (s, Timestamp, Timestamp)
profile :: Machine s i
-> (i -> Timestamp)
-> [i]
-> Process (Profile s, i) (s, Timestamp, Timestamp)
profile Machine s i
machine i -> Timestamp
timer =
  Machine (Profile s) i
-> (Profile s -> i -> Maybe (s, Timestamp, Timestamp))
-> [i]
-> Process (Profile s, i) (s, Timestamp, Timestamp)
forall s i o.
Machine s i -> (s -> i -> Maybe o) -> [i] -> Process (s, i) o
analyse ((i -> Timestamp) -> Machine s i -> Machine (Profile s) i
forall s i.
Ord s =>
(i -> Timestamp) -> Machine s i -> Machine (Profile s) i
profileM i -> Timestamp
timer Machine s i
machine)
          ((i -> Timestamp)
-> Profile s -> i -> Maybe (s, Timestamp, Timestamp)
forall i s.
(i -> Timestamp)
-> Profile s -> i -> Maybe (s, Timestamp, Timestamp)
extractProfile i -> Timestamp
timer)

profileIndexed :: (Ord k, Ord s, Eq s)
               => Machine s i
               -> (i -> Maybe k)
               -> (i -> Timestamp)
               -> [i]
               -> Process (Map k (Profile s), i) (k, (s, Timestamp, Timestamp))
profileIndexed :: Machine s i
-> (i -> Maybe k)
-> (i -> Timestamp)
-> [i]
-> Process (Map k (Profile s), i) (k, (s, Timestamp, Timestamp))
profileIndexed Machine s i
machine i -> Maybe k
index i -> Timestamp
timer =
  Machine (Map k (Profile s)) i
-> (Map k (Profile s) -> i -> Maybe (k, (s, Timestamp, Timestamp)))
-> [i]
-> Process (Map k (Profile s), i) (k, (s, Timestamp, Timestamp))
forall s i o.
Machine s i -> (s -> i -> Maybe o) -> [i] -> Process (s, i) o
analyse ((i -> Maybe k)
-> Machine (Profile s) i -> Machine (Map k (Profile s)) i
forall k i s.
Ord k =>
(i -> Maybe k) -> Machine s i -> Machine (Map k s) i
indexM i -> Maybe k
index ((i -> Timestamp) -> Machine s i -> Machine (Profile s) i
forall s i.
Ord s =>
(i -> Timestamp) -> Machine s i -> Machine (Profile s) i
profileM i -> Timestamp
timer Machine s i
machine))
          ((Profile s -> i -> Maybe (s, Timestamp, Timestamp))
-> (i -> Maybe k)
-> Map k (Profile s)
-> i
-> Maybe (k, (s, Timestamp, Timestamp))
forall k s i o.
Ord k =>
(s -> i -> Maybe o)
-> (i -> Maybe k) -> Map k s -> i -> Maybe (k, o)
extractIndexed ((i -> Timestamp)
-> Profile s -> i -> Maybe (s, Timestamp, Timestamp)
forall i s.
(i -> Timestamp)
-> Profile s -> i -> Maybe (s, Timestamp, Timestamp)
extractProfile i -> Timestamp
timer) i -> Maybe k
index)

extractIndexed :: Ord k => (s -> i -> Maybe o) -> (i -> Maybe k) -> (Map k s -> i -> Maybe (k, o))
extractIndexed :: (s -> i -> Maybe o)
-> (i -> Maybe k) -> Map k s -> i -> Maybe (k, o)
extractIndexed s -> i -> Maybe o
extract i -> Maybe k
index Map k s
m i
i = do
  k
k <- i -> Maybe k
index i
i
  s
s <- k -> Map k s -> Maybe s
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k s
m
  o
o <- s -> i -> Maybe o
extract s
s i
i
  (k, o) -> Maybe (k, o)
forall (m :: * -> *) a. Monad m => a -> m a
return (k
k, o
o)

-- | An indexed machine takes a function that multiplexes the input to a key
-- and then takes a machine description to an indexed machine.
indexM :: Ord k
       => (i -> Maybe k)        -- ^ An indexing function
       -> Machine s i           -- ^ A machine to index with
       -> Machine (Map k s) i   -- ^ The indexed machine
indexM :: (i -> Maybe k) -> Machine s i -> Machine (Map k s) i
indexM i -> Maybe k
index Machine s i
machine = Machine :: forall s i.
s
-> (s -> Bool) -> (i -> Bool) -> (s -> i -> Maybe s) -> Machine s i
Machine
  { initial :: Map k s
initial = Map k s
forall k a. Map k a
M.empty
  , final :: Map k s -> Bool
final   = Map k s -> Bool
forall b. b -> Bool
indexMFinal
  , alpha :: i -> Bool
alpha   = i -> Bool
indexMAlpha
  , delta :: Map k s -> i -> Maybe (Map k s)
delta   = Map k s -> i -> Maybe (Map k s)
indexMDelta
  }
 where
  -- An indexer never reaches a final state: it is always possible that
  -- an event comes along that is accepted by a machine that is not
  -- yet in in the index.
  --
  -- An alternative view is that the indexer is in a final state if all its
  -- elements are, but this would not allow the creation of new indexes:
  --     indexMFinal m = not (M.null m) && (all (final machine) . M.elems $ m)
  indexMFinal :: b -> Bool
indexMFinal = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False

  -- The alphabet of the indexer is that of its elements.
  indexMAlpha :: i -> Bool
indexMAlpha = Machine s i -> i -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine s i
machine

  -- If the index is not yet in the mapping, we start a new machine in its
  -- initial state. The indexer fails if indexed state fails.
  indexMDelta :: Map k s -> i -> Maybe (Map k s)
indexMDelta Map k s
m i
i = do
    k
k <- i -> Maybe k
index i
i
    let state :: s
state = s -> Maybe s -> s
forall a. a -> Maybe a -> a
fromMaybe (Machine s i -> s
forall s i. Machine s i -> s
initial Machine s i
machine) (k -> Map k s -> Maybe s
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k s
m)
    s
state' <- Machine s i -> s -> i -> Maybe s
forall s i. Machine s i -> s -> i -> Maybe s
delta Machine s i
machine s
state i
i
    Map k s -> Maybe (Map k s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k s -> Maybe (Map k s)) -> Map k s -> Maybe (Map k s)
forall a b. (a -> b) -> a -> b
$ k -> s -> Map k s -> Map k s
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k s
state' Map k s
m

profileRouted :: (Ord k, Ord s, Eq s, Eq r)
              => Machine s i
              -> Machine r i
              -> (r -> i -> Maybe k)
              -> (i -> Timestamp)
              -> [i]
              -> Process ((Map k (Profile s), r), i) (k, (s, Timestamp, Timestamp))
profileRouted :: Machine s i
-> Machine r i
-> (r -> i -> Maybe k)
-> (i -> Timestamp)
-> [i]
-> Process
     ((Map k (Profile s), r), i) (k, (s, Timestamp, Timestamp))
profileRouted Machine s i
machine Machine r i
router r -> i -> Maybe k
index i -> Timestamp
timer =
  Machine (Map k (Profile s), r) i
-> ((Map k (Profile s), r)
    -> i -> Maybe (k, (s, Timestamp, Timestamp)))
-> [i]
-> Process
     ((Map k (Profile s), r), i) (k, (s, Timestamp, Timestamp))
forall s i o.
Machine s i -> (s -> i -> Maybe o) -> [i] -> Process (s, i) o
analyse (Machine r i
-> (r -> i -> Maybe k)
-> Machine (Profile s) i
-> Machine (Map k (Profile s), r) i
forall k r i s.
Ord k =>
Machine r i
-> (r -> i -> Maybe k) -> Machine s i -> Machine (Map k s, r) i
routeM Machine r i
router r -> i -> Maybe k
index ((i -> Timestamp) -> Machine s i -> Machine (Profile s) i
forall s i.
Ord s =>
(i -> Timestamp) -> Machine s i -> Machine (Profile s) i
profileM i -> Timestamp
timer Machine s i
machine))
          ((Profile s -> i -> Maybe (s, Timestamp, Timestamp))
-> (r -> i -> Maybe k)
-> (Map k (Profile s), r)
-> i
-> Maybe (k, (s, Timestamp, Timestamp))
forall k s i o r.
Ord k =>
(s -> i -> Maybe o)
-> (r -> i -> Maybe k) -> (Map k s, r) -> i -> Maybe (k, o)
extractRouted ((i -> Timestamp)
-> Profile s -> i -> Maybe (s, Timestamp, Timestamp)
forall i s.
(i -> Timestamp)
-> Profile s -> i -> Maybe (s, Timestamp, Timestamp)
extractProfile i -> Timestamp
timer) r -> i -> Maybe k
index)

extractRouted :: Ord k => (s -> i -> Maybe o) -> (r -> i -> Maybe k) -> ((Map k s, r)  -> i -> Maybe (k, o))
extractRouted :: (s -> i -> Maybe o)
-> (r -> i -> Maybe k) -> (Map k s, r) -> i -> Maybe (k, o)
extractRouted s -> i -> Maybe o
extract r -> i -> Maybe k
index (Map k s
m, r
r) i
i = do
  k
k <- r -> i -> Maybe k
index r
r i
i
  s
s <- k -> Map k s -> Maybe s
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k s
m
  o
o <- s -> i -> Maybe o
extract s
s i
i
  (k, o) -> Maybe (k, o)
forall (m :: * -> *) a. Monad m => a -> m a
return (k
k, o
o)


-- | A machine can be indexed not only by the inputs, but also by the state
-- of an intermediary routing machine. This is a generalisation of indexM.
routeM :: (Ord k)
       => Machine r i
       -> (r -> i -> Maybe k)
       -> Machine s i
       -> Machine (Map k s, r) i
routeM :: Machine r i
-> (r -> i -> Maybe k) -> Machine s i -> Machine (Map k s, r) i
routeM Machine r i
router r -> i -> Maybe k
index Machine s i
machine = Machine :: forall s i.
s
-> (s -> Bool) -> (i -> Bool) -> (s -> i -> Maybe s) -> Machine s i
Machine
  { initial :: (Map k s, r)
initial = (Map k s
forall k a. Map k a
M.empty, Machine r i -> r
forall s i. Machine s i -> s
initial Machine r i
router)
  , final :: (Map k s, r) -> Bool
final   = (Map k s, r) -> Bool
forall b. b -> Bool
routeMFinal
  , alpha :: i -> Bool
alpha   = i -> Bool
routeMAlpha
  , delta :: (Map k s, r) -> i -> Maybe (Map k s, r)
delta   = (Map k s, r) -> i -> Maybe (Map k s, r)
routeMDelta
  }
 where
  -- As with indexers, there is no final state.
  routeMFinal :: b -> Bool
routeMFinal = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False

  -- The alphabet is that of the router combined with the machine
  routeMAlpha :: i -> Bool
routeMAlpha i
i = Machine r i -> i -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine r i
router i
i Bool -> Bool -> Bool
|| Machine s i -> i -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine s i
machine i
i

  routeMDelta :: (Map k s, r) -> i -> Maybe (Map k s, r)
routeMDelta (Map k s
m, r
r) i
i = do
    r
r' <- if Machine r i -> i -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine r i
router i
i
          then Machine r i -> r -> i -> Maybe r
forall s i. Machine s i -> s -> i -> Maybe s
delta Machine r i
router r
r i
i
          else r -> Maybe r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
    Map k s
m' <- if Machine s i -> i -> Bool
forall s i. Machine s i -> i -> Bool
alpha Machine s i
machine i
i
          then case r -> i -> Maybe k
index r
r' i
i of
            Just k
k -> do
              s
s' <- Machine s i -> s -> i -> Maybe s
forall s i. Machine s i -> s -> i -> Maybe s
delta Machine s i
machine (s -> Maybe s -> s
forall a. a -> Maybe a -> a
fromMaybe (Machine s i -> s
forall s i. Machine s i -> s
initial Machine s i
machine) (k -> Map k s -> Maybe s
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k s
m)) i
i
              Map k s -> Maybe (Map k s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k s -> Maybe (Map k s)) -> Map k s -> Maybe (Map k s)
forall a b. (a -> b) -> a -> b
$ k -> s -> Map k s -> Map k s
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k s
s' Map k s
m
            Maybe k
Nothing -> Map k s -> Maybe (Map k s)
forall (m :: * -> *) a. Monad m => a -> m a
return Map k s
m
          else Map k s -> Maybe (Map k s)
forall (m :: * -> *) a. Monad m => a -> m a
return Map k s
m
    (Map k s, r) -> Maybe (Map k s, r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k s
m', r
r')