{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# OPTIONS_HADDOCK ignore-exports #-}

{- | This module contains a simple greedy parser for path grammars.
 The grammar is provided by an evaluator ('Eval').
 In addition, the parser takes a policy function
 that picks a reduction option in each step.
-}
module GreedyParser where

-- TODO: add back export list once haddock's ignore-exports works again.
-- ( parseGreedy
-- , pickRandom
-- , parseRandom
-- , parseRandom'
-- ) where

import Common

import Control.Monad.Except
  ( ExceptT
  , MonadError (throwError)
  )
import Control.Monad.IO.Class
  ( MonadIO
  )
import Control.Monad.Trans.Class (lift)
import Data.Maybe
  ( catMaybes
  , mapMaybe
  , maybeToList
  )
import System.Random (initStdGen)
import System.Random.Stateful
  ( StatefulGen
  , newIOGenM
  , uniformRM
  )

-- * Parsing State

-- {- | A transition during greedy parsing.
--  Augments transition data with a flag
--  that indicates whether the transition is a transitive right (2nd) parent of a spread
--  and/or the direct parent of a left/single-split or thaw.
--  This allows the parser to enforce the following constraints:
--  - right splits are not allowed directly before a left split or freeze
--  - right splits
-- -}
-- data Trans tr = Trans
--   { gtContent :: !tr
--   -- ^ content of the transition
--   , gtSpread2nd :: !Bool
--   -- ^ flag that indicates (transitive) right parents of spreads
--   , gtStage1Parent :: !Bool
--   -- ^ flag that indicates that the edge is the parent of a freeze or left split,
--   -- preventing it from being used for a right split.
--   }
--   deriving (Show)

{- | The state of the greedy parse between steps.
 Generally, the current reduction consists of frozen transitions
 between the ⋊ and the current location
 and open transitions between the current location and ⋉.

 > ⋊==[1]==[2]==[3]——[4]——[5]——⋉
 >   └ frozen  ┘  | └   open  ┘
 >             midSlice (current position)
 >
 > frozen:   ==[2]==[1]==
 > midSlice: [3]
 > open:     ——[4]——[5]——

 This is the 'GSSemiOpen' case:
 The slice at the current pointer (@[3]@)
 is represented as an individual slice (@midSlice@).
 The frozen part is represented by a 'Path' of frozen transitions (@tr'@) and slices (@slc@).
 __in reverse direction__, i.e. from @midslice@ back to ⋊ (excluding ⋊).
 The open part is a 'Path' of open transitions (@tr@) and slices (@slc@)
 in forward direction from @midSlice@ up to ⋉.

 There are two special cases.
 All transitions can be frozen ('GSFrozen'),
 in which case state only contains the backward 'Path' of frozen transitions
 (excluding ⋊ and ⋉):

 > ⋊==[1]==[2]==[3]==⋉
 >                    └ current position
 > represented as: ==[3]==[2]==[1]==

 Or all transitions can be open ('GSOpen'),
 in which case the state is just the forward path of open transitions:

 > ⋊——[1]——[2]——[3]——⋉
 > └ current position
 > represented as: ——[1]——[2]——[3]——

 The open and semiopen case additionally have a list of operations in generative order,
 and a flag that indicates whether the previous step was a left operation,
 which would prevent continuing with a right unsplit.
-}
data GreedyState tr tr' slc op
  = GSFrozen !(Path (Maybe tr') slc)
  | GSSemiOpen
      { forall tr tr' slc op.
GreedyState tr tr' slc op -> Path (Maybe tr') slc
_gsFrozen :: !(Path (Maybe tr') slc)
      -- ^ frozen transitions and slices from current point leftward
      , forall tr tr' slc op. GreedyState tr tr' slc op -> slc
_gsMidSlice :: !slc
      -- ^ the slice at the current posision between gsFrozen and gsOpen
      , forall tr tr' slc op. GreedyState tr tr' slc op -> Path tr slc
_gsOpen :: !(Path tr slc)
      -- ^ non-frozen transitions and slices from current point rightward
      , forall tr tr' slc op. GreedyState tr tr' slc op -> [op]
_gsDeriv :: ![op]
      -- ^ derivation from current reduction to original surface
      }
  | GSOpen !(Path tr slc) ![op]

instance (Show tr, Show tr', Show slc, Show o) => Show (GreedyState tr tr' slc o) where
  show :: GreedyState tr tr' slc o -> String
show (GSFrozen Path (Maybe tr') slc
frozen) = Path (Maybe tr') slc -> String
forall slc tr'. (Show slc, Show tr') => Path tr' slc -> String
showFrozen Path (Maybe tr') slc
frozen String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n⋉"
  show (GSOpen Path tr slc
open [o]
_ops) = String
"⋊" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path tr slc -> String
forall slc tr'. (Show slc, Show tr') => Path tr' slc -> String
showOpen Path tr slc
open -- <> showOps ops
  show (GSSemiOpen Path (Maybe tr') slc
frozen slc
mid Path tr slc
open [o]
_ops) =
    Path (Maybe tr') slc -> String
forall slc tr'. (Show slc, Show tr') => Path tr' slc -> String
showFrozen Path (Maybe tr') slc
frozen String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> slc -> String
forall a. Show a => a -> String
show slc
mid String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path tr slc -> String
forall slc tr'. (Show slc, Show tr') => Path tr' slc -> String
showOpen Path tr slc
open -- <> showOps ops

-- | Helper function for showing the frozen part of a piece.
showFrozen :: (Show slc, Show tr') => Path tr' slc -> String
showFrozen :: forall slc tr'. (Show slc, Show tr') => Path tr' slc -> String
showFrozen Path tr' slc
path = String
"⋊" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path tr' slc -> String
forall {a} {a}. (Show a, Show a) => Path a a -> String
go Path tr' slc
path
 where
  go :: Path a a -> String
go (PathEnd a
tr) = String
"\n‖ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
tr
  go (Path a
tr a
slc Path a a
rst) = Path a a -> String
go Path a a
rst String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
slc String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n‖ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
tr

-- | Helper function for showing the open part of a piece.
showOpen :: (Show slc, Show tr) => Path tr slc -> String
showOpen :: forall slc tr'. (Show slc, Show tr') => Path tr' slc -> String
showOpen Path tr slc
path = Path tr slc -> String
forall {a} {a}. (Show a, Show a) => Path a a -> String
go Path tr slc
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n⋉"
 where
  go :: Path a a -> String
go (PathEnd a
tr) = String
"\n| " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
tr
  go (Path a
tr a
slc Path a a
rst) = String
"\n| " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
tr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
slc String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path a a -> String
go Path a a
rst

showOps :: (Show o) => [o] -> String
showOps :: forall o. Show o => [o] -> String
showOps [o]
ops = String
"\nops: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (o -> String) -> [o] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\o
o -> String
"\n- " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> o -> String
forall a. Show a => a -> String
show o
o) [o]
ops

gsOps :: GreedyState tr tr' slc op -> [op]
gsOps :: forall tr tr' slc op. GreedyState tr tr' slc op -> [op]
gsOps (GSFrozen Path (Maybe tr') slc
_) = []
gsOps (GSOpen Path tr slc
_ [op]
ops) = [op]
ops
gsOps (GSSemiOpen Path (Maybe tr') slc
_ slc
_ Path tr slc
_ [op]
ops) = [op]
ops

-- * Parsing Actions

-- | Single parent of a parsing action
data SingleParent slc tr = SingleParent !(StartStop slc) !tr !(StartStop slc)
  deriving (Int -> SingleParent slc tr -> ShowS
[SingleParent slc tr] -> ShowS
SingleParent slc tr -> String
(Int -> SingleParent slc tr -> ShowS)
-> (SingleParent slc tr -> String)
-> ([SingleParent slc tr] -> ShowS)
-> Show (SingleParent slc tr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall slc tr.
(Show slc, Show tr) =>
Int -> SingleParent slc tr -> ShowS
forall slc tr.
(Show slc, Show tr) =>
[SingleParent slc tr] -> ShowS
forall slc tr. (Show slc, Show tr) => SingleParent slc tr -> String
$cshowsPrec :: forall slc tr.
(Show slc, Show tr) =>
Int -> SingleParent slc tr -> ShowS
showsPrec :: Int -> SingleParent slc tr -> ShowS
$cshow :: forall slc tr. (Show slc, Show tr) => SingleParent slc tr -> String
show :: SingleParent slc tr -> String
$cshowList :: forall slc tr.
(Show slc, Show tr) =>
[SingleParent slc tr] -> ShowS
showList :: [SingleParent slc tr] -> ShowS
Show)

{- | A parsing action (reduction step) with a single parent transition.
 Combines the parent elements with a single-transition derivation operation.
-}
data ActionSingle slc tr s f
  = ActionSingle
      (SingleParent slc tr)
      -- ^ parent transition (and adjacent slices)
      (LeftmostSingle s f)
      -- ^ single-transition operation
  deriving (Int -> ActionSingle slc tr s f -> ShowS
[ActionSingle slc tr s f] -> ShowS
ActionSingle slc tr s f -> String
(Int -> ActionSingle slc tr s f -> ShowS)
-> (ActionSingle slc tr s f -> String)
-> ([ActionSingle slc tr s f] -> ShowS)
-> Show (ActionSingle slc tr s f)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
Int -> ActionSingle slc tr s f -> ShowS
forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
[ActionSingle slc tr s f] -> ShowS
forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
ActionSingle slc tr s f -> String
$cshowsPrec :: forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
Int -> ActionSingle slc tr s f -> ShowS
showsPrec :: Int -> ActionSingle slc tr s f -> ShowS
$cshow :: forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
ActionSingle slc tr s f -> String
show :: ActionSingle slc tr s f -> String
$cshowList :: forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
[ActionSingle slc tr s f] -> ShowS
showList :: [ActionSingle slc tr s f] -> ShowS
Show)

-- | Single parent of a parsing action
data DoubleParent slc tr
  = DoubleParent
      !(StartStop slc)
      !tr
      !slc
      !tr
      !(StartStop slc)
  deriving (Int -> DoubleParent slc tr -> ShowS
[DoubleParent slc tr] -> ShowS
DoubleParent slc tr -> String
(Int -> DoubleParent slc tr -> ShowS)
-> (DoubleParent slc tr -> String)
-> ([DoubleParent slc tr] -> ShowS)
-> Show (DoubleParent slc tr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall slc tr.
(Show slc, Show tr) =>
Int -> DoubleParent slc tr -> ShowS
forall slc tr.
(Show slc, Show tr) =>
[DoubleParent slc tr] -> ShowS
forall slc tr. (Show slc, Show tr) => DoubleParent slc tr -> String
$cshowsPrec :: forall slc tr.
(Show slc, Show tr) =>
Int -> DoubleParent slc tr -> ShowS
showsPrec :: Int -> DoubleParent slc tr -> ShowS
$cshow :: forall slc tr. (Show slc, Show tr) => DoubleParent slc tr -> String
show :: DoubleParent slc tr -> String
$cshowList :: forall slc tr.
(Show slc, Show tr) =>
[DoubleParent slc tr] -> ShowS
showList :: [DoubleParent slc tr] -> ShowS
Show)

{- | A parsing action (reduction step) with two parent transitions.
 Combines the parent elements with a double-transition derivation operation.
-}
data ActionDouble slc tr s f h
  = ActionDouble
      (DoubleParent slc tr)
      -- ^ parent transitions and slice
      (LeftmostDouble s f h)
      -- ^ double-transition operation
  deriving (Int -> ActionDouble slc tr s f h -> ShowS
[ActionDouble slc tr s f h] -> ShowS
ActionDouble slc tr s f h -> String
(Int -> ActionDouble slc tr s f h -> ShowS)
-> (ActionDouble slc tr s f h -> String)
-> ([ActionDouble slc tr s f h] -> ShowS)
-> Show (ActionDouble slc tr s f h)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall slc tr s f h.
(Show slc, Show tr, Show f, Show s, Show h) =>
Int -> ActionDouble slc tr s f h -> ShowS
forall slc tr s f h.
(Show slc, Show tr, Show f, Show s, Show h) =>
[ActionDouble slc tr s f h] -> ShowS
forall slc tr s f h.
(Show slc, Show tr, Show f, Show s, Show h) =>
ActionDouble slc tr s f h -> String
$cshowsPrec :: forall slc tr s f h.
(Show slc, Show tr, Show f, Show s, Show h) =>
Int -> ActionDouble slc tr s f h -> ShowS
showsPrec :: Int -> ActionDouble slc tr s f h -> ShowS
$cshow :: forall slc tr s f h.
(Show slc, Show tr, Show f, Show s, Show h) =>
ActionDouble slc tr s f h -> String
show :: ActionDouble slc tr s f h -> String
$cshowList :: forall slc tr s f h.
(Show slc, Show tr, Show f, Show s, Show h) =>
[ActionDouble slc tr s f h] -> ShowS
showList :: [ActionDouble slc tr s f h] -> ShowS
Show)

-- | An alias that combines 'ActionSingle' and 'ActionDouble', representing all possible reduction steps.
type Action slc tr s f h = Either (ActionSingle slc tr s f) (ActionDouble slc tr s f h)

{- | A helper function that checks whether an action:
- - is a double action and goes left ('Just True')
- - is a double action and goes right ('Just False')
- - is a single action ('Nothing', doesn't have to choose).
- (See 'opGoesLeft'.)
-}
actionGoesLeft :: Action slc tr s f h -> Maybe Bool
actionGoesLeft :: forall slc tr s f h. Action slc tr s f h -> Maybe Bool
actionGoesLeft (Right (ActionDouble DoubleParent slc tr
_ LeftmostDouble s f h
op)) = case LeftmostDouble s f h
op of
  LMDoubleFreezeLeft f
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  LMDoubleSplitLeft s
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  LeftmostDouble s f h
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
actionGoesLeft Either (ActionSingle slc tr s f) (ActionDouble slc tr s f h)
_ = Maybe Bool
forall a. Maybe a
Nothing

{- | A helper function that checks whether a derivation operation:
- - is a double op and goes left ('Just True')
- - is a double op and goes right ('Just False')
- - is a single op ('Nothing', doesn't have to choose).
- (See 'actionGoesLeft'.)
-}
opGoesLeft :: Leftmost s f h -> Maybe Bool
opGoesLeft :: forall s f h. Leftmost s f h -> Maybe Bool
opGoesLeft (LMDouble LeftmostDouble s f h
lmd) = case LeftmostDouble s f h
lmd of
  LMDoubleFreezeLeft f
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  LMDoubleSplitLeft s
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  LeftmostDouble s f h
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
opGoesLeft Leftmost s f h
_ = Maybe Bool
forall a. Maybe a
Nothing

-- * Parsing Algorithm

{- | Parse a piece in a greedy fashion.
 At each step, a policy chooses from the possible reduction actions,
 the reduction is applied, and parsing continues
 until the piece is fully reduced or no more reduction operations are available.
 Returns the full derivation from the top (@⋊——⋉@) or an error message.
-}
parseGreedy
  :: forall m tr tr' slc slc' s f h
   . (Monad m, MonadIO m, Show tr', Show slc, Show tr, Show s, Show f, Show h)
  => Eval tr tr' slc slc' h (Leftmost s f h)
  -- ^ the evaluator of the grammar to be used
  -> ([Action slc tr s f h] -> ExceptT String m (Action slc tr s f h))
  -- ^ the policy: picks a parsing action from a list of options
  -- (determines the 'Monad' @m@, e.g., for randomness).
  -> Path slc' tr'
  -- ^ the input piece
  -> ExceptT String m (Analysis s f h tr slc)
  -- ^ the full parse or an error message
parseGreedy :: forall (m :: * -> *) tr tr' slc slc' s f h.
(Monad m, MonadIO m, Show tr', Show slc, Show tr, Show s, Show f,
 Show h) =>
Eval tr tr' slc slc' h (Leftmost s f h)
-> ([Action slc tr s f h]
    -> ExceptT String m (Action slc tr s f h))
-> Path slc' tr'
-> ExceptT String m (Analysis s f h tr slc)
parseGreedy Eval tr tr' slc slc' h (Leftmost s f h)
eval [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
pick Path slc' tr'
input = do
  (top, deriv) <- GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT String m (tr, [Leftmost s f h])
parse GreedyState tr tr' slc (Leftmost s f h)
forall {op}. GreedyState tr tr' slc op
state0
  pure $ Analysis deriv $ PathEnd top
 where
  state0 :: GreedyState tr tr' slc op
state0 = Eval tr tr' slc slc' h (Leftmost s f h)
-> Path slc' tr' -> GreedyState tr tr' slc op
forall tr tr' slc slc' h v op.
Eval tr tr' slc slc' h v
-> Path slc' tr' -> GreedyState tr tr' slc op
initParseState Eval tr tr' slc slc' h (Leftmost s f h)
eval Path slc' tr'
input
  parse :: GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT String m (tr, [Leftmost s f h])
parse GreedyState tr tr' slc (Leftmost s f h)
state = do
    result <- Eval tr tr' slc slc' h (Leftmost s f h)
-> ([Action slc tr s f h]
    -> ExceptT String m (Action slc tr s f h))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall (m :: * -> *) tr tr' slc slc' s f h.
Monad m =>
Eval tr tr' slc slc' h (Leftmost s f h)
-> ([Action slc tr s f h]
    -> ExceptT String m (Action slc tr s f h))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
parseStep Eval tr tr' slc slc' h (Leftmost s f h)
eval [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
pick GreedyState tr tr' slc (Leftmost s f h)
state
    case result of
      Left GreedyState tr tr' slc (Leftmost s f h)
state' -> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT String m (tr, [Leftmost s f h])
parse GreedyState tr tr' slc (Leftmost s f h)
state'
      Right (tr, [Leftmost s f h])
result -> (tr, [Leftmost s f h]) -> ExceptT String m (tr, [Leftmost s f h])
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (tr, [Leftmost s f h])
result

{- | Initializes a parse state.
Takes an evaluator and a (frozen) input path.
Returns the parsing state that corresponds to the unparsed input.
-}
initParseState
  :: forall tr tr' slc slc' h v op
   . Eval tr tr' slc slc' h v
  -> Path slc' tr'
  -> GreedyState tr tr' slc op
initParseState :: forall tr tr' slc slc' h v op.
Eval tr tr' slc slc' h v
-> Path slc' tr' -> GreedyState tr tr' slc op
initParseState Eval tr tr' slc slc' h v
eval Path slc' tr'
input = Path (Maybe tr') slc -> GreedyState tr tr' slc op
forall tr tr' slc op.
Path (Maybe tr') slc -> GreedyState tr tr' slc op
GSFrozen (Path (Maybe tr') slc -> GreedyState tr tr' slc op)
-> Path (Maybe tr') slc -> GreedyState tr tr' slc op
forall a b. (a -> b) -> a -> b
$ Maybe tr' -> Path slc' tr' -> Path (Maybe tr') slc
wrapPath Maybe tr'
forall a. Maybe a
Nothing (Path slc' tr' -> Path slc' tr'
forall a b. Path a b -> Path a b
reversePath Path slc' tr'
input)
 where
  -- prepare the input: eval slices, wrap in Inner, add Start/Stop
  wrapPath :: Maybe tr' -> Path slc' tr' -> Path (Maybe tr') slc
  wrapPath :: Maybe tr' -> Path slc' tr' -> Path (Maybe tr') slc
wrapPath Maybe tr'
eleft (PathEnd slc'
a) = Maybe tr' -> slc -> Path (Maybe tr') slc -> Path (Maybe tr') slc
forall around between.
around -> between -> Path around between -> Path around between
Path Maybe tr'
eleft (Eval tr tr' slc slc' h v -> slc' -> slc
forall tr tr' slc slc' h v. Eval tr tr' slc slc' h v -> slc' -> slc
evalSlice Eval tr tr' slc slc' h v
eval slc'
a) (Path (Maybe tr') slc -> Path (Maybe tr') slc)
-> Path (Maybe tr') slc -> Path (Maybe tr') slc
forall a b. (a -> b) -> a -> b
$ Maybe tr' -> Path (Maybe tr') slc
forall around between. around -> Path around between
PathEnd Maybe tr'
forall a. Maybe a
Nothing
  wrapPath Maybe tr'
eleft (Path slc'
a tr'
e Path slc' tr'
rst) =
    Maybe tr' -> slc -> Path (Maybe tr') slc -> Path (Maybe tr') slc
forall around between.
around -> between -> Path around between -> Path around between
Path Maybe tr'
eleft (Eval tr tr' slc slc' h v -> slc' -> slc
forall tr tr' slc slc' h v. Eval tr tr' slc slc' h v -> slc' -> slc
evalSlice Eval tr tr' slc slc' h v
eval slc'
a) (Path (Maybe tr') slc -> Path (Maybe tr') slc)
-> Path (Maybe tr') slc -> Path (Maybe tr') slc
forall a b. (a -> b) -> a -> b
$ Maybe tr' -> Path slc' tr' -> Path (Maybe tr') slc
wrapPath (tr' -> Maybe tr'
forall a. a -> Maybe a
Just tr'
e) Path slc' tr'
rst

{- | A single greedy parse step.
 Enumerates a list of possible actions in the current state
 and applies a policy function to select an action.
 The resulting state is returned,
 wrapped in a monad transformer stack containing
 'String' exceptions and the monad of the policy.
-}
parseStep
  :: forall m tr tr' slc slc' s f h
   . (Monad m)
  => Eval tr tr' slc slc' h (Leftmost s f h)
  -- ^ the evaluator of the grammar to be used
  -> ([Action slc tr s f h] -> ExceptT String m (Action slc tr s f h))
  -- ^ the policy: picks a parsing action from a list of options
  -- (determines the 'Monad' @m@, e.g., for randomness).
  -> GreedyState tr tr' slc (Leftmost s f h)
  -- ^ the current parsing state
  -> ExceptT String m (Either (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
  -- ^ either the next state or the result of the parse.
parseStep :: forall (m :: * -> *) tr tr' slc slc' s f h.
Monad m =>
Eval tr tr' slc slc' h (Leftmost s f h)
-> ([Action slc tr s f h]
    -> ExceptT String m (Action slc tr s f h))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
parseStep Eval tr tr' slc slc' h (Leftmost s f h)
eval [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
pick GreedyState tr tr' slc (Leftmost s f h)
state = do
  -- liftIO $ putStrLn "" >> print state
  case GreedyState tr tr' slc (Leftmost s f h)
state of
    -- case 1: everything frozen
    GSFrozen Path (Maybe tr') slc
frozen -> case Path (Maybe tr') slc
frozen of
      -- only one transition: unfreeze and terminate
      PathEnd Maybe tr'
trans -> do
        (thawed, op) <-
          [ActionSingle slc tr s f]
-> ExceptT String m (tr, LeftmostSingle s f)
pickSingle ([ActionSingle slc tr s f]
 -> ExceptT String m (tr, LeftmostSingle s f))
-> [ActionSingle slc tr s f]
-> ExceptT String m (tr, LeftmostSingle s f)
forall a b. (a -> b) -> a -> b
$
            Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
collectThawSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start Maybe tr'
trans StartStop slc
forall a. StartStop a
Stop
        finish (thawed, [LMSingle op])
      -- several transition: unfreeze last and continue
      Path Maybe tr'
t slc
slice Path (Maybe tr') slc
rst -> do
        (thawed, op) <- [ActionSingle slc tr s f]
-> ExceptT String m (tr, LeftmostSingle s f)
pickSingle ([ActionSingle slc tr s f]
 -> ExceptT String m (tr, LeftmostSingle s f))
-> [ActionSingle slc tr s f]
-> ExceptT String m (tr, LeftmostSingle s f)
forall a b. (a -> b) -> a -> b
$ Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
collectThawSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
slice) Maybe tr'
t StartStop slc
forall a. StartStop a
Stop
        continue $ GSSemiOpen rst slice (PathEnd thawed) [LMSingle op]

    -- case 2: everything open
    GSOpen Path tr slc
open [Leftmost s f h]
ops -> case Path tr slc
open of
      -- only one transition: terminate
      PathEnd tr
t -> (tr, [Leftmost s f h])
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {a}. a -> ExceptT String m (Either a a)
finish (tr
t, [Leftmost s f h]
ops)
      -- two transitions: unsplit single and terminate
      Path tr
tl slc
slice (PathEnd tr
tr) -> do
        (ttop, optop) <-
          [ActionSingle slc tr s f]
-> ExceptT String m (tr, LeftmostSingle s f)
pickSingle ([ActionSingle slc tr s f]
 -> ExceptT String m (tr, LeftmostSingle s f))
-> [ActionSingle slc tr s f]
-> ExceptT String m (tr, LeftmostSingle s f)
forall a b. (a -> b) -> a -> b
$
            Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
collectUnsplitSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start tr
tl slc
slice tr
tr StartStop slc
forall a. StartStop a
Stop
        finish (ttop, LMSingle optop : ops)
      -- more than two transitions: pick double operation and continue
      Path tr
tl slc
sl (Path tr
tm slc
sr Path tr slc
rst) -> do
        let doubles :: [ActionDouble slc tr s f h]
doubles = Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
collectDoubles Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start tr
tl slc
sl tr
tm slc
sr Path tr slc
rst ([Leftmost s f h] -> Bool
forall s f h. [Leftmost s f h] -> Bool
lastWasLeft [Leftmost s f h]
ops)
        ((topl, tops, topr), op) <- [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
pickDouble [ActionDouble slc tr s f h]
doubles
        continue $
          GSOpen
            (Path topl tops (pathSetHead rst topr))
            (LMDouble op : ops)

    -- case 3: some parts frozen, some open
    GSSemiOpen Path (Maybe tr') slc
frozen slc
mid Path tr slc
open [Leftmost s f h]
ops -> case Path tr slc
open of
      -- only one open transition: thaw
      PathEnd tr
topen -> case Path (Maybe tr') slc
frozen of
        PathEnd Maybe tr'
tfrozen -> do
          ((thawed, _, _), op) <-
            [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
pickDouble ([ActionDouble slc tr s f h]
 -> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h))
-> [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
forall a b. (a -> b) -> a -> b
$
              Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start Maybe tr'
tfrozen slc
mid tr
topen StartStop slc
forall a. StartStop a
Stop
          continue $ GSOpen (Path thawed mid open) (LMDouble op : ops)
        Path Maybe tr'
tfrozen slc
sfrozen Path (Maybe tr') slc
rstFrozen -> do
          ((thawed, _, _), op) <-
            [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
pickDouble ([ActionDouble slc tr s f h]
 -> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h))
-> [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
forall a b. (a -> b) -> a -> b
$
              Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sfrozen) Maybe tr'
tfrozen slc
mid tr
topen StartStop slc
forall a. StartStop a
Stop
          continue $
            GSSemiOpen
              rstFrozen
              sfrozen
              (Path thawed mid open)
              (LMDouble op : ops)
      -- two open transitions: thaw or unsplit single
      Path tr
topenl slc
sopen (PathEnd tr
topenr) -> do
        let
          unsplits :: [Either (ActionSingle slc tr s f) b]
unsplits =
            ActionSingle slc tr s f -> Either (ActionSingle slc tr s f) b
forall a b. a -> Either a b
Left (ActionSingle slc tr s f -> Either (ActionSingle slc tr s f) b)
-> [ActionSingle slc tr s f]
-> [Either (ActionSingle slc tr s f) b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
collectUnsplitSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
mid) tr
topenl slc
sopen tr
topenr StartStop slc
forall a. StartStop a
Stop
        case Path (Maybe tr') slc
frozen of
          PathEnd Maybe tr'
tfrozen -> do
            let
              thaws :: [Either a (ActionDouble slc tr s f h)]
thaws =
                ActionDouble slc tr s f h -> Either a (ActionDouble slc tr s f h)
forall a b. b -> Either a b
Right
                  (ActionDouble slc tr s f h -> Either a (ActionDouble slc tr s f h))
-> [ActionDouble slc tr s f h]
-> [Either a (ActionDouble slc tr s f h)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start Maybe tr'
tfrozen slc
mid tr
topenl (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sopen)
            action <- [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
pick ([Action slc tr s f h] -> ExceptT String m (Action slc tr s f h))
-> [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
forall a b. (a -> b) -> a -> b
$ [Action slc tr s f h]
forall {a}. [Either a (ActionDouble slc tr s f h)]
thaws [Action slc tr s f h]
-> [Action slc tr s f h] -> [Action slc tr s f h]
forall a. Semigroup a => a -> a -> a
<> [Action slc tr s f h]
forall {b}. [Either (ActionSingle slc tr s f) b]
unsplits
            case action of
              -- picked unsplit
              Left (ActionSingle (SingleParent StartStop slc
_ tr
parent StartStop slc
_) LeftmostSingle s f
op) ->
                GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> ExceptT String m (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> ExceptT
      String
      m
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$
                  Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen
                    Path (Maybe tr') slc
frozen
                    slc
mid
                    (tr -> Path tr slc
forall around between. around -> Path around between
PathEnd tr
parent)
                    (LeftmostSingle s f -> Leftmost s f h
forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
              -- picked thaw
              Right (ActionDouble (DoubleParent StartStop slc
_ tr
thawed slc
_ tr
_ StartStop slc
_) LeftmostDouble s f h
op) ->
                GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> ExceptT String m (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> ExceptT
      String
      m
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path tr slc
-> [Leftmost s f h] -> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path tr slc -> [op] -> GreedyState tr tr' slc op
GSOpen (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
thawed slc
mid Path tr slc
open) (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
          Path Maybe tr'
tfrozen slc
sfrozen Path (Maybe tr') slc
rstFrozen -> do
            let thaws :: [Either a (ActionDouble slc tr s f h)]
thaws =
                  ActionDouble slc tr s f h -> Either a (ActionDouble slc tr s f h)
forall a b. b -> Either a b
Right
                    (ActionDouble slc tr s f h -> Either a (ActionDouble slc tr s f h))
-> [ActionDouble slc tr s f h]
-> [Either a (ActionDouble slc tr s f h)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft
                      Eval tr tr' slc slc' h (Leftmost s f h)
eval
                      (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sfrozen)
                      Maybe tr'
tfrozen
                      slc
mid
                      tr
topenl
                      (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sopen)
            action <- [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
pick ([Action slc tr s f h] -> ExceptT String m (Action slc tr s f h))
-> [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
forall a b. (a -> b) -> a -> b
$ [Action slc tr s f h]
forall {a}. [Either a (ActionDouble slc tr s f h)]
thaws [Action slc tr s f h]
-> [Action slc tr s f h] -> [Action slc tr s f h]
forall a. Semigroup a => a -> a -> a
<> [Action slc tr s f h]
forall {b}. [Either (ActionSingle slc tr s f) b]
unsplits
            case action of
              -- picked unsplit
              Left (ActionSingle (SingleParent StartStop slc
_ tr
parent StartStop slc
_) LeftmostSingle s f
op) ->
                GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> ExceptT String m (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> ExceptT
      String
      m
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$
                  Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen
                    Path (Maybe tr') slc
frozen
                    slc
mid
                    (tr -> Path tr slc
forall around between. around -> Path around between
PathEnd tr
parent)
                    (LeftmostSingle s f -> Leftmost s f h
forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
              -- picked thaw
              Right (ActionDouble (DoubleParent StartStop slc
_ tr
thawed slc
_ tr
_ StartStop slc
_) LeftmostDouble s f h
op) ->
                GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> ExceptT String m (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> ExceptT
      String
      m
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$
                  Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen
                    Path (Maybe tr') slc
rstFrozen
                    slc
sfrozen
                    (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
thawed slc
mid Path tr slc
open)
                    (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
      -- more than two open transitions: thaw or any double operation
      Path tr
topenl slc
sopenl (Path tr
topenm slc
sopenr Path tr slc
rstOpen) -> do
        let doubles :: [ActionDouble slc tr s f h]
doubles =
              Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
collectDoubles Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
mid) tr
topenl slc
sopenl tr
topenm slc
sopenr Path tr slc
rstOpen ([Leftmost s f h] -> Bool
forall s f h. [Leftmost s f h] -> Bool
lastWasLeft [Leftmost s f h]
ops)
        case Path (Maybe tr') slc
frozen of
          PathEnd Maybe tr'
tfrozen -> do
            let thaws :: [ActionDouble slc tr s f h]
thaws =
                  Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start Maybe tr'
tfrozen slc
mid tr
topenl (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sopenl)
            action <- [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
pickDouble ([ActionDouble slc tr s f h]
 -> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h))
-> [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
forall a b. (a -> b) -> a -> b
$ [ActionDouble slc tr s f h]
thaws [ActionDouble slc tr s f h]
-> [ActionDouble slc tr s f h] -> [ActionDouble slc tr s f h]
forall a. Semigroup a => a -> a -> a
<> [ActionDouble slc tr s f h]
doubles
            case action of
              -- picked thaw
              ((tr
thawed, slc
_, tr
_), op :: LeftmostDouble s f h
op@(LMDoubleFreezeLeft f
_)) ->
                GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> ExceptT String m (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> ExceptT
      String
      m
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path tr slc
-> [Leftmost s f h] -> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path tr slc -> [op] -> GreedyState tr tr' slc op
GSOpen (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
thawed slc
mid Path tr slc
open) (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
              -- picked non-thaw
              ((tr
topl, slc
tops, tr
topr), LeftmostDouble s f h
op) ->
                GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> ExceptT String m (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> ExceptT
      String
      m
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$
                  Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen
                    Path (Maybe tr') slc
frozen
                    slc
mid
                    (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
topl slc
tops (Path tr slc -> tr -> Path tr slc
forall a b. Path a b -> a -> Path a b
pathSetHead Path tr slc
rstOpen tr
topr))
                    (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
          Path Maybe tr'
tfrozen slc
sfrozen Path (Maybe tr') slc
rstFrozen -> do
            let
              thaws :: [ActionDouble slc tr s f h]
thaws =
                Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft
                  Eval tr tr' slc slc' h (Leftmost s f h)
eval
                  (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sfrozen)
                  Maybe tr'
tfrozen
                  slc
mid
                  tr
topenl
                  (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sopenl)
            action <- [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
pickDouble ([ActionDouble slc tr s f h]
 -> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h))
-> [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
forall a b. (a -> b) -> a -> b
$ [ActionDouble slc tr s f h]
thaws [ActionDouble slc tr s f h]
-> [ActionDouble slc tr s f h] -> [ActionDouble slc tr s f h]
forall a. Semigroup a => a -> a -> a
<> [ActionDouble slc tr s f h]
doubles
            case action of
              -- picked thaw
              ((tr
thawed, slc
_, tr
_), op :: LeftmostDouble s f h
op@(LMDoubleFreezeLeft f
_)) ->
                GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> ExceptT String m (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> ExceptT
      String
      m
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$
                  Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen
                    Path (Maybe tr') slc
rstFrozen
                    slc
sfrozen
                    (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
thawed slc
mid Path tr slc
open)
                    (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
              -- picked non-thaw
              ((tr
topl, slc
tops, tr
topr), LeftmostDouble s f h
op) ->
                GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> ExceptT String m (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> ExceptT
      String
      m
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT
     String
     m
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$
                  Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen
                    Path (Maybe tr') slc
frozen
                    slc
mid
                    (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
topl slc
tops (Path tr slc -> tr -> Path tr slc
forall a b. Path a b -> a -> Path a b
pathSetHead Path tr slc
rstOpen tr
topr))
                    (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
 where
  continue :: a -> ExceptT String m (Either a b)
continue = Either a b -> ExceptT String m (Either a b)
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> ExceptT String m (Either a b))
-> (a -> Either a b) -> a -> ExceptT String m (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left
  finish :: a -> ExceptT String m (Either a a)
finish = Either a a -> ExceptT String m (Either a a)
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a a -> ExceptT String m (Either a a))
-> (a -> Either a a) -> a -> ExceptT String m (Either a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a a
forall a b. b -> Either a b
Right

  pickSingle
    :: [ActionSingle slc tr s f] -> ExceptT String m (tr, LeftmostSingle s f)
  pickSingle :: [ActionSingle slc tr s f]
-> ExceptT String m (tr, LeftmostSingle s f)
pickSingle [ActionSingle slc tr s f]
actions = do
    -- liftIO $ putStrLn $ "pickSingle " <> show actions
    action <- [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
pick ([Action slc tr s f h] -> ExceptT String m (Action slc tr s f h))
-> [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
forall a b. (a -> b) -> a -> b
$ ActionSingle slc tr s f -> Action slc tr s f h
forall a b. a -> Either a b
Left (ActionSingle slc tr s f -> Action slc tr s f h)
-> [ActionSingle slc tr s f] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ActionSingle slc tr s f]
actions
    case action of
      Left (ActionSingle (SingleParent StartStop slc
_ tr
top StartStop slc
_) LeftmostSingle s f
op) -> (tr, LeftmostSingle s f)
-> ExceptT String m (tr, LeftmostSingle s f)
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (tr
top, LeftmostSingle s f
op)
      Right ActionDouble slc tr s f h
_ -> String -> ExceptT String m (tr, LeftmostSingle s f)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"pickSingle returned a double action"

  pickDouble
    :: [ActionDouble slc tr s f h]
    -> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
  pickDouble :: [ActionDouble slc tr s f h]
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
pickDouble [ActionDouble slc tr s f h]
actions = do
    -- liftIO $ putStrLn $ "pickDouble " <> show actions
    action <- [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
pick ([Action slc tr s f h] -> ExceptT String m (Action slc tr s f h))
-> [Action slc tr s f h] -> ExceptT String m (Action slc tr s f h)
forall a b. (a -> b) -> a -> b
$ ActionDouble slc tr s f h -> Action slc tr s f h
forall a b. b -> Either a b
Right (ActionDouble slc tr s f h -> Action slc tr s f h)
-> [ActionDouble slc tr s f h] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ActionDouble slc tr s f h]
actions
    case action of
      Left ActionSingle slc tr s f
_ -> String -> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"pickDouble returned a single action"
      Right (ActionDouble (DoubleParent StartStop slc
_ tr
topl slc
tops tr
topr StartStop slc
_) LeftmostDouble s f h
op) ->
        ((tr, slc, tr), LeftmostDouble s f h)
-> ExceptT String m ((tr, slc, tr), LeftmostDouble s f h)
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((tr
topl, slc
tops, tr
topr), LeftmostDouble s f h
op)

-- | Enumerates the list of possible actions in the current state
getActions
  :: forall m tr tr' slc slc' s f h
   . Eval tr tr' slc slc' h (Leftmost s f h)
  -- ^ the evaluator of the grammar to be used
  -> GreedyState tr tr' slc (Leftmost s f h)
  -- ^ the current parsing state
  -> [Action slc tr s f h]
  -- ^ the list of possible actions
getActions :: forall {k} (m :: k) tr tr' slc slc' s f h.
Eval tr tr' slc slc' h (Leftmost s f h)
-> GreedyState tr tr' slc (Leftmost s f h) -> [Action slc tr s f h]
getActions Eval tr tr' slc slc' h (Leftmost s f h)
eval GreedyState tr tr' slc (Leftmost s f h)
state =
  -- check which type of state we are in
  case GreedyState tr tr' slc (Leftmost s f h)
state of
    -- case 1: everything frozen
    GSFrozen Path (Maybe tr') slc
frozen -> case Path (Maybe tr') slc
frozen of
      PathEnd Maybe tr'
trans -> ActionSingle slc tr s f -> Action slc tr s f h
forall a b. a -> Either a b
Left (ActionSingle slc tr s f -> Action slc tr s f h)
-> [ActionSingle slc tr s f] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
collectThawSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start Maybe tr'
trans StartStop slc
forall a. StartStop a
Stop
      Path Maybe tr'
t slc
slice Path (Maybe tr') slc
rst -> ActionSingle slc tr s f -> Action slc tr s f h
forall a b. a -> Either a b
Left (ActionSingle slc tr s f -> Action slc tr s f h)
-> [ActionSingle slc tr s f] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
collectThawSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
slice) Maybe tr'
t StartStop slc
forall a. StartStop a
Stop
    -- case 2: everything open
    GSOpen Path tr slc
open [Leftmost s f h]
ops -> case Path tr slc
open of
      PathEnd tr
_t -> []
      Path tr
tl slc
slice (PathEnd tr
tr) -> ActionSingle slc tr s f -> Action slc tr s f h
forall a b. a -> Either a b
Left (ActionSingle slc tr s f -> Action slc tr s f h)
-> [ActionSingle slc tr s f] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
collectUnsplitSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start tr
tl slc
slice tr
tr StartStop slc
forall a. StartStop a
Stop
      Path tr
tl slc
sl (Path tr
tm slc
sr Path tr slc
rst) -> ActionDouble slc tr s f h -> Action slc tr s f h
forall a b. b -> Either a b
Right (ActionDouble slc tr s f h -> Action slc tr s f h)
-> [ActionDouble slc tr s f h] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
collectDoubles Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start tr
tl slc
sl tr
tm slc
sr Path tr slc
rst ([Leftmost s f h] -> Bool
forall s f h. [Leftmost s f h] -> Bool
lastWasLeft [Leftmost s f h]
ops)
    -- case 3: some parts frozen, some open
    -- check how many transitions are open
    GSSemiOpen Path (Maybe tr') slc
frozen slc
mid Path tr slc
open [Leftmost s f h]
ops -> case Path tr slc
open of
      -- only one open transition: thaw
      PathEnd tr
topen -> ActionDouble slc tr s f h -> Action slc tr s f h
forall a b. b -> Either a b
Right (ActionDouble slc tr s f h -> Action slc tr s f h)
-> [ActionDouble slc tr s f h] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eval tr tr' slc slc' h (Leftmost s f h)
-> Path (Maybe tr') slc
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> Path (Maybe tr') slc
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectAllThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval Path (Maybe tr') slc
frozen slc
mid tr
topen StartStop slc
forall a. StartStop a
Stop
      -- two open transitions: thaw or unsplit single
      Path tr
t1 slc
s1 (PathEnd tr
t2) ->
        let
          unsplits :: [ActionSingle slc tr s f]
unsplits = Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
collectUnsplitSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
mid) tr
t1 slc
s1 tr
t2 StartStop slc
forall a. StartStop a
Stop
          thaws :: [ActionDouble slc tr s f h]
thaws = Eval tr tr' slc slc' h (Leftmost s f h)
-> Path (Maybe tr') slc
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> Path (Maybe tr') slc
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectAllThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval Path (Maybe tr') slc
frozen slc
mid tr
t1 (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
s1)
         in
          (ActionSingle slc tr s f -> Action slc tr s f h
forall a b. a -> Either a b
Left (ActionSingle slc tr s f -> Action slc tr s f h)
-> [ActionSingle slc tr s f] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ActionSingle slc tr s f]
unsplits) [Action slc tr s f h]
-> [Action slc tr s f h] -> [Action slc tr s f h]
forall a. Semigroup a => a -> a -> a
<> (ActionDouble slc tr s f h -> Action slc tr s f h
forall a b. b -> Either a b
Right (ActionDouble slc tr s f h -> Action slc tr s f h)
-> [ActionDouble slc tr s f h] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ActionDouble slc tr s f h]
thaws)
      -- more than two open transitions: thaw or any double operation
      Path tr
t1 slc
s1 (Path tr
t2 slc
s2 Path tr slc
rstOpen) -> do
        let doubles :: [ActionDouble slc tr s f h]
doubles = Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
collectDoubles Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
mid) tr
t1 slc
s1 tr
t2 slc
s2 Path tr slc
rstOpen ([Leftmost s f h] -> Bool
forall s f h. [Leftmost s f h] -> Bool
lastWasLeft [Leftmost s f h]
ops)
            thaws :: [ActionDouble slc tr s f h]
thaws = Eval tr tr' slc slc' h (Leftmost s f h)
-> Path (Maybe tr') slc
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> Path (Maybe tr') slc
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectAllThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval Path (Maybe tr') slc
frozen slc
mid tr
t1 (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
s1)
        ActionDouble slc tr s f h -> Action slc tr s f h
forall a b. b -> Either a b
Right (ActionDouble slc tr s f h -> Action slc tr s f h)
-> [ActionDouble slc tr s f h] -> [Action slc tr s f h]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ActionDouble slc tr s f h]
doubles [ActionDouble slc tr s f h]
-> [ActionDouble slc tr s f h] -> [ActionDouble slc tr s f h]
forall a. Semigroup a => a -> a -> a
<> [ActionDouble slc tr s f h]
thaws)

-- helper functions for getActions and parseStep
-- ---------------------------------------------

lastWasLeft :: [Leftmost s f h] -> Bool
lastWasLeft :: forall s f h. [Leftmost s f h] -> Bool
lastWasLeft [] = Bool
False
lastWasLeft (Leftmost s f h
op : [Leftmost s f h]
_) = case Leftmost s f h
op of
  LMSplitLeft s
_ -> Bool
True
  LMFreezeLeft f
_ -> Bool
True
  Leftmost s f h
_ -> Bool
False

collectAllThawLeft
  :: Eval tr tr' slc slc' h (Leftmost s f h)
  -> Path (Maybe tr') slc
  -> slc
  -> tr
  -> StartStop slc
  -> [ActionDouble slc tr s f h]
collectAllThawLeft :: forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> Path (Maybe tr') slc
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectAllThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval Path (Maybe tr') slc
frozen slc
sm tr
tr StartStop slc
sr =
  case Path (Maybe tr') slc
frozen of
    PathEnd Maybe tr'
tfrozen -> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
forall a. StartStop a
Start Maybe tr'
tfrozen slc
sm tr
tr StartStop slc
sr
    Path Maybe tr'
tfrozen slc
sl Path (Maybe tr') slc
_ -> Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sl) Maybe tr'
tfrozen slc
sm tr
tr StartStop slc
sr

collectThawSingle
  :: Eval tr tr' slc slc' h (Leftmost s f h)
  -> StartStop slc
  -> Maybe tr'
  -> StartStop slc
  -> [ActionSingle slc tr s f]
collectThawSingle :: forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> [ActionSingle slc tr s f]
collectThawSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sl Maybe tr'
t StartStop slc
sr =
  ((tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f))
-> [(tr, Leftmost s f h)] -> [ActionSingle slc tr s f]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
    (tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f)
forall {tr} {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f)
getAction
    (Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> Bool
-> [(tr, Leftmost s f h)]
forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v
-> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
evalUnfreeze Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sl Maybe tr'
t StartStop slc
sr Bool
True)
 where
  getAction :: (tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f)
getAction (tr
t', Leftmost s f h
op) = case Leftmost s f h
op of
    LMSingle LeftmostSingle s f
sop -> ActionSingle slc tr s f -> Maybe (ActionSingle slc tr s f)
forall a. a -> Maybe a
Just (ActionSingle slc tr s f -> Maybe (ActionSingle slc tr s f))
-> ActionSingle slc tr s f -> Maybe (ActionSingle slc tr s f)
forall a b. (a -> b) -> a -> b
$ SingleParent slc tr
-> LeftmostSingle s f -> ActionSingle slc tr s f
forall slc tr s f.
SingleParent slc tr
-> LeftmostSingle s f -> ActionSingle slc tr s f
ActionSingle (StartStop slc -> tr -> StartStop slc -> SingleParent slc tr
forall slc tr.
StartStop slc -> tr -> StartStop slc -> SingleParent slc tr
SingleParent StartStop slc
sl tr
t' StartStop slc
sr) LeftmostSingle s f
sop
    LMDouble LeftmostDouble s f h
_ -> Maybe (ActionSingle slc tr s f)
forall a. Maybe a
Nothing

collectThawLeft
  :: Eval tr tr' slc slc' h (Leftmost s f h)
  -> StartStop slc
  -> Maybe tr'
  -> slc
  -> tr
  -> StartStop slc
  -> [ActionDouble slc tr s f h]
collectThawLeft :: forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sl Maybe tr'
tl slc
sm tr
tr StartStop slc
sr =
  ((tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h))
-> [(tr, Leftmost s f h)] -> [ActionDouble slc tr s f h]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
    (tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
forall {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction
    (Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> Maybe tr'
-> StartStop slc
-> Bool
-> [(tr, Leftmost s f h)]
forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v
-> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
evalUnfreeze Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sl Maybe tr'
tl (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sm) Bool
False)
 where
  getAction :: (tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction (tr
thawed, Leftmost s f h
op) = case Leftmost s f h
op of
    LMDouble LeftmostDouble s f h
dop ->
      ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h)
forall a. a -> Maybe a
Just (ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h))
-> ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h)
forall a b. (a -> b) -> a -> b
$ DoubleParent slc tr
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
forall slc tr s f h.
DoubleParent slc tr
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
ActionDouble (StartStop slc
-> tr -> slc -> tr -> StartStop slc -> DoubleParent slc tr
forall slc tr.
StartStop slc
-> tr -> slc -> tr -> StartStop slc -> DoubleParent slc tr
DoubleParent StartStop slc
sl tr
thawed slc
sm tr
tr StartStop slc
sr) LeftmostDouble s f h
dop
    LMSingle LeftmostSingle s f
_ -> Maybe (ActionDouble slc tr s f h)
forall a. Maybe a
Nothing

collectUnsplitSingle
  :: Eval tr tr' slc slc' h (Leftmost s f h)
  -> StartStop slc
  -> tr
  -> slc
  -> tr
  -> StartStop slc
  -> [ActionSingle slc tr s f]
collectUnsplitSingle :: forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionSingle slc tr s f]
collectUnsplitSingle Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sl tr
tl slc
sm tr
tr StartStop slc
sr =
  ((tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f))
-> [(tr, Leftmost s f h)] -> [ActionSingle slc tr s f]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f)
forall {tr} {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f)
getAction ([(tr, Leftmost s f h)] -> [ActionSingle slc tr s f])
-> [(tr, Leftmost s f h)] -> [ActionSingle slc tr s f]
forall a b. (a -> b) -> a -> b
$ Eval tr tr' slc slc' h (Leftmost s f h)
-> Unsplit tr slc (Leftmost s f h)
forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v -> Unsplit tr slc v
evalUnsplit Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sl tr
tl slc
sm tr
tr StartStop slc
sr SplitType
SingleOfOne
 where
  getAction :: (tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f)
getAction (tr
ttop, Leftmost s f h
op) = case Leftmost s f h
op of
    LMSingle LeftmostSingle s f
sop -> ActionSingle slc tr s f -> Maybe (ActionSingle slc tr s f)
forall a. a -> Maybe a
Just (ActionSingle slc tr s f -> Maybe (ActionSingle slc tr s f))
-> ActionSingle slc tr s f -> Maybe (ActionSingle slc tr s f)
forall a b. (a -> b) -> a -> b
$ SingleParent slc tr
-> LeftmostSingle s f -> ActionSingle slc tr s f
forall slc tr s f.
SingleParent slc tr
-> LeftmostSingle s f -> ActionSingle slc tr s f
ActionSingle (StartStop slc -> tr -> StartStop slc -> SingleParent slc tr
forall slc tr.
StartStop slc -> tr -> StartStop slc -> SingleParent slc tr
SingleParent StartStop slc
sl tr
ttop StartStop slc
sr) LeftmostSingle s f
sop
    LMDouble LeftmostDouble s f h
_ -> Maybe (ActionSingle slc tr s f)
forall a. Maybe a
Nothing

collectUnsplitLeft
  :: Eval tr tr' slc slc' h (Leftmost s f h)
  -> StartStop slc
  -> tr
  -> slc
  -> tr
  -> slc
  -> tr
  -> StartStop slc
  -> [ActionDouble slc tr s f h]
collectUnsplitLeft :: forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnsplitLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm slc
sr tr
tr StartStop slc
send =
  ((tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h))
-> [(tr, Leftmost s f h)] -> [ActionDouble slc tr s f h]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
forall {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction ([(tr, Leftmost s f h)] -> [ActionDouble slc tr s f h])
-> [(tr, Leftmost s f h)] -> [ActionDouble slc tr s f h]
forall a b. (a -> b) -> a -> b
$ Eval tr tr' slc slc' h (Leftmost s f h)
-> Unsplit tr slc (Leftmost s f h)
forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v -> Unsplit tr slc v
evalUnsplit Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sr) SplitType
LeftOfTwo
 where
  getAction :: (tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction (tr
ttop, Leftmost s f h
op) = case Leftmost s f h
op of
    LMSingle LeftmostSingle s f
_ -> Maybe (ActionDouble slc tr s f h)
forall a. Maybe a
Nothing
    LMDouble LeftmostDouble s f h
dop ->
      ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h)
forall a. a -> Maybe a
Just (ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h))
-> ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h)
forall a b. (a -> b) -> a -> b
$
        DoubleParent slc tr
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
forall slc tr s f h.
DoubleParent slc tr
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
ActionDouble
          (StartStop slc
-> tr -> slc -> tr -> StartStop slc -> DoubleParent slc tr
forall slc tr.
StartStop slc
-> tr -> slc -> tr -> StartStop slc -> DoubleParent slc tr
DoubleParent StartStop slc
sstart tr
ttop slc
sr tr
tr StartStop slc
send)
          LeftmostDouble s f h
dop

collectUnsplitRight
  :: Eval tr tr' slc slc' h (Leftmost s f h)
  -> StartStop slc
  -> tr
  -> slc
  -> tr
  -> slc
  -> tr
  -> StartStop slc
  -> Bool
  -> [ActionDouble slc tr s f h]
collectUnsplitRight :: forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> Bool
-> [ActionDouble slc tr s f h]
collectUnsplitRight Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm slc
sr tr
tr StartStop slc
send Bool
afterLeft
  | Bool
afterLeft = []
  | Bool
otherwise =
      ((tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h))
-> [(tr, Leftmost s f h)] -> [ActionDouble slc tr s f h]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
forall {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction ([(tr, Leftmost s f h)] -> [ActionDouble slc tr s f h])
-> [(tr, Leftmost s f h)] -> [ActionDouble slc tr s f h]
forall a b. (a -> b) -> a -> b
$
        Eval tr tr' slc slc' h (Leftmost s f h)
-> Unsplit tr slc (Leftmost s f h)
forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v -> Unsplit tr slc v
evalUnsplit Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sl) tr
tm slc
sr tr
tr StartStop slc
send SplitType
RightOfTwo
 where
  getAction :: (tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction (tr
ttop, Leftmost s f h
op) = case Leftmost s f h
op of
    LMSingle LeftmostSingle s f
_ -> Maybe (ActionDouble slc tr s f h)
forall a. Maybe a
Nothing
    LMDouble LeftmostDouble s f h
dop ->
      ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h)
forall a. a -> Maybe a
Just (ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h))
-> ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h)
forall a b. (a -> b) -> a -> b
$ DoubleParent slc tr
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
forall slc tr s f h.
DoubleParent slc tr
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
ActionDouble (StartStop slc
-> tr -> slc -> tr -> StartStop slc -> DoubleParent slc tr
forall slc tr.
StartStop slc
-> tr -> slc -> tr -> StartStop slc -> DoubleParent slc tr
DoubleParent StartStop slc
sstart tr
tl slc
sl tr
ttop StartStop slc
send) LeftmostDouble s f h
dop

collectUnspreads
  :: Eval tr tr' slc slc' h (Leftmost s f h)
  -> StartStop slc
  -> tr
  -> slc
  -> tr
  -> slc
  -> tr
  -> StartStop slc
  -> [ActionDouble slc tr s f h]
collectUnspreads :: forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnspreads Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm slc
sr tr
tr StartStop slc
send =
  [Maybe (ActionDouble slc tr s f h)] -> [ActionDouble slc tr s f h]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ActionDouble slc tr s f h)]
 -> [ActionDouble slc tr s f h])
-> [Maybe (ActionDouble slc tr s f h)]
-> [ActionDouble slc tr s f h]
forall a b. (a -> b) -> a -> b
$ do
    -- List
    (sTop, us, op) <- Eval tr tr' slc slc' h (Leftmost s f h)
-> UnspreadMiddle tr slc h (Leftmost s f h)
forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v -> UnspreadMiddle tr slc h v
evalUnspreadMiddle Eval tr tr' slc slc' h (Leftmost s f h)
eval (slc
sl, tr
tm, slc
sr)
    lTop <- evalUnspreadLeft eval (tl, sl) sTop us
    rTop <- evalUnspreadRight eval (sr, tr) sTop us
    pure $ getAction lTop sTop rTop op
 where
  getAction :: tr
-> slc -> tr -> Leftmost s f h -> Maybe (ActionDouble slc tr s f h)
getAction tr
lTop slc
sTop tr
rTop Leftmost s f h
op = case Leftmost s f h
op of
    LMSingle LeftmostSingle s f
_ -> Maybe (ActionDouble slc tr s f h)
forall a. Maybe a
Nothing
    LMDouble LeftmostDouble s f h
dop ->
      ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h)
forall a. a -> Maybe a
Just (ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h))
-> ActionDouble slc tr s f h -> Maybe (ActionDouble slc tr s f h)
forall a b. (a -> b) -> a -> b
$
        DoubleParent slc tr
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
forall slc tr s f h.
DoubleParent slc tr
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
ActionDouble
          (StartStop slc
-> tr -> slc -> tr -> StartStop slc -> DoubleParent slc tr
forall slc tr.
StartStop slc
-> tr -> slc -> tr -> StartStop slc -> DoubleParent slc tr
DoubleParent StartStop slc
sstart tr
lTop slc
sTop tr
rTop StartStop slc
send)
          LeftmostDouble s f h
dop

collectDoubles
  :: Eval tr tr' slc slc' h (Leftmost s f h)
  -> StartStop slc
  -> tr
  -> slc
  -> tr
  -> slc
  -> Path tr slc
  -> Bool
  -> [ActionDouble slc tr s f h]
collectDoubles :: forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> Path tr slc
-> Bool
-> [ActionDouble slc tr s f h]
collectDoubles Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm slc
sr Path tr slc
rst Bool
afterLeft = [ActionDouble slc tr s f h]
leftUnsplits [ActionDouble slc tr s f h]
-> [ActionDouble slc tr s f h] -> [ActionDouble slc tr s f h]
forall a. Semigroup a => a -> a -> a
<> [ActionDouble slc tr s f h]
rightUnsplits [ActionDouble slc tr s f h]
-> [ActionDouble slc tr s f h] -> [ActionDouble slc tr s f h]
forall a. Semigroup a => a -> a -> a
<> [ActionDouble slc tr s f h]
unspreads
 where
  (tr
tr, StartStop slc
send) = case Path tr slc
rst of
    PathEnd tr
t -> (tr
t, StartStop slc
forall a. StartStop a
Stop)
    Path tr
t slc
s Path tr slc
_ -> (tr
t, slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
s)
  leftUnsplits :: [ActionDouble slc tr s f h]
leftUnsplits = Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnsplitLeft Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm slc
sr tr
tr StartStop slc
send
  rightUnsplits :: [ActionDouble slc tr s f h]
rightUnsplits = Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> Bool
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> Bool
-> [ActionDouble slc tr s f h]
collectUnsplitRight Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm slc
sr tr
tr StartStop slc
send Bool
afterLeft
  unspreads :: [ActionDouble slc tr s f h]
unspreads = Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
forall tr tr' slc slc' h s f.
Eval tr tr' slc slc' h (Leftmost s f h)
-> StartStop slc
-> tr
-> slc
-> tr
-> slc
-> tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnspreads Eval tr tr' slc slc' h (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm slc
sr tr
tr StartStop slc
send

{- | A policy that picks the next action at random.
 Must be partially applied with a random generator before passing to 'parseGreedy'.
-}
pickRandom :: (StatefulGen g m) => g -> [slc] -> ExceptT String m slc
pickRandom :: forall g (m :: * -> *) slc.
StatefulGen g m =>
g -> [slc] -> ExceptT String m slc
pickRandom g
_ [] = String -> ExceptT String m slc
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"No candidates for pickRandom!"
pickRandom g
gen [slc]
xs = do
  i <- m Int -> ExceptT String m Int
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Int -> ExceptT String m Int) -> m Int -> ExceptT String m Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> g -> m Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (Int
0, [slc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [slc]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) g
gen
  pure $ xs !! i

-- * Applying actions

-- | Apply an action to a parsing state.
applyAction
  :: forall m tr tr' slc slc' s f h
   . GreedyState tr tr' slc (Leftmost s f h)
  -- ^ the current parsing state
  -> Action slc tr s f h
  -- ^ the action to be applied
  -> Either String (Either (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
  -- ^ either the next state or an error message
applyAction :: forall {k} {k} (m :: k) tr tr' slc (slc' :: k) s f h.
GreedyState tr tr' slc (Leftmost s f h)
-> Action slc tr s f h
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
applyAction GreedyState tr tr' slc (Leftmost s f h)
state Action slc tr s f h
action =
  case GreedyState tr tr' slc (Leftmost s f h)
state of
    -- case 1: everything frozen
    GSFrozen Path (Maybe tr') slc
frozen ->
      case Action slc tr s f h
action of
        Left (ActionSingle (SingleParent StartStop slc
_ tr
top StartStop slc
_) op :: LeftmostSingle s f
op@(LMSingleFreeze f
_)) ->
          case Path (Maybe tr') slc
frozen of
            PathEnd Maybe tr'
_ -> tr
-> [Leftmost s f h]
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {f :: * -> *} {a} {b} {a}.
Applicative f =>
a -> b -> f (Either a (a, b))
finish tr
top [LeftmostSingle s f -> Leftmost s f h
forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op]
            Path Maybe tr'
_ slc
slc Path (Maybe tr') slc
rst -> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen Path (Maybe tr') slc
rst slc
slc (tr -> Path tr slc
forall around between. around -> Path around between
PathEnd tr
top) [LeftmostSingle s f -> Leftmost s f h
forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op]
        Action slc tr s f h
_ -> String
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. a -> Either a b
Left String
"cannot apply this operation to frozen state"
    -- case 2: everything open
    GSOpen Path tr slc
open [Leftmost s f h]
ops -> case Path tr slc
open of
      PathEnd tr
tr -> tr
-> [Leftmost s f h]
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {f :: * -> *} {a} {b} {a}.
Applicative f =>
a -> b -> f (Either a (a, b))
finish tr
tr [Leftmost s f h]
ops
      Path tr
tl slc
slice (PathEnd tr
tr) ->
        case Action slc tr s f h
action of
          Left (ActionSingle (SingleParent StartStop slc
_ tr
top StartStop slc
_) op :: LeftmostSingle s f
op@(LMSingleSplit s
_)) ->
            tr
-> [Leftmost s f h]
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {f :: * -> *} {a} {b} {a}.
Applicative f =>
a -> b -> f (Either a (a, b))
finish tr
top (LeftmostSingle s f -> Leftmost s f h
forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
          Action slc tr s f h
_ -> String
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. a -> Either a b
Left String
"cannot apply this operation to 2 open transitions"
      Path tr
tl slc
sl (Path tr
tm slc
sm Path tr slc
rst) ->
        case Action slc tr s f h
action of
          Right (ActionDouble DoubleParent slc tr
_ (LMDoubleFreezeLeft f
_)) ->
            String
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. a -> Either a b
Left String
"cannot apply unfreeze in open state"
          Right (ActionDouble (DoubleParent StartStop slc
_ tr
topl slc
tops tr
topr StartStop slc
_) LeftmostDouble s f h
op) ->
            GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path tr slc
-> [Leftmost s f h] -> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path tr slc -> [op] -> GreedyState tr tr' slc op
GSOpen (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
topl slc
tops (Path tr slc -> tr -> Path tr slc
forall a b. Path a b -> a -> Path a b
pathSetHead Path tr slc
rst tr
topr)) (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
    -- case 3: some open some closed
    GSSemiOpen Path (Maybe tr') slc
frozen slc
mid Path tr slc
open [Leftmost s f h]
ops -> case Action slc tr s f h
action of
      -- single op: unfreeze or unsplit
      Left (ActionSingle (SingleParent StartStop slc
_ tr
top StartStop slc
_) LeftmostSingle s f
op) -> case LeftmostSingle s f
op of
        -- unfreeze single
        LMSingleFreeze f
_ -> case Path (Maybe tr') slc
frozen of
          PathEnd Maybe tr'
_ -> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path tr slc
-> [Leftmost s f h] -> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path tr slc -> [op] -> GreedyState tr tr' slc op
GSOpen (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
top slc
mid Path tr slc
open) (LeftmostSingle s f -> Leftmost s f h
forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
          Path Maybe tr'
_ slc
frs Path (Maybe tr') slc
frrest ->
            GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen Path (Maybe tr') slc
frrest slc
frs (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
top slc
mid Path tr slc
open) (LeftmostSingle s f -> Leftmost s f h
forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
        -- unsplit single
        LMSingleSplit s
_ -> case Path tr slc
open of
          PathEnd tr
_ -> String
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. a -> Either a b
Left String
"cannot apply unsplit to single open transition"
          Path tr
topenl slc
sopen Path tr slc
rstopen ->
            GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen Path (Maybe tr') slc
frozen slc
mid (Path tr slc -> tr -> Path tr slc
forall a b. Path a b -> a -> Path a b
pathSetHead Path tr slc
rstopen tr
top) (LeftmostSingle s f -> Leftmost s f h
forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
      -- double op:
      Right (ActionDouble (DoubleParent StartStop slc
_ tr
topl slc
tops tr
topr StartStop slc
_) LeftmostDouble s f h
op) -> case LeftmostDouble s f h
op of
        -- unfreeze left
        LMDoubleFreezeLeft f
_ -> case Path (Maybe tr') slc
frozen of
          PathEnd Maybe tr'
_ -> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path tr slc
-> [Leftmost s f h] -> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path tr slc -> [op] -> GreedyState tr tr' slc op
GSOpen (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
topl slc
mid Path tr slc
open) (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
          Path Maybe tr'
_ slc
mid' Path (Maybe tr') slc
frozen' ->
            GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen Path (Maybe tr') slc
frozen' slc
mid' (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
topl slc
mid Path tr slc
open) (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
        -- unsplit left
        LMDoubleSplitLeft s
_ -> case Path tr slc
open of
          PathEnd tr
_ -> String
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. a -> Either a b
Left String
"cannot apply unsplit to single open transition"
          Path tr
_ slc
sopen Path tr slc
rst ->
            GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen Path (Maybe tr') slc
frozen slc
mid (Path tr slc -> tr -> Path tr slc
forall a b. Path a b -> a -> Path a b
pathSetHead Path tr slc
rst tr
topl) (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
        -- unsplit right or unspread
        LeftmostDouble s f h
_ -> case Path tr slc
open of
          Path tr
_tl slc
_sl (Path tr
_tm slc
_sr Path tr slc
rst) ->
            GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall {a} {b}. a -> Either String (Either a b)
continue (GreedyState tr tr' slc (Leftmost s f h)
 -> Either
      String
      (Either
         (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h])))
-> GreedyState tr tr' slc (Leftmost s f h)
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. (a -> b) -> a -> b
$ Path (Maybe tr') slc
-> slc
-> Path tr slc
-> [Leftmost s f h]
-> GreedyState tr tr' slc (Leftmost s f h)
forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path tr slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen Path (Maybe tr') slc
frozen slc
mid (tr -> slc -> Path tr slc -> Path tr slc
forall around between.
around -> between -> Path around between -> Path around between
Path tr
topl slc
tops (Path tr slc -> tr -> Path tr slc
forall a b. Path a b -> a -> Path a b
pathSetHead Path tr slc
rst tr
topr)) (LeftmostDouble s f h -> Leftmost s f h
forall s f h. LeftmostDouble s f h -> Leftmost s f h
LMDouble LeftmostDouble s f h
op Leftmost s f h -> [Leftmost s f h] -> [Leftmost s f h]
forall a. a -> [a] -> [a]
: [Leftmost s f h]
ops)
          Path tr slc
_ -> String
-> Either
     String
     (Either
        (GreedyState tr tr' slc (Leftmost s f h)) (tr, [Leftmost s f h]))
forall a b. a -> Either a b
Left String
"cannot apply unsplit right or unspread to less than 3 open transitions"
 where
  continue :: a -> Either String (Either a b)
continue = Either a b -> Either String (Either a b)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> Either String (Either a b))
-> (a -> Either a b) -> a -> Either String (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left
  finish :: a -> b -> f (Either a (a, b))
finish a
top b
ops = Either a (a, b) -> f (Either a (a, b))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (a, b) -> f (Either a (a, b)))
-> Either a (a, b) -> f (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ (a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
top, b
ops)

-- * Entry Points

-- | Parse a piece randomly using a fresh random number generator.
parseRandom
  :: (Show tr', Show slc, Show tr, Show s, Show f, Show h)
  => Eval tr tr' slc slc' h (Leftmost s f h)
  -- ^ the grammar's evaluator
  -> Path slc' tr'
  -- ^ the input piece
  -> ExceptT String IO (Analysis s f h tr slc)
  -- ^ a random reduction of the piece (or an error message)
parseRandom :: forall tr' slc tr s f h slc'.
(Show tr', Show slc, Show tr, Show s, Show f, Show h) =>
Eval tr tr' slc slc' h (Leftmost s f h)
-> Path slc' tr' -> ExceptT String IO (Analysis s f h tr slc)
parseRandom Eval tr tr' slc slc' h (Leftmost s f h)
eval Path slc' tr'
input = do
  gen <- IO StdGen -> ExceptT String IO StdGen
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
initStdGen
  mgen <- lift $ newIOGenM gen
  parseGreedy eval (pickRandom mgen) input

-- | Parse a piece randomly using an existing random number generator.
parseRandom'
  :: (Show tr', Show slc, Show tr, Show s, Show f, Show h, StatefulGen g IO)
  => g
  -- ^ a random number generator
  -> Eval tr tr' slc slc' h (Leftmost s f h)
  -- ^ the grammar's evaluator
  -> Path slc' tr'
  -- ^ the input piece
  -> ExceptT String IO (Analysis s f h tr slc)
  -- ^ a random reduction of the piece (or an error message)
parseRandom' :: forall tr' slc tr s f h g slc'.
(Show tr', Show slc, Show tr, Show s, Show f, Show h,
 StatefulGen g IO) =>
g
-> Eval tr tr' slc slc' h (Leftmost s f h)
-> Path slc' tr'
-> ExceptT String IO (Analysis s f h tr slc)
parseRandom' g
mgen Eval tr tr' slc slc' h (Leftmost s f h)
eval Path slc' tr'
input = do
  Eval tr tr' slc slc' h (Leftmost s f h)
-> ([Action slc tr s f h]
    -> ExceptT String IO (Action slc tr s f h))
-> Path slc' tr'
-> ExceptT String IO (Analysis s f h tr slc)
forall (m :: * -> *) tr tr' slc slc' s f h.
(Monad m, MonadIO m, Show tr', Show slc, Show tr, Show s, Show f,
 Show h) =>
Eval tr tr' slc slc' h (Leftmost s f h)
-> ([Action slc tr s f h]
    -> ExceptT String m (Action slc tr s f h))
-> Path slc' tr'
-> ExceptT String m (Analysis s f h tr slc)
parseGreedy Eval tr tr' slc slc' h (Leftmost s f h)
eval (g
-> [Action slc tr s f h] -> ExceptT String IO (Action slc tr s f h)
forall g (m :: * -> *) slc.
StatefulGen g m =>
g -> [slc] -> ExceptT String m slc
pickRandom g
mgen) Path slc' tr'
input