{-# 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.
-}
data Trans tr = Trans
  { forall tr. Trans tr -> tr
_tContent :: !tr
  -- ^ content of the transition
  , forall tr. Trans tr -> Bool
_t2nd :: !Bool
  -- ^ flag that indicates (transitive) right parents of spreads
  }
  deriving (Int -> Trans tr -> ShowS
forall tr. Show tr => Int -> Trans tr -> ShowS
forall tr. Show tr => [Trans tr] -> ShowS
forall tr. Show tr => Trans tr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Trans tr] -> ShowS
$cshowList :: forall tr. Show tr => [Trans tr] -> ShowS
show :: Trans tr -> String
$cshow :: forall tr. Show tr => Trans tr -> String
showsPrec :: Int -> Trans tr -> ShowS
$cshowsPrec :: forall tr. Show tr => Int -> Trans tr -> ShowS
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.
-}
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 (Trans tr) slc
_gsOpen :: !(Path (Trans 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 (Trans tr) slc) ![op]

instance (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) = forall slc tr'. Show slc => Path tr' slc -> String
showFrozen Path (Maybe tr') slc
frozen forall a. Semigroup a => a -> a -> a
<> String
"⋉"
  show (GSOpen Path (Trans tr) slc
open [o]
_ops) = String
"⋊" forall a. Semigroup a => a -> a -> a
<> forall slc tr'. Show slc => Path tr' slc -> String
showOpen Path (Trans tr) slc
open -- <> " " <> show ops
  show (GSSemiOpen Path (Maybe tr') slc
frozen slc
mid Path (Trans tr) slc
open [o]
_ops) =
    forall slc tr'. Show slc => Path tr' slc -> String
showFrozen Path (Maybe tr') slc
frozen forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show slc
mid forall a. Semigroup a => a -> a -> a
<> forall slc tr'. Show slc => Path tr' slc -> String
showOpen Path (Trans tr) slc
open -- <> " " <> show ops

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

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

-- * Parsing Actions

{- | 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
      (StartStop slc, Trans tr, StartStop slc)
      -- ^ parent transition (and adjacent slices)
      (LeftmostSingle s f)
      -- ^ single-transition operation
  deriving (Int -> ActionSingle slc tr s f -> ShowS
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
showList :: [ActionSingle slc tr s f] -> ShowS
$cshowList :: forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
[ActionSingle slc tr s f] -> ShowS
show :: ActionSingle slc tr s f -> String
$cshow :: forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
ActionSingle slc tr s f -> String
showsPrec :: Int -> ActionSingle slc tr s f -> ShowS
$cshowsPrec :: forall slc tr s f.
(Show slc, Show tr, Show s, Show f) =>
Int -> ActionSingle slc tr s f -> 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
      ( StartStop slc
      , Trans tr
      , slc
      , Trans tr
      , StartStop slc
      )
      -- ^ parent transitions and slice
      (LeftmostDouble s f h)
      -- ^ double-transition operation
  deriving (Int -> ActionDouble slc tr s f h -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall slc tr s f h.
(Show slc, Show tr, Show s, Show f, Show h) =>
Int -> ActionDouble slc tr s f h -> ShowS
forall slc tr s f h.
(Show slc, Show tr, Show s, Show f, Show h) =>
[ActionDouble slc tr s f h] -> ShowS
forall slc tr s f h.
(Show slc, Show tr, Show s, Show f, Show h) =>
ActionDouble slc tr s f h -> String
showList :: [ActionDouble slc tr s f h] -> ShowS
$cshowList :: forall slc tr s f h.
(Show slc, Show tr, Show s, Show f, Show h) =>
[ActionDouble slc tr s f h] -> ShowS
show :: ActionDouble slc tr s f h -> String
$cshow :: forall slc tr s f h.
(Show slc, Show tr, Show s, Show f, Show h) =>
ActionDouble slc tr s f h -> String
showsPrec :: Int -> ActionDouble slc tr s f h -> ShowS
$cshowsPrec :: forall slc tr s f h.
(Show slc, Show tr, Show s, Show f, Show h) =>
Int -> 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)

-- * 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' (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' (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' (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
  (tr
top, [Leftmost s f h]
deriv) <- GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT String m (tr, [Leftmost s f h])
parse forall {tr} {op}. GreedyState tr tr' slc op
initState
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s f h tr slc.
[Leftmost s f h] -> Path tr slc -> Analysis s f h tr slc
Analysis [Leftmost s f h]
deriv forall a b. (a -> b) -> a -> b
$ forall around between. around -> Path around between
PathEnd tr
top
 where
  initState :: GreedyState tr tr' slc op
initState = forall tr tr' slc op.
Path (Maybe tr') slc -> GreedyState tr tr' slc op
GSFrozen forall a b. (a -> b) -> a -> b
$ Maybe tr' -> Path slc' tr' -> Path (Maybe tr') slc
wrapPath forall a. Maybe a
Nothing (forall a b. Path a b -> Path a b
reversePath Path slc' tr'
input)
  -- 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) = forall around between.
around -> between -> Path around between -> Path around between
Path Maybe tr'
eleft (forall tr tr' slc slc' v. Eval tr tr' slc slc' v -> slc' -> slc
evalSlice Eval tr tr' slc slc' (Leftmost s f h)
eval slc'
a) forall a b. (a -> b) -> a -> b
$ forall around between. around -> Path around between
PathEnd forall a. Maybe a
Nothing
  wrapPath Maybe tr'
eleft (Path slc'
a tr'
e Path slc' tr'
rst) =
    forall around between.
around -> between -> Path around between -> Path around between
Path Maybe tr'
eleft (forall tr tr' slc slc' v. Eval tr tr' slc slc' v -> slc' -> slc
evalSlice Eval tr tr' slc slc' (Leftmost s f h)
eval slc'
a) forall a b. (a -> b) -> a -> b
$ Maybe tr' -> Path slc' tr' -> Path (Maybe tr') slc
wrapPath (forall a. a -> Maybe a
Just tr'
e) Path slc' tr'
rst

  -- parsing loop
  parse
    :: GreedyState tr tr' slc (Leftmost s f h)
    -> ExceptT String m (tr, [Leftmost s f h])

  -- case 1: everything frozen
  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
    -- liftIO $ putStrLn "" >> print state
    case GreedyState tr tr' slc (Leftmost s f h)
state of
      GSFrozen Path (Maybe tr') slc
frozen -> case Path (Maybe tr') slc
frozen of
        -- only one transition: unfreeze and terminate
        PathEnd Maybe tr'
trans -> do
          (Trans tr
thawed Bool
_, LeftmostSingle s f
op) <-
            [ActionSingle slc tr s f]
-> ExceptT String m (Trans tr, LeftmostSingle s f)
pickSingle forall a b. (a -> b) -> a -> b
$
              StartStop slc
-> Maybe tr' -> StartStop slc -> [ActionSingle slc tr s f]
collectThawSingle forall a. StartStop a
Start Maybe tr'
trans forall a. StartStop a
Stop
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (tr
thawed, [forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op])
        -- several transition: unfreeze last and continue
        Path Maybe tr'
t slc
slice Path (Maybe tr') slc
rst -> do
          (Trans tr
thawed, LeftmostSingle s f
op) <- [ActionSingle slc tr s f]
-> ExceptT String m (Trans tr, LeftmostSingle s f)
pickSingle forall a b. (a -> b) -> a -> b
$ StartStop slc
-> Maybe tr' -> StartStop slc -> [ActionSingle slc tr s f]
collectThawSingle (forall a. a -> StartStop a
Inner slc
slice) Maybe tr'
t forall a. StartStop a
Stop
          GreedyState tr tr' slc (Leftmost s f h)
-> ExceptT String m (tr, [Leftmost s f h])
parse forall a b. (a -> b) -> a -> b
$ forall tr tr' slc op.
Path (Maybe tr') slc
-> slc -> Path (Trans tr) slc -> [op] -> GreedyState tr tr' slc op
GSSemiOpen Path (Maybe tr') slc
rst slc
slice (forall around between. around -> Path around between
PathEnd Trans tr
thawed) [forall s f h. LeftmostSingle s f -> Leftmost s f h
LMSingle LeftmostSingle s f
op]

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

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

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

  collectThawSingle
    :: (StartStop slc -> Maybe tr' -> StartStop slc -> [ActionSingle slc tr s f])
  collectThawSingle :: StartStop slc
-> Maybe tr' -> StartStop slc -> [ActionSingle slc tr s f]
collectThawSingle StartStop slc
sl Maybe tr'
t StartStop slc
sr =
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      forall {tr} {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f)
getAction
      (forall tr tr' slc slc' v.
Eval tr tr' slc slc' v
-> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
evalUnfreeze Eval tr tr' slc slc' (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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall slc tr s f.
(StartStop slc, Trans tr, StartStop slc)
-> LeftmostSingle s f -> ActionSingle slc tr s f
ActionSingle (StartStop slc
sl, forall tr. tr -> Bool -> Trans tr
Trans tr
t' Bool
False, StartStop slc
sr) LeftmostSingle s f
sop
      LMDouble LeftmostDouble s f h
_ -> forall a. Maybe a
Nothing

  collectThawLeft
    :: ( StartStop slc
         -> Maybe tr'
         -> slc
         -> Trans tr
         -> StartStop slc
         -> [ActionDouble slc tr s f h]
       )
  collectThawLeft :: StartStop slc
-> Maybe tr'
-> slc
-> Trans tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectThawLeft StartStop slc
sl Maybe tr'
tl slc
sm (Trans tr
tr Bool
_) StartStop slc
sr =
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      forall {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction
      (forall tr tr' slc slc' v.
Eval tr tr' slc slc' v
-> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
evalUnfreeze Eval tr tr' slc slc' (Leftmost s f h)
eval StartStop slc
sl Maybe tr'
tl (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 ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall slc tr s f h.
(StartStop slc, Trans tr, slc, Trans tr, StartStop slc)
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
ActionDouble (StartStop slc
sl, forall tr. tr -> Bool -> Trans tr
Trans tr
thawed Bool
False, slc
sm, forall tr. tr -> Bool -> Trans tr
Trans tr
tr Bool
False, StartStop slc
sr) LeftmostDouble s f h
dop
      LMSingle LeftmostSingle s f
_ -> forall a. Maybe a
Nothing

  collectUnsplitSingle
    :: ( StartStop slc
         -> Trans tr
         -> slc
         -> Trans tr
         -> StartStop slc
         -> [ActionSingle slc tr s f]
       )
  collectUnsplitSingle :: StartStop slc
-> Trans tr
-> slc
-> Trans tr
-> StartStop slc
-> [ActionSingle slc tr s f]
collectUnsplitSingle StartStop slc
sl (Trans tr
tl Bool
_) slc
sm (Trans tr
tr Bool
_) StartStop slc
sr =
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {tr} {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionSingle slc tr s f)
getAction forall a b. (a -> b) -> a -> b
$ forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> Unsplit tr slc v
evalUnsplit Eval tr tr' slc slc' (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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall slc tr s f.
(StartStop slc, Trans tr, StartStop slc)
-> LeftmostSingle s f -> ActionSingle slc tr s f
ActionSingle (StartStop slc
sl, forall tr. tr -> Bool -> Trans tr
Trans tr
ttop Bool
False, StartStop slc
sr) LeftmostSingle s f
sop
      LMDouble LeftmostDouble s f h
_ -> forall a. Maybe a
Nothing

  collectUnsplitLeft
    :: ( StartStop slc
         -> Trans tr
         -> slc
         -> Trans tr
         -> slc
         -> Trans tr
         -> StartStop slc
         -> [ActionDouble slc tr s f h]
       )
  collectUnsplitLeft :: StartStop slc
-> Trans tr
-> slc
-> Trans tr
-> slc
-> Trans tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnsplitLeft StartStop slc
sstart (Trans tr
tl Bool
_) slc
sl (Trans tr
tm Bool
_) slc
sr (Trans tr
tr Bool
_) StartStop slc
send =
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction forall a b. (a -> b) -> a -> b
$ forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> Unsplit tr slc v
evalUnsplit Eval tr tr' slc slc' (Leftmost s f h)
eval StartStop slc
sstart tr
tl slc
sl tr
tm (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
_ -> forall a. Maybe a
Nothing
      LMDouble LeftmostDouble s f h
dop ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          forall slc tr s f h.
(StartStop slc, Trans tr, slc, Trans tr, StartStop slc)
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
ActionDouble
            (StartStop slc
sstart, forall tr. tr -> Bool -> Trans tr
Trans tr
ttop Bool
False, slc
sr, forall tr. tr -> Bool -> Trans tr
Trans tr
tr Bool
False, StartStop slc
send)
            LeftmostDouble s f h
dop

  collectUnsplitRight
    :: ( StartStop slc
         -> Trans tr
         -> slc
         -> Trans tr
         -> slc
         -> Trans tr
         -> StartStop slc
         -> [ActionDouble slc tr s f h]
       )
  collectUnsplitRight :: StartStop slc
-> Trans tr
-> slc
-> Trans tr
-> slc
-> Trans tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnsplitRight StartStop slc
sstart Trans tr
tl slc
sl (Trans tr
tm Bool
m2nd) slc
sr (Trans tr
tr Bool
_) StartStop slc
send
    | Bool -> Bool
not Bool
m2nd = []
    | Bool
otherwise =
        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {s} {f} {h}.
(tr, Leftmost s f h) -> Maybe (ActionDouble slc tr s f h)
getAction forall a b. (a -> b) -> a -> b
$
          forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> Unsplit tr slc v
evalUnsplit Eval tr tr' slc slc' (Leftmost s f h)
eval (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
_ -> forall a. Maybe a
Nothing
      LMDouble LeftmostDouble s f h
dop ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall slc tr s f h.
(StartStop slc, Trans tr, slc, Trans tr, StartStop slc)
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
ActionDouble (StartStop slc
sstart, Trans tr
tl, slc
sl, forall tr. tr -> Bool -> Trans tr
Trans tr
ttop Bool
True, StartStop slc
send) LeftmostDouble s f h
dop

  collectUnspreads
    :: ( StartStop slc
         -> Trans tr
         -> slc
         -> Trans tr
         -> slc
         -> Trans tr
         -> StartStop slc
         -> [ActionDouble slc tr s f h]
       )
  collectUnspreads :: StartStop slc
-> Trans tr
-> slc
-> Trans tr
-> slc
-> Trans tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnspreads StartStop slc
sstart (Trans tr
tl Bool
_) slc
sl (Trans tr
tm Bool
_) slc
sr (Trans tr
tr Bool
_) StartStop slc
send =
    forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ do
      -- List
      (slc
sTop, Leftmost s f h
op) <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> UnspreadMiddle tr slc v
evalUnspreadMiddle Eval tr tr' slc slc' (Leftmost s f h)
eval (slc
sl, tr
tm, slc
sr)
      tr
lTop <- forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> UnspreadLeft tr slc
evalUnspreadLeft Eval tr tr' slc slc' (Leftmost s f h)
eval (tr
tl, slc
sl) slc
sTop
      tr
rTop <- forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> UnspreadRight tr slc
evalUnspreadRight Eval tr tr' slc slc' (Leftmost s f h)
eval (slc
sr, tr
tr) slc
sTop
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {tr} {s} {f} {h}.
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
   where
    -- pure $ getAction $ evalUnsplit eval (Inner sl) tm sr tr send RightOfTwo

    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
_ -> forall a. Maybe a
Nothing
      LMDouble LeftmostDouble s f h
dop ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          forall slc tr s f h.
(StartStop slc, Trans tr, slc, Trans tr, StartStop slc)
-> LeftmostDouble s f h -> ActionDouble slc tr s f h
ActionDouble
            (StartStop slc
sstart, forall tr. tr -> Bool -> Trans tr
Trans tr
lTop Bool
False, slc
sTop, forall tr. tr -> Bool -> Trans tr
Trans tr
rTop Bool
True, StartStop slc
send)
            LeftmostDouble s f h
dop

  collectDoubles :: StartStop slc
-> Trans tr
-> slc
-> Trans tr
-> slc
-> Path (Trans tr) slc
-> [ActionDouble slc tr s f h]
collectDoubles StartStop slc
sstart Trans tr
tl slc
sl Trans tr
tm slc
sr Path (Trans tr) slc
rst = [ActionDouble slc tr s f h]
leftUnsplits forall a. Semigroup a => a -> a -> a
<> [ActionDouble slc tr s f h]
rightUnsplits forall a. Semigroup a => a -> a -> a
<> [ActionDouble slc tr s f h]
unspreads
   where
    (Trans tr
tr, StartStop slc
send) = case Path (Trans tr) slc
rst of
      PathEnd Trans tr
t -> (Trans tr
t, forall a. StartStop a
Stop)
      Path Trans tr
t slc
s Path (Trans tr) slc
_ -> (Trans tr
t, forall a. a -> StartStop a
Inner slc
s)
    leftUnsplits :: [ActionDouble slc tr s f h]
leftUnsplits = StartStop slc
-> Trans tr
-> slc
-> Trans tr
-> slc
-> Trans tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnsplitLeft StartStop slc
sstart Trans tr
tl slc
sl Trans tr
tm slc
sr Trans tr
tr StartStop slc
send
    rightUnsplits :: [ActionDouble slc tr s f h]
rightUnsplits = StartStop slc
-> Trans tr
-> slc
-> Trans tr
-> slc
-> Trans tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnsplitRight StartStop slc
sstart Trans tr
tl slc
sl Trans tr
tm slc
sr Trans tr
tr StartStop slc
send
    unspreads :: [ActionDouble slc tr s f h]
unspreads = StartStop slc
-> Trans tr
-> slc
-> Trans tr
-> slc
-> Trans tr
-> StartStop slc
-> [ActionDouble slc tr s f h]
collectUnspreads StartStop slc
sstart Trans tr
tl slc
sl Trans tr
tm slc
sr Trans 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
_ [] = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"No candidates for pickRandom!"
pickRandom g
gen [slc]
xs = do
  Int
i <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [slc]
xs forall a. Num a => a -> a -> a
- Int
1) g
gen
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [slc]
xs forall a. [a] -> Int -> a
!! Int
i

-- * 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' (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' (Leftmost s f h)
-> Path slc' tr' -> ExceptT String IO (Analysis s f h tr slc)
parseRandom Eval tr tr' slc slc' (Leftmost s f h)
eval Path slc' tr'
input = do
  StdGen
gen <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadIO m => m StdGen
initStdGen
  IOGenM StdGen
mgen <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
newIOGenM StdGen
gen
  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' (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' (Leftmost s f h)
eval (forall g (m :: * -> *) slc.
StatefulGen g m =>
g -> [slc] -> ExceptT String m slc
pickRandom IOGenM StdGen
mgen) Path slc' tr'
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' (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' (Leftmost s f h)
-> Path slc' tr'
-> ExceptT String IO (Analysis s f h tr slc)
parseRandom' g
mgen Eval tr tr' slc slc' (Leftmost s f h)
eval Path slc' tr'
input = do
  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' (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' (Leftmost s f h)
eval (forall g (m :: * -> *) slc.
StatefulGen g m =>
g -> [slc] -> ExceptT String m slc
pickRandom g
mgen) Path slc' tr'
input