{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

-- | Common types and functionality that are used throughout the model.
module Common
  ( -- * Paths #paths#

    -- | Paths encode sequences of alternating objects (such as nodes and edges).
    -- They are often used to encode sequences of slices and transitions.
    -- Note that dependending on context,
    -- both slice-transition-slice and transition-slice-transition orders are used.
    Path (..)
  , pathLen
  , pathHead
  , pathSetHead
  , mapArounds
  , mapAroundsWithIndex
  , mapBetweens
  , reversePath
  , pathArounds
  , pathBetweens

    -- * StartStop #startstop#

    -- | 'StartStop' is a wrapper that augments a type with special values for beginning and end.
  , StartStop (..)
  , onlyInner
  , getInner
  , getInnerE
  , isInner
  , isStart
  , isStop
  , distStartStop

    -- * Evaluators #evals#

    -- | Evaluators ('Eval') are the main parsing interface for a grammar.
    -- They bundle a number of functions that compute local "completions"
    -- (i.e., parent objects and generative operations)
    -- from child objects.
    -- Parsers use these evaluators to generically parse an input sequence
    -- since all the grammar-specific parsing code is provided by the evaluator.
    --
    -- Evaluators can be transformed and combined using 'mapEvalScore' and 'productEval' respectively.
  , SplitType (..)
  , UnspreadMiddle
  , UnspreadLeft
  , UnspreadRight
  , Unsplit
  , Eval (..)
  , IsLast
  , mapEvalScore
  , productEval

    -- * Special Restricting Evaluators #special-evals#

    -- | Some special evaluators that can be combined with grammar-specific evaluators
    -- to restrict the possibile derivations.
  , RightBranchSpread (..)
  , evalRightBranchSpread
  , rightBranchSpread
  , Merged (..)
  , evalSplitBeforeSpread
  , splitFirst

    -- * Leftmost Derivations #leftmost#

    -- | Derivations can be represented as lists of operations in leftmost-first order.
    -- In this order, each operation (split, spread, or freeze)
    -- is applied to the leftmost non-terminal transition(s).
    -- $leftmostdoc
  , Leftmost
    ( LMDouble
    , LMFreezeLeft
    , LMFreezeOnly
    , LMSingle
    , LMSplitLeft
    , LMSplitOnly
    , LMSplitRight
    , LMSpread
    )
  , LeftmostSingle (..)
  , LeftmostDouble (..)
  , Analysis (..)
  , debugAnalysis
  , mkLeftmostEval

    -- * Monadic Interface for Constructing Derivations #monadicDeriv#
    -- $monadicdoc
  , PartialDerivation (..)
  , DerivationInfo
  , IndexedWriter
  , itell
  , DerivationAction (..)
  , buildDerivation
  , buildPartialDerivation
  , split
  , freeze
  , splitRight
  , spread

    -- * Derivations Semiring #derivSemiring#

    -- | A generic semiring that represents a collection of derivations as prefix trees.
  , Derivations (..)
  , mapDerivations
  , flattenDerivations
  , flattenDerivationsRed
  , firstDerivation

    -- * Utilities #utils#
  , traceLevel
  , traceIf
  , showTex
  , showTexT
  ) where

import Control.DeepSeq (NFData)
import Control.Monad (when)
import Control.Monad.Except
  ( ExceptT
  , runExceptT
  )
import Control.Monad.Indexed qualified as MI
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Except (except)
import Control.Monad.Writer.Strict qualified as MW
import Data.Aeson
  ( FromJSON (..)
  , ToJSON (..)
  , (.:)
  )
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (unexpected)
import Data.Aeson.Types qualified as Aeson
import Data.Bifunctor
  ( Bifunctor
  , bimap
  , second
  )
import Data.Hashable (Hashable)
import Data.Kind (Type)
import Data.Semigroup (stimesMonoid)
import Data.Semiring qualified as R
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Typeable (Proxy (Proxy))
import Debug.Trace (trace)
import GHC.Generics (Generic)
import GHC.TypeNats
  ( KnownNat
  , Nat
  , natVal
  , type (+)
  , type (-)
  , type (<=)
  )
import GHC.Unicode (toLower)
import Musicology.Pitch (Notation (..))
import Text.ParserCombinators.ReadP qualified as ReadP

-- Path: sequences of alternating objects
-- ======================================

{- | A Path is a datastructure that represents a sequence of alternating objects,
 /arounds/ and /betweens/,
 starting and ending with the same type.
 An example would be a path in a graph,
 starting and ending with a node with edges in-between.
-}
data Path around between
  = Path !around !between !(Path around between)
  | PathEnd !around
  deriving (Path around between -> Path around between -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall around between.
(Eq around, Eq between) =>
Path around between -> Path around between -> Bool
/= :: Path around between -> Path around between -> Bool
$c/= :: forall around between.
(Eq around, Eq between) =>
Path around between -> Path around between -> Bool
== :: Path around between -> Path around between -> Bool
$c== :: forall around between.
(Eq around, Eq between) =>
Path around between -> Path around between -> Bool
Eq, Path around between -> Path around between -> Bool
Path around between -> Path around between -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {around} {between}.
(Ord around, Ord between) =>
Eq (Path around between)
forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Bool
forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Ordering
forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Path around between
min :: Path around between -> Path around between -> Path around between
$cmin :: forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Path around between
max :: Path around between -> Path around between -> Path around between
$cmax :: forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Path around between
>= :: Path around between -> Path around between -> Bool
$c>= :: forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Bool
> :: Path around between -> Path around between -> Bool
$c> :: forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Bool
<= :: Path around between -> Path around between -> Bool
$c<= :: forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Bool
< :: Path around between -> Path around between -> Bool
$c< :: forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Bool
compare :: Path around between -> Path around between -> Ordering
$ccompare :: forall around between.
(Ord around, Ord between) =>
Path around between -> Path around between -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall around between x.
Rep (Path around between) x -> Path around between
forall around between x.
Path around between -> Rep (Path around between) x
$cto :: forall around between x.
Rep (Path around between) x -> Path around between
$cfrom :: forall around between x.
Path around between -> Rep (Path around between) x
Generic)

instance Bifunctor Path where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Path a c -> Path b d
bimap a -> b
fa c -> d
_ (PathEnd a
a) = forall around between. around -> Path around between
PathEnd (a -> b
fa a
a)
  bimap a -> b
fa c -> d
fb (Path a
a c
b Path a c
rst) = forall around between.
around -> between -> Path around between -> Path around between
Path (a -> b
fa a
a) (c -> d
fb c
b) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
fa c -> d
fb Path a c
rst

instance (Show a, Show b) => Show (Path a b) where
  show :: Path a b -> String
show (Path a
a b
b Path a b
rst) = forall a. Show a => a -> String
show a
a forall a. Semigroup a => a -> a -> a
<> String
"\n+-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show b
b forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Path a b
rst
  show (PathEnd a
a) = forall a. Show a => a -> String
show a
a

-- | Returns the number of /arounds/ in the path.
pathLen :: Path a b -> Int
pathLen :: forall a b. Path a b -> Int
pathLen (Path a
_ b
_ Path a b
rest) = forall a b. Path a b -> Int
pathLen Path a b
rest forall a. Num a => a -> a -> a
+ Int
1
pathLen (PathEnd a
_) = Int
1

-- | Returns the first /around/ in the path.
pathHead :: Path a b -> a
pathHead :: forall a b. Path a b -> a
pathHead (Path a
l b
_ Path a b
_) = a
l
pathHead (PathEnd a
l) = a
l

-- | Replaces the first /around/ in the path.
pathSetHead :: Path a b -> a -> Path a b
pathSetHead :: forall a b. Path a b -> a -> Path a b
pathSetHead (Path a
_ b
b Path a b
rst) a
a' = forall around between.
around -> between -> Path around between -> Path around between
Path a
a' b
b Path a b
rst
pathSetHead (PathEnd a
_) a
a' = forall around between. around -> Path around between
PathEnd a
a'

-- | Maps a function over every /around/ in the path.
mapArounds :: (a -> a') -> Path a b -> Path a' b
mapArounds :: forall a b c. (a -> b) -> Path a c -> Path b c
mapArounds a -> a'
f (Path a
a b
b Path a b
rest) = forall around between.
around -> between -> Path around between -> Path around between
Path (a -> a'
f a
a) b
b forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b) -> Path a c -> Path b c
mapArounds a -> a'
f Path a b
rest
mapArounds a -> a'
f (PathEnd a
a) = forall around between. around -> Path around between
PathEnd (a -> a'
f a
a)

-- | Maps a function over every /around/ in the path together with its index.
mapAroundsWithIndex :: Int -> (Int -> a -> a') -> Path a b -> Path a' b
mapAroundsWithIndex :: forall a a' b. Int -> (Int -> a -> a') -> Path a b -> Path a' b
mapAroundsWithIndex Int
i Int -> a -> a'
f (Path a
a b
b Path a b
rest) =
  forall around between.
around -> between -> Path around between -> Path around between
Path (Int -> a -> a'
f Int
i a
a) b
b (forall a a' b. Int -> (Int -> a -> a') -> Path a b -> Path a' b
mapAroundsWithIndex (Int
i forall a. Num a => a -> a -> a
+ Int
1) Int -> a -> a'
f Path a b
rest)
mapAroundsWithIndex Int
i Int -> a -> a'
f (PathEnd a
a) = forall around between. around -> Path around between
PathEnd (Int -> a -> a'
f Int
i a
a)

-- | Maps a function over every /between/ and its adjacent /arounds/ in the path.
mapBetweens :: (a -> b -> a -> c) -> Path a b -> [c]
mapBetweens :: forall a b c. (a -> b -> a -> c) -> Path a b -> [c]
mapBetweens a -> b -> a -> c
f (Path a
al b
b Path a b
rest) = a -> b -> a -> c
f a
al b
b a
ar forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> a -> c) -> Path a b -> [c]
mapBetweens a -> b -> a -> c
f Path a b
rest
 where
  ar :: a
ar = forall a b. Path a b -> a
pathHead Path a b
rest
mapBetweens a -> b -> a -> c
_ (PathEnd a
_) = []

-- | Reverses the path.
reversePath :: Path a b -> Path a b
reversePath :: forall a b. Path a b -> Path a b
reversePath Path a b
path = case Path a b
path of
  PathEnd a
end -> forall around between. around -> Path around between
PathEnd a
end
  Path a
a b
b Path a b
rest -> forall {t} {around}.
t -> Path around t -> Path around t -> Path around t
go b
b Path a b
rest (forall around between. around -> Path around between
PathEnd a
a)
 where
  go :: t -> Path around t -> Path around t -> Path around t
go t
b (PathEnd around
aEnd) Path around t
acc = forall around between.
around -> between -> Path around between -> Path around between
Path around
aEnd t
b Path around t
acc
  go t
b1 (Path around
a t
b2 Path around t
rest) Path around t
acc = t -> Path around t -> Path around t -> Path around t
go t
b2 Path around t
rest forall a b. (a -> b) -> a -> b
$ forall around between.
around -> between -> Path around between -> Path around between
Path around
a t
b1 Path around t
acc

-- | Returns the list of /arounds/  in the path.
pathArounds :: Path a b -> [a]
pathArounds :: forall a b. Path a b -> [a]
pathArounds (Path a
a b
_ Path a b
rst) = a
a forall a. a -> [a] -> [a]
: forall a b. Path a b -> [a]
pathArounds Path a b
rst
pathArounds (PathEnd a
a) = [a
a]

-- | Returns the list of /betweens/ in the path).
pathBetweens :: Path a b -> [b]
pathBetweens :: forall a b. Path a b -> [b]
pathBetweens (Path a
_ b
b Path a b
rst) = b
b forall a. a -> [a] -> [a]
: forall a b. Path a b -> [b]
pathBetweens Path a b
rst
pathBetweens Path a b
_ = []

-- StartStop
-- =========

{- | A container type that augements the type @a@
 with symbols for beginning ('Start', ⋊) and end ('Stop', ⋉).
 Every other value is wrapped in an @Inner@ constructor.
-}
data StartStop a
  = Start
  | Inner !a
  | Stop
  deriving (StartStop a -> StartStop a -> Bool
StartStop a -> StartStop a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (StartStop a)
forall a. Ord a => StartStop a -> StartStop a -> Bool
forall a. Ord a => StartStop a -> StartStop a -> Ordering
forall a. Ord a => StartStop a -> StartStop a -> StartStop a
min :: StartStop a -> StartStop a -> StartStop a
$cmin :: forall a. Ord a => StartStop a -> StartStop a -> StartStop a
max :: StartStop a -> StartStop a -> StartStop a
$cmax :: forall a. Ord a => StartStop a -> StartStop a -> StartStop a
>= :: StartStop a -> StartStop a -> Bool
$c>= :: forall a. Ord a => StartStop a -> StartStop a -> Bool
> :: StartStop a -> StartStop a -> Bool
$c> :: forall a. Ord a => StartStop a -> StartStop a -> Bool
<= :: StartStop a -> StartStop a -> Bool
$c<= :: forall a. Ord a => StartStop a -> StartStop a -> Bool
< :: StartStop a -> StartStop a -> Bool
$c< :: forall a. Ord a => StartStop a -> StartStop a -> Bool
compare :: StartStop a -> StartStop a -> Ordering
$ccompare :: forall a. Ord a => StartStop a -> StartStop a -> Ordering
Ord, StartStop a -> StartStop a -> Bool
forall a. Eq a => StartStop a -> StartStop a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StartStop a -> StartStop a -> Bool
$c/= :: forall a. Eq a => StartStop a -> StartStop a -> Bool
== :: StartStop a -> StartStop a -> Bool
$c== :: forall a. Eq a => StartStop a -> StartStop a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (StartStop a) x -> StartStop a
forall a x. StartStop a -> Rep (StartStop a) x
$cto :: forall a x. Rep (StartStop a) x -> StartStop a
$cfrom :: forall a x. StartStop a -> Rep (StartStop a) x
Generic, forall a. NFData a => StartStop a -> ()
forall a. (a -> ()) -> NFData a
rnf :: StartStop a -> ()
$crnf :: forall a. NFData a => StartStop a -> ()
NFData, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {a}. Hashable a => Eq (StartStop a)
forall a. Hashable a => Int -> StartStop a -> Int
forall a. Hashable a => StartStop a -> Int
hash :: StartStop a -> Int
$chash :: forall a. Hashable a => StartStop a -> Int
hashWithSalt :: Int -> StartStop a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> StartStop a -> Int
Hashable, forall a b. a -> StartStop b -> StartStop a
forall a b. (a -> b) -> StartStop a -> StartStop b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> StartStop b -> StartStop a
$c<$ :: forall a b. a -> StartStop b -> StartStop a
fmap :: forall a b. (a -> b) -> StartStop a -> StartStop b
$cfmap :: forall a b. (a -> b) -> StartStop a -> StartStop b
Functor, forall a. Eq a => a -> StartStop a -> Bool
forall a. Num a => StartStop a -> a
forall a. Ord a => StartStop a -> a
forall m. Monoid m => StartStop m -> m
forall a. StartStop a -> Bool
forall a. StartStop a -> Int
forall a. StartStop a -> [a]
forall a. (a -> a -> a) -> StartStop a -> a
forall m a. Monoid m => (a -> m) -> StartStop a -> m
forall b a. (b -> a -> b) -> b -> StartStop a -> b
forall a b. (a -> b -> b) -> b -> StartStop a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => StartStop a -> a
$cproduct :: forall a. Num a => StartStop a -> a
sum :: forall a. Num a => StartStop a -> a
$csum :: forall a. Num a => StartStop a -> a
minimum :: forall a. Ord a => StartStop a -> a
$cminimum :: forall a. Ord a => StartStop a -> a
maximum :: forall a. Ord a => StartStop a -> a
$cmaximum :: forall a. Ord a => StartStop a -> a
elem :: forall a. Eq a => a -> StartStop a -> Bool
$celem :: forall a. Eq a => a -> StartStop a -> Bool
length :: forall a. StartStop a -> Int
$clength :: forall a. StartStop a -> Int
null :: forall a. StartStop a -> Bool
$cnull :: forall a. StartStop a -> Bool
toList :: forall a. StartStop a -> [a]
$ctoList :: forall a. StartStop a -> [a]
foldl1 :: forall a. (a -> a -> a) -> StartStop a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> StartStop a -> a
foldr1 :: forall a. (a -> a -> a) -> StartStop a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> StartStop a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> StartStop a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> StartStop a -> b
foldl :: forall b a. (b -> a -> b) -> b -> StartStop a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> StartStop a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> StartStop a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> StartStop a -> b
foldr :: forall a b. (a -> b -> b) -> b -> StartStop a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> StartStop a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> StartStop a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> StartStop a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> StartStop a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> StartStop a -> m
fold :: forall m. Monoid m => StartStop m -> m
$cfold :: forall m. Monoid m => StartStop m -> m
Foldable, Functor StartStop
Foldable StartStop
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
StartStop (m a) -> m (StartStop a)
forall (f :: * -> *) a.
Applicative f =>
StartStop (f a) -> f (StartStop a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> StartStop a -> m (StartStop b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
sequence :: forall (m :: * -> *) a.
Monad m =>
StartStop (m a) -> m (StartStop a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
StartStop (m a) -> m (StartStop a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> StartStop a -> m (StartStop b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> StartStop a -> m (StartStop b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
StartStop (f a) -> f (StartStop a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
StartStop (f a) -> f (StartStop a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
Traversable)

-- some instances for StartStop

instance Show a => Show (StartStop a) where
  show :: StartStop a -> String
show StartStop a
Start = String
"⋊"
  show StartStop a
Stop = String
"⋉"
  show (Inner a
a) = forall a. Show a => a -> String
show a
a

instance (Notation a) => Notation (StartStop a) where
  showNotation :: StartStop a -> String
showNotation StartStop a
Start = String
"⋊"
  showNotation StartStop a
Stop = String
"⋉"
  showNotation (Inner a
a) = forall i. Notation i => i -> String
showNotation a
a
  parseNotation :: ReadP (StartStop a)
parseNotation = forall a. ReadP a
ReadP.pfail

instance FromJSON a => FromJSON (StartStop a) where
  parseJSON :: Value -> Parser (StartStop a)
parseJSON (Aeson.String Text
"start") = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StartStop a
Start
  parseJSON (Aeson.String Text
"stop") = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StartStop a
Stop
  parseJSON Value
other = forall a. a -> StartStop a
Inner forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
other

-- some helper functions for StartStop

{- | From a list of @StartStop@s returns only the elements that are not @:⋊@ or @:⋉@,
 unwrapped to their original type.
-}
onlyInner :: [StartStop a] -> [a]
onlyInner :: forall a. [StartStop a] -> [a]
onlyInner [] = []
onlyInner (Inner a
a : [StartStop a]
rst) = a
a forall a. a -> [a] -> [a]
: forall a. [StartStop a] -> [a]
onlyInner [StartStop a]
rst
onlyInner (StartStop a
_ : [StartStop a]
rst) = forall a. [StartStop a] -> [a]
onlyInner [StartStop a]
rst

-- | Returns the content of an 'Inner', or 'Nothing'.
getInner :: StartStop a -> Maybe a
getInner :: forall a. StartStop a -> Maybe a
getInner (Inner a
a) = forall a. a -> Maybe a
Just a
a
getInner StartStop a
_ = forall a. Maybe a
Nothing

-- | Returns the content of an 'Inner', or a 'Left' with an error message.
getInnerE :: StartStop a -> Either String a
getInnerE :: forall a. StartStop a -> Either String a
getInnerE (Inner a
a) = forall a b. b -> Either a b
Right a
a
getInnerE StartStop a
Start = forall a b. a -> Either a b
Left String
"expected inner but found ⋊"
getInnerE StartStop a
Stop = forall a b. a -> Either a b
Left String
"expected inner but found ⋉"

-- | Returns 'True' iff the argument is an 'Inner'.
isInner :: StartStop a -> Bool
isInner :: forall a. StartStop a -> Bool
isInner (Inner a
_) = Bool
True
isInner StartStop a
_ = Bool
False

-- | Returns 'True' iff the argument is 'Start'.
isStart :: StartStop a -> Bool
isStart :: forall a. StartStop a -> Bool
isStart StartStop a
Start = Bool
True
isStart StartStop a
_ = Bool
False

-- | Returns 'True' iff the argument is 'Stop'.
isStop :: StartStop a -> Bool
isStop :: forall a. StartStop a -> Bool
isStop StartStop a
Stop = Bool
True
isStop StartStop a
_ = Bool
False

-- | Turns a pair within a 'StartStop' into a pair of 'StartStop's
distStartStop :: StartStop (a, b) -> (StartStop a, StartStop b)
distStartStop :: forall a b. StartStop (a, b) -> (StartStop a, StartStop b)
distStartStop StartStop (a, b)
Start = (forall a. StartStop a
Start, forall a. StartStop a
Start)
distStartStop StartStop (a, b)
Stop = (forall a. StartStop a
Stop, forall a. StartStop a
Stop)
distStartStop (Inner (a
a, b
b)) = (forall a. a -> StartStop a
Inner a
a, forall a. a -> StartStop a
Inner b
b)

-- evaluator interface
-- ===================

-- | A flag indicating whether an operation is performed on the last transition.
type IsLast = Bool

{- | A flag that indicates where a split has been performed,
 on the left transition, the right transition, or the only transition
-}
data SplitType
  = LeftOfTwo
  | RightOfTwo
  | SingleOfOne

{- | An evaluator for unspreads.
 Takes the two child slices and the middle transition.
 Returns the parent slice and the spread operation, if possible.
-}
type UnspreadMiddle tr slc v = (slc, tr, slc) -> Maybe (slc, v)

{- | An evaluator returning the possible left parent edges of an unspread.
 The first argument is a pair of left child transition and left child slice.
 The second argument is the parent slice.
-}
type UnspreadLeft tr slc = (tr, slc) -> slc -> [tr]

{- | An evaluator returning the possible right parent edges of an unspread.
 The first argument is a pair of right child slice and right child transition.
 The second argument is the parent slice.
-}
type UnspreadRight tr slc = (slc, tr) -> slc -> [tr]

{- | An evaluator for unsplits.
 Returns possible unsplits of a given pair of transitions.
-}
type Unsplit tr slc v =
  StartStop slc -> tr -> slc -> tr -> StartStop slc -> SplitType -> [(tr, v)]

{- | A combined evaluator for unsplits, unspreads, and unfreezes.
 Additionally, contains a function for mapping terminal slices to derivation slices.
-}
data Eval tr tr' slc slc' v = Eval
  { forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> UnspreadMiddle tr slc v
evalUnspreadMiddle :: !(UnspreadMiddle tr slc v)
  , forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> UnspreadLeft tr slc
evalUnspreadLeft :: !(UnspreadLeft tr slc)
  , forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> UnspreadRight tr slc
evalUnspreadRight :: !(UnspreadRight tr slc)
  , forall tr tr' slc slc' v.
Eval tr tr' slc slc' v -> Unsplit tr slc v
evalUnsplit :: !(Unsplit tr slc v)
  , forall tr tr' slc slc' v.
Eval tr tr' slc slc' v
-> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
evalUnfreeze
      :: !(StartStop slc -> Maybe tr' -> StartStop slc -> IsLast -> [(tr, v)])
  , forall tr tr' slc slc' v. Eval tr tr' slc slc' v -> slc' -> slc
evalSlice :: !(slc' -> slc)
  }

-- | Maps a function over all scores produced by the evaluator.
mapEvalScore :: (v -> w) -> Eval tr tr' slc slc' v -> Eval tr tr' slc slc' w
mapEvalScore :: forall v w tr tr' slc slc'.
(v -> w) -> Eval tr tr' slc slc' v -> Eval tr tr' slc slc' w
mapEvalScore v -> w
f (Eval UnspreadMiddle tr slc v
unspreadm UnspreadLeft tr slc
unspreadl UnspreadRight tr slc
unspreadr Unsplit tr slc v
unsplit StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
uf slc' -> slc
s) =
  forall tr tr' slc slc' v.
UnspreadMiddle tr slc v
-> UnspreadLeft tr slc
-> UnspreadRight tr slc
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' v
Eval
    (slc, tr, slc) -> Maybe (slc, w)
unspreadm'
    UnspreadLeft tr slc
unspreadl
    UnspreadRight tr slc
unspreadr
    StartStop slc
-> tr -> slc -> tr -> StartStop slc -> SplitType -> [(tr, w)]
unsplit'
    StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, w)]
uf'
    slc' -> slc
s
 where
  unspreadm' :: (slc, tr, slc) -> Maybe (slc, w)
unspreadm' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> w
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnspreadMiddle tr slc v
unspreadm
  unsplit' :: StartStop slc
-> tr -> slc -> tr -> StartStop slc -> SplitType -> [(tr, w)]
unsplit' StartStop slc
sl tr
tl slc
sm tr
tr StartStop slc
sr SplitType
typ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> w
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unsplit tr slc v
unsplit StartStop slc
sl tr
tl slc
sm tr
tr StartStop slc
sr SplitType
typ
  uf' :: StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, w)]
uf' StartStop slc
l Maybe tr'
e StartStop slc
r Bool
isLast = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> w
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
uf StartStop slc
l Maybe tr'
e StartStop slc
r Bool
isLast

-- product evaluators
-- ------------------

{- | Combine two evaluators into a product evaluator.
 Each evaluation function returns the product of the two component evaluators' results.
-}
productEval
  :: Eval tr1 tr' slc1 slc' v1
  -> Eval tr2 tr' slc2 slc' v2
  -> Eval (tr1, tr2) tr' (slc1, slc2) slc' (v1, v2)
productEval :: forall tr1 tr' slc1 slc' v1 tr2 slc2 v2.
Eval tr1 tr' slc1 slc' v1
-> Eval tr2 tr' slc2 slc' v2
-> Eval (tr1, tr2) tr' (slc1, slc2) slc' (v1, v2)
productEval (Eval UnspreadMiddle tr1 slc1 v1
unspreadm1 UnspreadLeft tr1 slc1
unspreadl1 UnspreadRight tr1 slc1
unspreadr1 Unsplit tr1 slc1 v1
merge1 StartStop slc1
-> Maybe tr' -> StartStop slc1 -> Bool -> [(tr1, v1)]
thaw1 slc' -> slc1
slice1) (Eval UnspreadMiddle tr2 slc2 v2
unspreadm2 UnspreadLeft tr2 slc2
unspreadl2 UnspreadRight tr2 slc2
unspreadr2 Unsplit tr2 slc2 v2
merge2 StartStop slc2
-> Maybe tr' -> StartStop slc2 -> Bool -> [(tr2, v2)]
thaw2 slc' -> slc2
slice2) =
  forall tr tr' slc slc' v.
UnspreadMiddle tr slc v
-> UnspreadLeft tr slc
-> UnspreadRight tr slc
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' v
Eval ((slc1, slc2), (tr1, tr2), (slc1, slc2))
-> Maybe ((slc1, slc2), (v1, v2))
unspreadm ((tr1, tr2), (slc1, slc2)) -> (slc1, slc2) -> [(tr1, tr2)]
unspreadl ((slc1, slc2), (tr1, tr2)) -> (slc1, slc2) -> [(tr1, tr2)]
unspreadr StartStop (slc1, slc2)
-> (tr1, tr2)
-> (slc1, slc2)
-> (tr1, tr2)
-> StartStop (slc1, slc2)
-> SplitType
-> [((tr1, tr2), (v1, v2))]
merge StartStop (slc1, slc2)
-> Maybe tr'
-> StartStop (slc1, slc2)
-> Bool
-> [((tr1, tr2), (v1, v2))]
thaw slc' -> (slc1, slc2)
slice
 where
  unspreadm :: ((slc1, slc2), (tr1, tr2), (slc1, slc2))
-> Maybe ((slc1, slc2), (v1, v2))
unspreadm ((slc1
l1, slc2
l2), (tr1
m1, tr2
m2), (slc1
r1, slc2
r2)) = do
    (slc1
a, v1
va) <- UnspreadMiddle tr1 slc1 v1
unspreadm1 (slc1
l1, tr1
m1, slc1
r1)
    (slc2
b, v2
vb) <- UnspreadMiddle tr2 slc2 v2
unspreadm2 (slc2
l2, tr2
m2, slc2
r2)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ((slc1
a, slc2
b), (v1
va, v2
vb))
  unspreadl :: ((tr1, tr2), (slc1, slc2)) -> (slc1, slc2) -> [(tr1, tr2)]
unspreadl ((tr1
l1, tr2
l2), (slc1
c1, slc2
c2)) (slc1
t1, slc2
t2) = do
    tr1
a <- UnspreadLeft tr1 slc1
unspreadl1 (tr1
l1, slc1
c1) slc1
t1
    tr2
b <- UnspreadLeft tr2 slc2
unspreadl2 (tr2
l2, slc2
c2) slc2
t2
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (tr1
a, tr2
b)
  unspreadr :: ((slc1, slc2), (tr1, tr2)) -> (slc1, slc2) -> [(tr1, tr2)]
unspreadr ((slc1
c1, slc2
c2), (tr1
r1, tr2
r2)) (slc1
t1, slc2
t2) = do
    tr1
a <- UnspreadRight tr1 slc1
unspreadr1 (slc1
c1, tr1
r1) slc1
t1
    tr2
b <- UnspreadRight tr2 slc2
unspreadr2 (slc2
c2, tr2
r2) slc2
t2
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (tr1
a, tr2
b)
  merge :: StartStop (slc1, slc2)
-> (tr1, tr2)
-> (slc1, slc2)
-> (tr1, tr2)
-> StartStop (slc1, slc2)
-> SplitType
-> [((tr1, tr2), (v1, v2))]
merge StartStop (slc1, slc2)
sl (tr1
tl1, tr2
tl2) (slc1
sm1, slc2
sm2) (tr1
tr1, tr2
tr2) StartStop (slc1, slc2)
sr SplitType
typ = do
    (tr1
a, v1
va) <- Unsplit tr1 slc1 v1
merge1 StartStop slc1
sl1 tr1
tl1 slc1
sm1 tr1
tr1 StartStop slc1
sr1 SplitType
typ
    (tr2
b, v2
vb) <- Unsplit tr2 slc2 v2
merge2 StartStop slc2
sl2 tr2
tl2 slc2
sm2 tr2
tr2 StartStop slc2
sr2 SplitType
typ
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ((tr1
a, tr2
b), (v1
va, v2
vb))
   where
    (StartStop slc1
sl1, StartStop slc2
sl2) = forall a b. StartStop (a, b) -> (StartStop a, StartStop b)
distStartStop StartStop (slc1, slc2)
sl
    (StartStop slc1
sr1, StartStop slc2
sr2) = forall a b. StartStop (a, b) -> (StartStop a, StartStop b)
distStartStop StartStop (slc1, slc2)
sr
  thaw :: StartStop (slc1, slc2)
-> Maybe tr'
-> StartStop (slc1, slc2)
-> Bool
-> [((tr1, tr2), (v1, v2))]
thaw StartStop (slc1, slc2)
l Maybe tr'
e StartStop (slc1, slc2)
r Bool
isLast = do
    (tr1
a, v1
va) <- StartStop slc1
-> Maybe tr' -> StartStop slc1 -> Bool -> [(tr1, v1)]
thaw1 StartStop slc1
l1 Maybe tr'
e StartStop slc1
r1 Bool
isLast
    (tr2
b, v2
vb) <- StartStop slc2
-> Maybe tr' -> StartStop slc2 -> Bool -> [(tr2, v2)]
thaw2 StartStop slc2
l2 Maybe tr'
e StartStop slc2
r2 Bool
isLast
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ((tr1
a, tr2
b), (v1
va, v2
vb))
   where
    (StartStop slc1
l1, StartStop slc2
l2) = forall a b. StartStop (a, b) -> (StartStop a, StartStop b)
distStartStop StartStop (slc1, slc2)
l
    (StartStop slc1
r1, StartStop slc2
r2) = forall a b. StartStop (a, b) -> (StartStop a, StartStop b)
distStartStop StartStop (slc1, slc2)
r
  slice :: slc' -> (slc1, slc2)
slice slc'
s = (slc' -> slc1
slice1 slc'
s, slc' -> slc2
slice2 slc'
s)

-- restricting branching
-- ---------------------

-- | A flag that is used to restrict spread operations to right branching.
data RightBranchSpread
  = RBBranches
  | RBClear
  deriving (RightBranchSpread -> RightBranchSpread -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RightBranchSpread -> RightBranchSpread -> Bool
$c/= :: RightBranchSpread -> RightBranchSpread -> Bool
== :: RightBranchSpread -> RightBranchSpread -> Bool
$c== :: RightBranchSpread -> RightBranchSpread -> Bool
Eq, Eq RightBranchSpread
RightBranchSpread -> RightBranchSpread -> Bool
RightBranchSpread -> RightBranchSpread -> Ordering
RightBranchSpread -> RightBranchSpread -> RightBranchSpread
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RightBranchSpread -> RightBranchSpread -> RightBranchSpread
$cmin :: RightBranchSpread -> RightBranchSpread -> RightBranchSpread
max :: RightBranchSpread -> RightBranchSpread -> RightBranchSpread
$cmax :: RightBranchSpread -> RightBranchSpread -> RightBranchSpread
>= :: RightBranchSpread -> RightBranchSpread -> Bool
$c>= :: RightBranchSpread -> RightBranchSpread -> Bool
> :: RightBranchSpread -> RightBranchSpread -> Bool
$c> :: RightBranchSpread -> RightBranchSpread -> Bool
<= :: RightBranchSpread -> RightBranchSpread -> Bool
$c<= :: RightBranchSpread -> RightBranchSpread -> Bool
< :: RightBranchSpread -> RightBranchSpread -> Bool
$c< :: RightBranchSpread -> RightBranchSpread -> Bool
compare :: RightBranchSpread -> RightBranchSpread -> Ordering
$ccompare :: RightBranchSpread -> RightBranchSpread -> Ordering
Ord, Int -> RightBranchSpread -> ShowS
[RightBranchSpread] -> ShowS
RightBranchSpread -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RightBranchSpread] -> ShowS
$cshowList :: [RightBranchSpread] -> ShowS
show :: RightBranchSpread -> String
$cshow :: RightBranchSpread -> String
showsPrec :: Int -> RightBranchSpread -> ShowS
$cshowsPrec :: Int -> RightBranchSpread -> ShowS
Show, forall x. Rep RightBranchSpread x -> RightBranchSpread
forall x. RightBranchSpread -> Rep RightBranchSpread x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RightBranchSpread x -> RightBranchSpread
$cfrom :: forall x. RightBranchSpread -> Rep RightBranchSpread x
Generic, RightBranchSpread -> ()
forall a. (a -> ()) -> NFData a
rnf :: RightBranchSpread -> ()
$crnf :: RightBranchSpread -> ()
NFData, Eq RightBranchSpread
Int -> RightBranchSpread -> Int
RightBranchSpread -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: RightBranchSpread -> Int
$chash :: RightBranchSpread -> Int
hashWithSalt :: Int -> RightBranchSpread -> Int
$chashWithSalt :: Int -> RightBranchSpread -> Int
Hashable)

{- | An evaluator that doesn't parse the input but restricts spread operations to right branching.
 Legal combinations will just return a singleton @()@ while illegal combinations return nothing.
 Combine this with any evaluator as a product (using 'productEval' or 'rightBranchSpread')
 to make the evaluator right-branching.
-}
evalRightBranchSpread :: Eval RightBranchSpread tr' () slc' ()
evalRightBranchSpread :: forall tr' slc'. Eval RightBranchSpread tr' () slc' ()
evalRightBranchSpread = forall tr tr' slc slc' v.
UnspreadMiddle tr slc v
-> UnspreadLeft tr slc
-> UnspreadRight tr slc
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' v
Eval forall {a} {c}. (a, RightBranchSpread, c) -> Maybe ((), ())
unspreadm forall {p} {p}. p -> p -> [RightBranchSpread]
unspreadl forall {p} {p}. p -> p -> [RightBranchSpread]
unspreadr forall {p} {p} {p} {p} {p} {p}.
p -> p -> p -> p -> p -> p -> [(RightBranchSpread, ())]
merge forall {p} {p} {p} {p}.
p -> p -> p -> p -> [(RightBranchSpread, ())]
thaw forall {p}. p -> ()
slice
 where
  unspreadm :: (a, RightBranchSpread, c) -> Maybe ((), ())
unspreadm (a
_, RightBranchSpread
RBBranches, c
_) = forall a. Maybe a
Nothing
  unspreadm (a
_, RightBranchSpread
RBClear, c
_) = forall a. a -> Maybe a
Just ((), ())
  unspreadl :: p -> p -> [RightBranchSpread]
unspreadl p
_ p
_ = [RightBranchSpread
RBClear]
  unspreadr :: p -> p -> [RightBranchSpread]
unspreadr p
_ p
_ = [RightBranchSpread
RBBranches]
  merge :: p -> p -> p -> p -> p -> p -> [(RightBranchSpread, ())]
merge p
_ p
_ p
_ p
_ p
_ p
_ = [(RightBranchSpread
RBClear, ())]
  thaw :: p -> p -> p -> p -> [(RightBranchSpread, ())]
thaw p
_ p
_ p
_ p
_ = [(RightBranchSpread
RBClear, ())]
  slice :: p -> ()
slice p
_ = ()

-- | Restrict any evaluator to right-branching spreads.
rightBranchSpread
  :: Eval tr tr' slc slc' w -> Eval (RightBranchSpread, tr) tr' ((), slc) slc' w
rightBranchSpread :: forall tr tr' slc slc' w.
Eval tr tr' slc slc' w
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' w
rightBranchSpread = forall v w tr tr' slc slc'.
(v -> w) -> Eval tr tr' slc slc' v -> Eval tr tr' slc slc' w
mapEvalScore forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tr1 tr' slc1 slc' v1 tr2 slc2 v2.
Eval tr1 tr' slc1 slc' v1
-> Eval tr2 tr' slc2 slc' v2
-> Eval (tr1, tr2) tr' (slc1, slc2) slc' (v1, v2)
productEval forall tr' slc'. Eval RightBranchSpread tr' () slc' ()
evalRightBranchSpread

-- restricting derivation order
-- ----------------------------

{- | A flag for indicating whether a transition is the result of a split or not.
 This is used for restricting the order of splits and spreads.
-}
data Merged
  = Merged
  | NotMerged
  deriving (Merged -> Merged -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Merged -> Merged -> Bool
$c/= :: Merged -> Merged -> Bool
== :: Merged -> Merged -> Bool
$c== :: Merged -> Merged -> Bool
Eq, Eq Merged
Merged -> Merged -> Bool
Merged -> Merged -> Ordering
Merged -> Merged -> Merged
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Merged -> Merged -> Merged
$cmin :: Merged -> Merged -> Merged
max :: Merged -> Merged -> Merged
$cmax :: Merged -> Merged -> Merged
>= :: Merged -> Merged -> Bool
$c>= :: Merged -> Merged -> Bool
> :: Merged -> Merged -> Bool
$c> :: Merged -> Merged -> Bool
<= :: Merged -> Merged -> Bool
$c<= :: Merged -> Merged -> Bool
< :: Merged -> Merged -> Bool
$c< :: Merged -> Merged -> Bool
compare :: Merged -> Merged -> Ordering
$ccompare :: Merged -> Merged -> Ordering
Ord, Int -> Merged -> ShowS
[Merged] -> ShowS
Merged -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Merged] -> ShowS
$cshowList :: [Merged] -> ShowS
show :: Merged -> String
$cshow :: Merged -> String
showsPrec :: Int -> Merged -> ShowS
$cshowsPrec :: Int -> Merged -> ShowS
Show, forall x. Rep Merged x -> Merged
forall x. Merged -> Rep Merged x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Merged x -> Merged
$cfrom :: forall x. Merged -> Rep Merged x
Generic, Merged -> ()
forall a. (a -> ()) -> NFData a
rnf :: Merged -> ()
$crnf :: Merged -> ()
NFData, Eq Merged
Int -> Merged -> Int
Merged -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Merged -> Int
$chash :: Merged -> Int
hashWithSalt :: Int -> Merged -> Int
$chashWithSalt :: Int -> Merged -> Int
Hashable)

{- | An evaluator that doesn't parse the input but restricts the order of operations
 to always have splits before spreads on the left and right transitions at a spread.
 Legal combinations will just return a singleton @()@ while illegal combinations return nothing.
 Combine this with any evaluator as a product (using 'productEval' or 'splitFirst')
 to make the evaluator order-restricted.
-}
evalSplitBeforeSpread :: (Eval Merged tr' () slc' ())
evalSplitBeforeSpread :: forall tr' slc'. Eval Merged tr' () slc' ()
evalSplitBeforeSpread = forall tr tr' slc slc' v.
UnspreadMiddle tr slc v
-> UnspreadLeft tr slc
-> UnspreadRight tr slc
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' v
Eval forall {p}. p -> Maybe ((), ())
unspreadm forall {b} {p}. (Merged, b) -> p -> [Merged]
unspreadl forall {a} {p}. (a, Merged) -> p -> [Merged]
unspreadr forall {p} {p} {p} {p} {p} {p}.
p -> p -> p -> p -> p -> p -> [(Merged, ())]
merge forall {p} {p} {p} {p}. p -> p -> p -> p -> [(Merged, ())]
thaw forall {p}. p -> ()
slice
 where
  unspreadm :: p -> Maybe ((), ())
unspreadm p
_ = forall a. a -> Maybe a
Just ((), ())
  unspreadl :: (Merged, b) -> p -> [Merged]
unspreadl (Merged
Merged, b
_) p
_ = []
  unspreadl (Merged
NotMerged, b
_) p
_ = [Merged
NotMerged]
  unspreadr :: (a, Merged) -> p -> [Merged]
unspreadr (a
_, Merged
Merged) p
_ = []
  unspreadr (a
_, Merged
NotMerged) p
_ = [Merged
NotMerged]
  merge :: p -> p -> p -> p -> p -> p -> [(Merged, ())]
merge p
_ p
_ p
_ p
_ p
_ p
_ = [(Merged
Merged, ())]
  thaw :: p -> p -> p -> p -> [(Merged, ())]
thaw p
_ p
_ p
_ p
_ = [(Merged
NotMerged, ())]
  slice :: p -> ()
slice p
_ = ()

-- | Restrict any evaluator to split-before-spread order.
splitFirst :: Eval tr tr' slc slc' w -> Eval (Merged, tr) tr' ((), slc) slc' w
splitFirst :: forall tr tr' slc slc' w.
Eval tr tr' slc slc' w -> Eval (Merged, tr) tr' ((), slc) slc' w
splitFirst = forall v w tr tr' slc slc'.
(v -> w) -> Eval tr tr' slc slc' v -> Eval tr tr' slc slc' w
mapEvalScore forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tr1 tr' slc1 slc' v1 tr2 slc2 v2.
Eval tr1 tr' slc1 slc' v1
-> Eval tr2 tr' slc2 slc' v2
-> Eval (tr1, tr2) tr' (slc1, slc2) slc' (v1, v2)
productEval forall tr' slc'. Eval Merged tr' () slc' ()
evalSplitBeforeSpread

-- left-most derivation outer operations
-- =====================================

{- $leftmostdoc

 More specifically, if there is only one open transition left, only two actions are possible,
 freezing or splitting that transition:

 > freeze only:   split only:
 > ...=[]——⋉      ==[]——⋉
 > ...=[]==⋉         \  /
 >                     []

 These options are encoded in 'LeftmostSingle'.

 If two or more transitions are still open, four actions are possible:

 > freeze left:         split left:          split right:         spread:
 > ...=[]——[]——[]—...   ...=[]——[]——[]—...   ...=[]——[]——[]—...   ...=[]——[]——[]—...
 > ...=[]==[]——[]—...        \  /                     \  /             \  /\  /
 >                            []                       []               []——[]

 These options are encoded in 'LeftmostDouble'.
 Note that the order of operations is restricted so that after a right split only
 only another right split or a spread are allowed.
 See [below](#monadicDeriv) for a way to construct leftmost derivations in a type-safe way,
 checking operation order and open transitions at compile time.

 Both single and double operations are combined in 'Leftmost'.
 All three operation containers are parameterized over the specific operations types for
 splits (@s@), spreads (@h@ for "horizontalization"), freezes (@f@).
-}

-- | Generative operations on a single transition (split or freeze).
data LeftmostSingle s f
  = LMSingleSplit !s
  | LMSingleFreeze !f
  deriving (LeftmostSingle s f -> LeftmostSingle s f -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s f.
(Eq s, Eq f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Bool
/= :: LeftmostSingle s f -> LeftmostSingle s f -> Bool
$c/= :: forall s f.
(Eq s, Eq f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Bool
== :: LeftmostSingle s f -> LeftmostSingle s f -> Bool
$c== :: forall s f.
(Eq s, Eq f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Bool
Eq, LeftmostSingle s f -> LeftmostSingle s f -> Bool
LeftmostSingle s f -> LeftmostSingle s f -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s} {f}. (Ord s, Ord f) => Eq (LeftmostSingle s f)
forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Bool
forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Ordering
forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> LeftmostSingle s f
min :: LeftmostSingle s f -> LeftmostSingle s f -> LeftmostSingle s f
$cmin :: forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> LeftmostSingle s f
max :: LeftmostSingle s f -> LeftmostSingle s f -> LeftmostSingle s f
$cmax :: forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> LeftmostSingle s f
>= :: LeftmostSingle s f -> LeftmostSingle s f -> Bool
$c>= :: forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Bool
> :: LeftmostSingle s f -> LeftmostSingle s f -> Bool
$c> :: forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Bool
<= :: LeftmostSingle s f -> LeftmostSingle s f -> Bool
$c<= :: forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Bool
< :: LeftmostSingle s f -> LeftmostSingle s f -> Bool
$c< :: forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Bool
compare :: LeftmostSingle s f -> LeftmostSingle s f -> Ordering
$ccompare :: forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Ordering
Ord, Int -> LeftmostSingle s f -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s f. (Show s, Show f) => Int -> LeftmostSingle s f -> ShowS
forall s f. (Show s, Show f) => [LeftmostSingle s f] -> ShowS
forall s f. (Show s, Show f) => LeftmostSingle s f -> String
showList :: [LeftmostSingle s f] -> ShowS
$cshowList :: forall s f. (Show s, Show f) => [LeftmostSingle s f] -> ShowS
show :: LeftmostSingle s f -> String
$cshow :: forall s f. (Show s, Show f) => LeftmostSingle s f -> String
showsPrec :: Int -> LeftmostSingle s f -> ShowS
$cshowsPrec :: forall s f. (Show s, Show f) => Int -> LeftmostSingle s f -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s f x. Rep (LeftmostSingle s f) x -> LeftmostSingle s f
forall s f x. LeftmostSingle s f -> Rep (LeftmostSingle s f) x
$cto :: forall s f x. Rep (LeftmostSingle s f) x -> LeftmostSingle s f
$cfrom :: forall s f x. LeftmostSingle s f -> Rep (LeftmostSingle s f) x
Generic, forall a. (a -> ()) -> NFData a
forall s f. (NFData s, NFData f) => LeftmostSingle s f -> ()
rnf :: LeftmostSingle s f -> ()
$crnf :: forall s f. (NFData s, NFData f) => LeftmostSingle s f -> ()
NFData, forall a b. a -> LeftmostSingle s b -> LeftmostSingle s a
forall a b. (a -> b) -> LeftmostSingle s a -> LeftmostSingle s b
forall s a b. a -> LeftmostSingle s b -> LeftmostSingle s a
forall s a b. (a -> b) -> LeftmostSingle s a -> LeftmostSingle s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> LeftmostSingle s b -> LeftmostSingle s a
$c<$ :: forall s a b. a -> LeftmostSingle s b -> LeftmostSingle s a
fmap :: forall a b. (a -> b) -> LeftmostSingle s a -> LeftmostSingle s b
$cfmap :: forall s a b. (a -> b) -> LeftmostSingle s a -> LeftmostSingle s b
Functor, forall a. LeftmostSingle s a -> Bool
forall s a. Eq a => a -> LeftmostSingle s a -> Bool
forall s a. Num a => LeftmostSingle s a -> a
forall s a. Ord a => LeftmostSingle s a -> a
forall m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m
forall s m. Monoid m => LeftmostSingle s m -> m
forall s a. LeftmostSingle s a -> Bool
forall s a. LeftmostSingle s a -> Int
forall s a. LeftmostSingle s a -> [a]
forall a b. (a -> b -> b) -> b -> LeftmostSingle s a -> b
forall s a. (a -> a -> a) -> LeftmostSingle s a -> a
forall s m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m
forall s b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b
forall s a b. (a -> b -> b) -> b -> LeftmostSingle s a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => LeftmostSingle s a -> a
$cproduct :: forall s a. Num a => LeftmostSingle s a -> a
sum :: forall a. Num a => LeftmostSingle s a -> a
$csum :: forall s a. Num a => LeftmostSingle s a -> a
minimum :: forall a. Ord a => LeftmostSingle s a -> a
$cminimum :: forall s a. Ord a => LeftmostSingle s a -> a
maximum :: forall a. Ord a => LeftmostSingle s a -> a
$cmaximum :: forall s a. Ord a => LeftmostSingle s a -> a
elem :: forall a. Eq a => a -> LeftmostSingle s a -> Bool
$celem :: forall s a. Eq a => a -> LeftmostSingle s a -> Bool
length :: forall a. LeftmostSingle s a -> Int
$clength :: forall s a. LeftmostSingle s a -> Int
null :: forall a. LeftmostSingle s a -> Bool
$cnull :: forall s a. LeftmostSingle s a -> Bool
toList :: forall a. LeftmostSingle s a -> [a]
$ctoList :: forall s a. LeftmostSingle s a -> [a]
foldl1 :: forall a. (a -> a -> a) -> LeftmostSingle s a -> a
$cfoldl1 :: forall s a. (a -> a -> a) -> LeftmostSingle s a -> a
foldr1 :: forall a. (a -> a -> a) -> LeftmostSingle s a -> a
$cfoldr1 :: forall s a. (a -> a -> a) -> LeftmostSingle s a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b
$cfoldl' :: forall s b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b
foldl :: forall b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b
$cfoldl :: forall s b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> LeftmostSingle s a -> b
$cfoldr' :: forall s a b. (a -> b -> b) -> b -> LeftmostSingle s a -> b
foldr :: forall a b. (a -> b -> b) -> b -> LeftmostSingle s a -> b
$cfoldr :: forall s a b. (a -> b -> b) -> b -> LeftmostSingle s a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m
$cfoldMap' :: forall s m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m
$cfoldMap :: forall s m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m
fold :: forall m. Monoid m => LeftmostSingle s m -> m
$cfold :: forall s m. Monoid m => LeftmostSingle s m -> m
Foldable, forall s. Functor (LeftmostSingle s)
forall s. Foldable (LeftmostSingle s)
forall s (m :: * -> *) a.
Monad m =>
LeftmostSingle s (m a) -> m (LeftmostSingle s a)
forall s (f :: * -> *) a.
Applicative f =>
LeftmostSingle s (f a) -> f (LeftmostSingle s a)
forall s (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LeftmostSingle s a -> m (LeftmostSingle s b)
forall s (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LeftmostSingle s a -> f (LeftmostSingle s b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LeftmostSingle s a -> f (LeftmostSingle s b)
sequence :: forall (m :: * -> *) a.
Monad m =>
LeftmostSingle s (m a) -> m (LeftmostSingle s a)
$csequence :: forall s (m :: * -> *) a.
Monad m =>
LeftmostSingle s (m a) -> m (LeftmostSingle s a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LeftmostSingle s a -> m (LeftmostSingle s b)
$cmapM :: forall s (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LeftmostSingle s a -> m (LeftmostSingle s b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
LeftmostSingle s (f a) -> f (LeftmostSingle s a)
$csequenceA :: forall s (f :: * -> *) a.
Applicative f =>
LeftmostSingle s (f a) -> f (LeftmostSingle s a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LeftmostSingle s a -> f (LeftmostSingle s b)
$ctraverse :: forall s (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LeftmostSingle s a -> f (LeftmostSingle s b)
Traversable)

instance (ToJSON s, ToJSON f) => ToJSON (LeftmostSingle s f) where
  toJSON :: LeftmostSingle s f -> Value
toJSON =
    forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON forall a b. (a -> b) -> a -> b
$ ShowS -> Options
variantDefaults ((forall a. Semigroup a => a -> a -> a
<> String
"Only") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
firstToLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
8)
  toEncoding :: LeftmostSingle s f -> Encoding
toEncoding =
    forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding forall a b. (a -> b) -> a -> b
$
      ShowS -> Options
variantDefaults ((forall a. Semigroup a => a -> a -> a
<> String
"Only") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
firstToLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
8)

-- | Generative operations on two transitions (split left, freeze left, split right, or spread)
data LeftmostDouble s f h
  = LMDoubleSplitLeft !s
  | LMDoubleFreezeLeft !f
  | LMDoubleSplitRight !s
  | LMDoubleSpread !h
  deriving (LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s f h.
(Eq s, Eq f, Eq h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
/= :: LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
$c/= :: forall s f h.
(Eq s, Eq f, Eq h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
== :: LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
$c== :: forall s f h.
(Eq s, Eq f, Eq h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
Eq, LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s} {f} {h}.
(Ord s, Ord f, Ord h) =>
Eq (LeftmostDouble s f h)
forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering
forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h
-> LeftmostDouble s f h -> LeftmostDouble s f h
min :: LeftmostDouble s f h
-> LeftmostDouble s f h -> LeftmostDouble s f h
$cmin :: forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h
-> LeftmostDouble s f h -> LeftmostDouble s f h
max :: LeftmostDouble s f h
-> LeftmostDouble s f h -> LeftmostDouble s f h
$cmax :: forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h
-> LeftmostDouble s f h -> LeftmostDouble s f h
>= :: LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
$c>= :: forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
> :: LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
$c> :: forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
<= :: LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
$c<= :: forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
< :: LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
$c< :: forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
compare :: LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering
$ccompare :: forall s f h.
(Ord s, Ord f, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering
Ord, Int -> LeftmostDouble s f h -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s f h.
(Show s, Show f, Show h) =>
Int -> LeftmostDouble s f h -> ShowS
forall s f h.
(Show s, Show f, Show h) =>
[LeftmostDouble s f h] -> ShowS
forall s f h.
(Show s, Show f, Show h) =>
LeftmostDouble s f h -> String
showList :: [LeftmostDouble s f h] -> ShowS
$cshowList :: forall s f h.
(Show s, Show f, Show h) =>
[LeftmostDouble s f h] -> ShowS
show :: LeftmostDouble s f h -> String
$cshow :: forall s f h.
(Show s, Show f, Show h) =>
LeftmostDouble s f h -> String
showsPrec :: Int -> LeftmostDouble s f h -> ShowS
$cshowsPrec :: forall s f h.
(Show s, Show f, Show h) =>
Int -> LeftmostDouble s f h -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s f h x.
Rep (LeftmostDouble s f h) x -> LeftmostDouble s f h
forall s f h x.
LeftmostDouble s f h -> Rep (LeftmostDouble s f h) x
$cto :: forall s f h x.
Rep (LeftmostDouble s f h) x -> LeftmostDouble s f h
$cfrom :: forall s f h x.
LeftmostDouble s f h -> Rep (LeftmostDouble s f h) x
Generic, forall a. (a -> ()) -> NFData a
forall s f h.
(NFData s, NFData f, NFData h) =>
LeftmostDouble s f h -> ()
rnf :: LeftmostDouble s f h -> ()
$crnf :: forall s f h.
(NFData s, NFData f, NFData h) =>
LeftmostDouble s f h -> ()
NFData)

-- | Helper function for `LeftmostDouble`'s 'ToJSON' instance.
lmDoubleToJSONName :: ShowS
lmDoubleToJSONName String
"LMDoubleSpread" = String
"hori"
lmDoubleToJSONName String
str = ShowS
firstToLower forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
8 String
str

instance (ToJSON s, ToJSON f, ToJSON h) => ToJSON (LeftmostDouble s f h) where
  toJSON :: LeftmostDouble s f h -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON forall a b. (a -> b) -> a -> b
$ ShowS -> Options
variantDefaults ShowS
lmDoubleToJSONName
  toEncoding :: LeftmostDouble s f h -> Encoding
toEncoding =
    forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding forall a b. (a -> b) -> a -> b
$ ShowS -> Options
variantDefaults ShowS
lmDoubleToJSONName

-- | A combined datatype for all leftmost-derivation operations.
data Leftmost s f h
  = LMSingle !(LeftmostSingle s f)
  | LMDouble !(LeftmostDouble s f h)
  deriving (Leftmost s f h -> Leftmost s f h -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s f h.
(Eq s, Eq f, Eq h) =>
Leftmost s f h -> Leftmost s f h -> Bool
/= :: Leftmost s f h -> Leftmost s f h -> Bool
$c/= :: forall s f h.
(Eq s, Eq f, Eq h) =>
Leftmost s f h -> Leftmost s f h -> Bool
== :: Leftmost s f h -> Leftmost s f h -> Bool
$c== :: forall s f h.
(Eq s, Eq f, Eq h) =>
Leftmost s f h -> Leftmost s f h -> Bool
Eq, Leftmost s f h -> Leftmost s f h -> Bool
Leftmost s f h -> Leftmost s f h -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s} {f} {h}. (Ord s, Ord f, Ord h) => Eq (Leftmost s f h)
forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Bool
forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Ordering
forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Leftmost s f h
min :: Leftmost s f h -> Leftmost s f h -> Leftmost s f h
$cmin :: forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Leftmost s f h
max :: Leftmost s f h -> Leftmost s f h -> Leftmost s f h
$cmax :: forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Leftmost s f h
>= :: Leftmost s f h -> Leftmost s f h -> Bool
$c>= :: forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Bool
> :: Leftmost s f h -> Leftmost s f h -> Bool
$c> :: forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Bool
<= :: Leftmost s f h -> Leftmost s f h -> Bool
$c<= :: forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Bool
< :: Leftmost s f h -> Leftmost s f h -> Bool
$c< :: forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Bool
compare :: Leftmost s f h -> Leftmost s f h -> Ordering
$ccompare :: forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Ordering
Ord, Int -> Leftmost s f h -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s f h.
(Show s, Show f, Show h) =>
Int -> Leftmost s f h -> ShowS
forall s f h. (Show s, Show f, Show h) => [Leftmost s f h] -> ShowS
forall s f h. (Show s, Show f, Show h) => Leftmost s f h -> String
showList :: [Leftmost s f h] -> ShowS
$cshowList :: forall s f h. (Show s, Show f, Show h) => [Leftmost s f h] -> ShowS
show :: Leftmost s f h -> String
$cshow :: forall s f h. (Show s, Show f, Show h) => Leftmost s f h -> String
showsPrec :: Int -> Leftmost s f h -> ShowS
$cshowsPrec :: forall s f h.
(Show s, Show f, Show h) =>
Int -> Leftmost s f h -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s f h x. Rep (Leftmost s f h) x -> Leftmost s f h
forall s f h x. Leftmost s f h -> Rep (Leftmost s f h) x
$cto :: forall s f h x. Rep (Leftmost s f h) x -> Leftmost s f h
$cfrom :: forall s f h x. Leftmost s f h -> Rep (Leftmost s f h) x
Generic, forall a. (a -> ()) -> NFData a
forall s f h.
(NFData s, NFData f, NFData h) =>
Leftmost s f h -> ()
rnf :: Leftmost s f h -> ()
$crnf :: forall s f h.
(NFData s, NFData f, NFData h) =>
Leftmost s f h -> ()
NFData)

instance (FromJSON s, FromJSON f, FromJSON h) => FromJSON (Leftmost s f h) where
  parseJSON :: Value -> Parser (Leftmost s f h)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Leftmost" forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Value
typ <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
    Value
val <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"
    case Value
typ of
      Value
"freezeLeft" -> forall f s h. f -> Leftmost s f h
LMFreezeLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"freezeOnly" -> forall f s h. f -> Leftmost s f h
LMFreezeOnly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"splitLeft" -> forall s f h. s -> Leftmost s f h
LMSplitLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"splitRight" -> forall s f h. s -> Leftmost s f h
LMSplitRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"splitOnly" -> forall s f h. s -> Leftmost s f h
LMSplitOnly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"hori" -> forall h s f. h -> Leftmost s f h
LMSpread forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
val -- the JSON encoding uses "hori" instead of "spread"
      Value
other -> forall a. Value -> Parser a
unexpected Value
other

instance (ToJSON s, ToJSON f, ToJSON h) => ToJSON (Leftmost s f h) where
  toJSON :: Leftmost s f h -> Value
toJSON (LMSingle LeftmostSingle s f
sg) = forall a. ToJSON a => a -> Value
toJSON LeftmostSingle s f
sg
  toJSON (LMDouble LeftmostDouble s f h
db) = forall a. ToJSON a => a -> Value
toJSON LeftmostDouble s f h
db
  toEncoding :: Leftmost s f h -> Encoding
toEncoding (LMSingle LeftmostSingle s f
sg) = forall a. ToJSON a => a -> Encoding
toEncoding LeftmostSingle s f
sg
  toEncoding (LMDouble LeftmostDouble s f h
db) = forall a. ToJSON a => a -> Encoding
toEncoding LeftmostDouble s f h
db

pattern LMSplitLeft :: s -> Leftmost s f h
pattern $bLMSplitLeft :: forall s f h. s -> Leftmost s f h
$mLMSplitLeft :: forall {r} {s} {f} {h}.
Leftmost s f h -> (s -> r) -> ((# #) -> r) -> r
LMSplitLeft s = LMDouble (LMDoubleSplitLeft s)

pattern LMFreezeLeft :: f -> Leftmost s f h
pattern $bLMFreezeLeft :: forall f s h. f -> Leftmost s f h
$mLMFreezeLeft :: forall {r} {f} {s} {h}.
Leftmost s f h -> (f -> r) -> ((# #) -> r) -> r
LMFreezeLeft f = LMDouble (LMDoubleFreezeLeft f)

pattern LMSplitRight :: s -> Leftmost s f h
pattern $bLMSplitRight :: forall s f h. s -> Leftmost s f h
$mLMSplitRight :: forall {r} {s} {f} {h}.
Leftmost s f h -> (s -> r) -> ((# #) -> r) -> r
LMSplitRight s = LMDouble (LMDoubleSplitRight s)

pattern LMSpread :: h -> Leftmost s f h
pattern $bLMSpread :: forall h s f. h -> Leftmost s f h
$mLMSpread :: forall {r} {h} {s} {f}.
Leftmost s f h -> (h -> r) -> ((# #) -> r) -> r
LMSpread h = LMDouble (LMDoubleSpread h)

pattern LMSplitOnly :: s -> Leftmost s f h
pattern $bLMSplitOnly :: forall s f h. s -> Leftmost s f h
$mLMSplitOnly :: forall {r} {s} {f} {h}.
Leftmost s f h -> (s -> r) -> ((# #) -> r) -> r
LMSplitOnly s = LMSingle (LMSingleSplit s)

pattern LMFreezeOnly :: f -> Leftmost s f h
pattern $bLMFreezeOnly :: forall f s h. f -> Leftmost s f h
$mLMFreezeOnly :: forall {r} {f} {s} {h}.
Leftmost s f h -> (f -> r) -> ((# #) -> r) -> r
LMFreezeOnly f = LMSingle (LMSingleFreeze f)

{-# COMPLETE LMSplitLeft, LMFreezeLeft, LMSplitRight, LMSpread, LMSplitOnly, LMFreezeOnly #-}

-- representing full analyses
-- ==========================

{- | Encodes an analysis of a piece,
 consisting of a "top" (the starting point of the derivation,
 i.e., the smallest reduction in the analysis)
 and a derivation of the piece's surface from the top.

 Use this type's 'FromJSON' instance to load an analysis exported by the protovoice annotation tool.
-}
data Analysis s f h tr slc = Analysis
  { forall s f h tr slc. Analysis s f h tr slc -> [Leftmost s f h]
anaDerivation :: [Leftmost s f h]
  -- ^ The derivation steps.
  , forall s f h tr slc. Analysis s f h tr slc -> Path tr slc
anaTop :: Path tr slc
  -- ^ The starting configuration of the derivation.
  -- Starts with the first transition, 'Start' and 'Stop' are implied.
  }
  deriving (Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s f h tr slc.
(Eq s, Eq f, Eq h, Eq tr, Eq slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
/= :: Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
$c/= :: forall s f h tr slc.
(Eq s, Eq f, Eq h, Eq tr, Eq slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
== :: Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
$c== :: forall s f h tr slc.
(Eq s, Eq f, Eq h, Eq tr, Eq slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
Eq, Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
Analysis s f h tr slc -> Analysis s f h tr slc -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s} {f} {h} {tr} {slc}.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Eq (Analysis s f h tr slc)
forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Ordering
forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc
-> Analysis s f h tr slc -> Analysis s f h tr slc
min :: Analysis s f h tr slc
-> Analysis s f h tr slc -> Analysis s f h tr slc
$cmin :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc
-> Analysis s f h tr slc -> Analysis s f h tr slc
max :: Analysis s f h tr slc
-> Analysis s f h tr slc -> Analysis s f h tr slc
$cmax :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc
-> Analysis s f h tr slc -> Analysis s f h tr slc
>= :: Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
$c>= :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
> :: Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
$c> :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
<= :: Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
$c<= :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
< :: Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
$c< :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Bool
compare :: Analysis s f h tr slc -> Analysis s f h tr slc -> Ordering
$ccompare :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord tr, Ord slc) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Ordering
Ord, Int -> Analysis s f h tr slc -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s f h tr slc.
(Show s, Show f, Show h, Show tr, Show slc) =>
Int -> Analysis s f h tr slc -> ShowS
forall s f h tr slc.
(Show s, Show f, Show h, Show tr, Show slc) =>
[Analysis s f h tr slc] -> ShowS
forall s f h tr slc.
(Show s, Show f, Show h, Show tr, Show slc) =>
Analysis s f h tr slc -> String
showList :: [Analysis s f h tr slc] -> ShowS
$cshowList :: forall s f h tr slc.
(Show s, Show f, Show h, Show tr, Show slc) =>
[Analysis s f h tr slc] -> ShowS
show :: Analysis s f h tr slc -> String
$cshow :: forall s f h tr slc.
(Show s, Show f, Show h, Show tr, Show slc) =>
Analysis s f h tr slc -> String
showsPrec :: Int -> Analysis s f h tr slc -> ShowS
$cshowsPrec :: forall s f h tr slc.
(Show s, Show f, Show h, Show tr, Show slc) =>
Int -> Analysis s f h tr slc -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s f h tr slc x.
Rep (Analysis s f h tr slc) x -> Analysis s f h tr slc
forall s f h tr slc x.
Analysis s f h tr slc -> Rep (Analysis s f h tr slc) x
$cto :: forall s f h tr slc x.
Rep (Analysis s f h tr slc) x -> Analysis s f h tr slc
$cfrom :: forall s f h tr slc x.
Analysis s f h tr slc -> Rep (Analysis s f h tr slc) x
Generic)

instance (FromJSON s, FromJSON f, FromJSON h, FromJSON tr, FromJSON slc) => FromJSON (Analysis s f h tr slc) where
  parseJSON :: Value -> Parser (Analysis s f h tr slc)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Analysis" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    [Leftmost s f h]
deriv <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"derivation"
    StartStop slc
start <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"start" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (StartStop slc)
parseSlice
    case StartStop slc
start of
      StartStop slc
Start -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      StartStop slc
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Start slice is not ⋊."
    [Value]
segments <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"topSegments"
    Path tr slc
top <- [Value] -> Parser (Path tr slc)
parseTop [Value]
segments
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Analysis{anaDerivation :: [Leftmost s f h]
anaDerivation = [Leftmost s f h]
deriv, anaTop :: Path tr slc
anaTop = Path tr slc
top}
   where
    parseTop :: [Aeson.Value] -> Aeson.Parser (Path tr slc)
    parseTop :: [Value] -> Parser (Path tr slc)
parseTop [Value]
segs = do
      [(tr, StartStop slc)]
segments <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Parser (tr, StartStop slc)
parseSegment [Value]
segs
      forall e a. [(e, StartStop a)] -> Parser (Path e a)
mkPath [(tr, StartStop slc)]
segments
     where
      mkPath :: [(e, StartStop a)] -> Aeson.Parser (Path e a)
      mkPath :: forall e a. [(e, StartStop a)] -> Parser (Path e a)
mkPath [(e
t, StartStop a
Stop)] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall around between. around -> Path around between
PathEnd e
t
      mkPath ((e
t, Inner a
s) : [(e, StartStop a)]
rest) = forall around between.
around -> between -> Path around between -> Path around between
Path e
t a
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. [(e, StartStop a)] -> Parser (Path e a)
mkPath [(e, StartStop a)]
rest
      mkPath [(e, StartStop a)]
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid top path."
    parseSlice :: Value -> Parser (StartStop slc)
parseSlice = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Slice" forall a b. (a -> b) -> a -> b
$ \Object
v -> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"notes"
    parseTrans :: Value -> Parser tr
parseTrans = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Transition" forall a b. (a -> b) -> a -> b
$ \Object
v -> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"edges"
    parseSegment :: Value -> Parser (tr, StartStop slc)
parseSegment = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Segment" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
      tr
trans <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"trans" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser tr
parseTrans
      StartStop slc
rslice <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"rslice" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser (StartStop slc)
parseSlice
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (tr
trans, StartStop slc
rslice)

-- | Prints the steps and intermediate configurations of a derivation.
debugAnalysis
  :: forall tr slc s f h
   . (Show tr, Show slc, Show s, Show h)
  => (s -> tr -> Either String (tr, slc, tr))
  -> (f -> tr -> Either String tr)
  -> (h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr))
  -> Analysis s f h tr slc
  -> IO (Either String ())
debugAnalysis :: forall tr slc s f h.
(Show tr, Show slc, Show s, Show h) =>
(s -> tr -> Either String (tr, slc, tr))
-> (f -> tr -> Either String tr)
-> (h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr))
-> Analysis s f h tr slc
-> IO (Either String ())
debugAnalysis s -> tr -> Either String (tr, slc, tr)
doSplit f -> tr -> Either String tr
doFreeze h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr)
doSpread (Analysis [Leftmost s f h]
deriv Path tr slc
top) =
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
    StartStop slc
-> Path tr slc -> Bool -> [Leftmost s f h] -> ExceptT String IO ()
go forall a. StartStop a
Start Path tr slc
top Bool
False [Leftmost s f h]
deriv
 where
  go
    :: StartStop slc
    -> Path tr slc
    -> Bool
    -> [Leftmost s f h]
    -> ExceptT String IO ()
  go :: StartStop slc
-> Path tr slc -> Bool -> [Leftmost s f h] -> ExceptT String IO ()
go StartStop slc
_sl Path tr slc
_surface Bool
_ars [] = forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"Derivation incomplete."
  go StartStop slc
sl surface :: Path tr slc
surface@(PathEnd tr
trans) Bool
_ars (Leftmost s f h
op : [Leftmost s f h]
rest) = do
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"\nCurrent surface: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Path tr slc
surface
    case Leftmost s f h
op of
      LMSingle LeftmostSingle s f
single -> do
        -- debugSingleStep (sl, trans, Stop) single
        case LeftmostSingle s f
single of
          LMSingleFreeze f
freezeOp -> do
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"freezing only (terminating)"
            tr
_ <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ f -> tr -> Either String tr
doFreeze f
freezeOp tr
trans
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          LMSingleSplit s
splitOp -> do
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"splitting only: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show s
splitOp
            (tr
ctl, slc
cs, tr
ctr) <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ s -> tr -> Either String (tr, slc, tr)
doSplit s
splitOp tr
trans
            StartStop slc
-> Path tr slc -> Bool -> [Leftmost s f h] -> ExceptT String IO ()
go StartStop slc
sl (forall around between.
around -> between -> Path around between -> Path around between
Path tr
ctl slc
cs (forall around between. around -> Path around between
PathEnd tr
ctr)) Bool
False [Leftmost s f h]
rest
      LMDouble LeftmostDouble s f h
_ -> forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"Double operation on single transition."
  go StartStop slc
sl surface :: Path tr slc
surface@(Path tr
tl slc
sm (PathEnd tr
tr)) Bool
ars (Leftmost s f h
op : [Leftmost s f h]
rest) = do
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"\nCurrent surface: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Path tr slc
surface
    Leftmost s f h
-> [Leftmost s f h]
-> Bool
-> (StartStop slc, tr, slc, tr, StartStop slc)
-> (tr -> Path tr slc)
-> ExceptT String IO ()
goDouble Leftmost s f h
op [Leftmost s f h]
rest Bool
ars (StartStop slc
sl, tr
tl, slc
sm, tr
tr, forall a. StartStop a
Stop) forall around between. around -> Path around between
PathEnd
  go StartStop slc
sl surface :: Path tr slc
surface@(Path tr
tl slc
sm (Path tr
tr slc
sr Path tr slc
pathRest)) Bool
ars (Leftmost s f h
op : [Leftmost s f h]
derivRest) = do
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"\nCurrent surface: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Path tr slc
surface
    Leftmost s f h
-> [Leftmost s f h]
-> Bool
-> (StartStop slc, tr, slc, tr, StartStop slc)
-> (tr -> Path tr slc)
-> ExceptT String IO ()
goDouble Leftmost s f h
op [Leftmost s f h]
derivRest Bool
ars (StartStop slc
sl, tr
tl, slc
sm, tr
tr, forall a. a -> StartStop a
Inner slc
sr) forall a b. (a -> b) -> a -> b
$
      \tr
tr' -> forall around between.
around -> between -> Path around between -> Path around between
Path tr
tr' slc
sr Path tr slc
pathRest

  goDouble :: Leftmost s f h
-> [Leftmost s f h]
-> Bool
-> (StartStop slc, tr, slc, tr, StartStop slc)
-> (tr -> Path tr slc)
-> ExceptT String IO ()
goDouble Leftmost s f h
op [Leftmost s f h]
rest Bool
ars (StartStop slc
sl, tr
tl, slc
sm, tr
tr, StartStop slc
_sr) tr -> Path tr slc
mkRest = case Leftmost s f h
op of
    LMSingle LeftmostSingle s f
_ ->
      forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"Single operation with several transitions left."
    LMDouble LeftmostDouble s f h
double -> do
      -- observeDoubleStep (sl, tl, sm, tr, sr) ars double
      case LeftmostDouble s f h
double of
        LMDoubleFreezeLeft f
freezeOp -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ars forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"FreezeLeft after SplitRight."
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"freezing left"
          tr
_ <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ f -> tr -> Either String tr
doFreeze f
freezeOp tr
tl
          StartStop slc
-> Path tr slc -> Bool -> [Leftmost s f h] -> ExceptT String IO ()
go (forall a. a -> StartStop a
Inner slc
sm) (tr -> Path tr slc
mkRest tr
tr) Bool
False [Leftmost s f h]
rest
        LMDoubleSplitLeft s
splitOp -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ars forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"SplitLeft after SplitRight."
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"splitting left: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show s
splitOp
          (tr
ctl, slc
cs, tr
ctr) <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ s -> tr -> Either String (tr, slc, tr)
doSplit s
splitOp tr
tl
          StartStop slc
-> Path tr slc -> Bool -> [Leftmost s f h] -> ExceptT String IO ()
go StartStop slc
sl (forall around between.
around -> between -> Path around between -> Path around between
Path tr
ctl slc
cs forall a b. (a -> b) -> a -> b
$ forall around between.
around -> between -> Path around between -> Path around between
Path tr
ctr slc
sm forall a b. (a -> b) -> a -> b
$ tr -> Path tr slc
mkRest tr
tr) Bool
False [Leftmost s f h]
rest
        LMDoubleSplitRight s
splitOp -> do
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"splitting right: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show s
splitOp
          (tr
ctl, slc
cs, tr
ctr) <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ s -> tr -> Either String (tr, slc, tr)
doSplit s
splitOp tr
tr
          StartStop slc
-> Path tr slc -> Bool -> [Leftmost s f h] -> ExceptT String IO ()
go StartStop slc
sl (forall around between.
around -> between -> Path around between -> Path around between
Path tr
tl slc
sm forall a b. (a -> b) -> a -> b
$ forall around between.
around -> between -> Path around between -> Path around between
Path tr
ctl slc
cs forall a b. (a -> b) -> a -> b
$ tr -> Path tr slc
mkRest tr
ctr) Bool
True [Leftmost s f h]
rest
        LMDoubleSpread h
spreadOp -> do
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"spreading: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show h
spreadOp
          (tr
ctl, slc
csl, tr
ctm, slc
csr, tr
ctr) <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ h -> tr -> slc -> tr -> Either String (tr, slc, tr, slc, tr)
doSpread h
spreadOp tr
tl slc
sm tr
tr
          StartStop slc
-> Path tr slc -> Bool -> [Leftmost s f h] -> ExceptT String IO ()
go StartStop slc
sl (forall around between.
around -> between -> Path around between -> Path around between
Path tr
ctl slc
csl forall a b. (a -> b) -> a -> b
$ forall around between.
around -> between -> Path around between -> Path around between
Path tr
ctm slc
csr forall a b. (a -> b) -> a -> b
$ tr -> Path tr slc
mkRest tr
ctr) Bool
False [Leftmost s f h]
rest

-- evaluators
-- ==========

{- | Create a leftmost evaluator from position-independent evaluation functions
 that just return spread, split, and freeze operations
 by wrapping those into the appropriate 'Leftmost' constructors.
-}
mkLeftmostEval
  :: UnspreadMiddle tr slc h
  -> UnspreadLeft tr slc
  -> UnspreadRight tr slc
  -> (StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)])
  -> (StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)])
  -> (slc' -> slc)
  -> Eval tr tr' slc slc' (Leftmost s f h)
mkLeftmostEval :: forall tr slc h s tr' f slc'.
UnspreadMiddle tr slc h
-> UnspreadLeft tr slc
-> UnspreadRight tr slc
-> (StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)])
-> (StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' (Leftmost s f h)
mkLeftmostEval UnspreadMiddle tr slc h
unspreadm UnspreadLeft tr slc
unspreadl UnspreadRight tr slc
unspreadr StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)]
unsplit StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)]
uf =
  forall tr tr' slc slc' v.
UnspreadMiddle tr slc v
-> UnspreadLeft tr slc
-> UnspreadRight tr slc
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' v
Eval
    (slc, tr, slc) -> Maybe (slc, Leftmost s f h)
unspreadm'
    UnspreadLeft tr slc
unspreadl
    UnspreadRight tr slc
unspreadr
    StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> SplitType
-> [(tr, Leftmost s f h)]
unsplit'
    StartStop slc
-> Maybe tr' -> StartStop slc -> Bool -> [(tr, Leftmost s f h)]
uf'
 where
  smap :: (b -> c) -> f (p a b) -> f (p a c)
smap b -> c
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second b -> c
f)
  -- vm' :: UnspreadMiddle e a (Leftmost s f h)
  unspreadm' :: (slc, tr, slc) -> Maybe (slc, Leftmost s f h)
unspreadm' (slc, tr, slc)
vert = forall {f :: * -> *} {p :: * -> * -> *} {b} {c} {a}.
(Functor f, Bifunctor p) =>
(b -> c) -> f (p a b) -> f (p a c)
smap forall h s f. h -> Leftmost s f h
LMSpread forall a b. (a -> b) -> a -> b
$ UnspreadMiddle tr slc h
unspreadm (slc, tr, slc)
vert
  unsplit' :: StartStop slc
-> tr
-> slc
-> tr
-> StartStop slc
-> SplitType
-> [(tr, Leftmost s f h)]
unsplit' StartStop slc
sl tr
tl slc
sm tr
tr StartStop slc
sr SplitType
typ = forall {f :: * -> *} {p :: * -> * -> *} {b} {c} {a}.
(Functor f, Bifunctor p) =>
(b -> c) -> f (p a b) -> f (p a c)
smap s -> Leftmost s f h
splitop [(tr, s)]
res
   where
    res :: [(tr, s)]
res = StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)]
unsplit StartStop slc
sl tr
tl slc
sm tr
tr StartStop slc
sr
    splitop :: s -> Leftmost s f h
splitop = case SplitType
typ of
      SplitType
LeftOfTwo -> forall s f h. s -> Leftmost s f h
LMSplitLeft
      SplitType
SingleOfOne -> forall s f h. s -> Leftmost s f h
LMSplitOnly
      SplitType
RightOfTwo -> forall s f h. s -> Leftmost s f h
LMSplitRight
  uf' :: StartStop slc
-> Maybe tr' -> StartStop slc -> Bool -> [(tr, Leftmost s f h)]
uf' StartStop slc
sl Maybe tr'
e StartStop slc
sr Bool
isLast
    | Bool
isLast = forall {f :: * -> *} {p :: * -> * -> *} {b} {c} {a}.
(Functor f, Bifunctor p) =>
(b -> c) -> f (p a b) -> f (p a c)
smap forall f s h. f -> Leftmost s f h
LMFreezeOnly [(tr, f)]
res
    | Bool
otherwise = forall {f :: * -> *} {p :: * -> * -> *} {b} {c} {a}.
(Functor f, Bifunctor p) =>
(b -> c) -> f (p a b) -> f (p a c)
smap forall f s h. f -> Leftmost s f h
LMFreezeLeft [(tr, f)]
res
   where
    res :: [(tr, f)]
res = StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)]
uf StartStop slc
sl Maybe tr'
e StartStop slc
sr

-- manually constructing derivations
-- =================================

{- $monadicdoc

 Use these functions to manually build a derivation,
 checking leftmost-correctness in the type.
 A good way to do this is to start a derivation using `buildDerivation` or `buildPartialDerivation`
 and follow up with a @do@ block that contains a sequence of `split`,
 `freeze`, `splitRight` and `spread` actions..

 > deriv :: [Leftmost () () ()] -- using unit for each operation type
 > deriv = buildDerivation $ do -- start with 1 transition
 >   split ()      -- (2 open transitions)
 >   splitRight () -- (3 open)
 >   spread ()     -- (4 open)
 >   freeze ()     -- (3 open)
 >   split ()      -- (4 open)
 >   freeze ()     -- (3 open)
 >   freeze ()     -- (2 open)
 >   freeze ()     -- (1 open)
 >   freeze ()     -- (0 open, end of derivation)

 The above example results in the following derivation graph:

 ![derivation of the above example](doc-images/monadic-deriv.svg)

 Since 'PartialDerivation' is an indexed monad
 (it's exact type changes between actions),
 using do-notation requires you to rebind its syntax to use indexed versions of '>>=' and '>>'
 using the @QualifiedDo@ extension.
 The easiest way to do use the generic operators from "Language.Haskell.DoNotation"
 by using this module as the @do@ qualifier:

 > import qualified Language.Haskell.DoNotation as Do
 >
 > deriv = buildDerivation $ Do.do -- requires -XQualifiedDo
 >   split ()
 >   ...
-}

{- | A wrapper around leftmost derivations
 that tracks information about the derivation state in the type.
 Number of open transitions: @openTrans@.
 Whether a right split has been performed at the current point: @afterRightSplit@.
-}
newtype PartialDerivation s f h (openTrans :: Nat) (afterRightSplit :: Bool) = PD {forall s f h (openTrans :: Nat) (afterRightSplit :: Bool).
PartialDerivation s f h openTrans afterRightSplit
-> [Leftmost s f h]
runPD :: [Leftmost s f h]}

{- | An "indexed" version of a writer monad, i.e. one where the monad type between two steps can change.
 This can be used for tracking the number of open transitions in a derivation on the type level
 while still providing an monadic interface for constructing a derivation.
-}
newtype IndexedWriter w i j a = IW {forall {k} {k} w (i :: k) (j :: k) a.
IndexedWriter w i j a -> Writer w a
runIW :: MW.Writer w a}

instance MI.IxFunctor (IndexedWriter w) where
  imap :: forall a b (j :: k) (k2 :: k1).
(a -> b) -> IndexedWriter w j k2 a -> IndexedWriter w j k2 b
imap a -> b
f (IW Writer w a
w) = forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW forall a b. (a -> b) -> a -> b
$ a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Writer w a
w

instance (Monoid w) => MI.IxPointed (IndexedWriter w) where
  ireturn :: forall a (i :: k). a -> IndexedWriter w i i a
ireturn a
a = forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return a
a

instance (Monoid w) => MI.IxApplicative (IndexedWriter w) where
  iap :: forall (i :: k) (j :: k) a b (k1 :: k).
IndexedWriter w i j (a -> b)
-> IndexedWriter w j k1 a -> IndexedWriter w i k1 b
iap (IW Writer w (a -> b)
wf) (IW Writer w a
wa) = forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW (Writer w (a -> b)
wf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Writer w a
wa)

instance (Monoid w) => MI.IxMonad (IndexedWriter w) where
  ibind :: forall a (j :: k) (k1 :: k) b (i :: k).
(a -> IndexedWriter w j k1 b)
-> IndexedWriter w i j a -> IndexedWriter w i k1 b
ibind a -> IndexedWriter w j k1 b
f (IW Writer w a
wa) = forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW forall a b. (a -> b) -> a -> b
$ (forall {k} {k} w (i :: k) (j :: k) a.
IndexedWriter w i j a -> Writer w a
runIW forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IndexedWriter w j k1 b
f) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Writer w a
wa

-- | 'MW.tell' for 'IndexedWriter'.
itell :: Monoid w => w -> IndexedWriter w i j ()
itell :: forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell = forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
MW.tell

{- | A type-level wrapper for partial derivation info.
 Encodes the number of open transitions
 and whether the last operation was a right split.
-}
type DerivationInfo :: Nat -> Bool -> Type
data DerivationInfo a b

{- | The type of a monadic derivation action that modifies the derivation state
 (number of open transitions, after right split).
-}
type DerivationAction s f h n n' afterRight afterRight' =
  IndexedWriter
    [Leftmost s f h]
    (DerivationInfo n afterRight)
    (DerivationInfo n' afterRight')
    ()

{- | Turn a monadically constructed derivation into a proper left-most derivation.
 This function assumes the derivation to start with a single transition.
-}
buildDerivation
  -- :: (PartialDeriv s f h 1 False -> PartialDeriv s f h n snd)
  :: DerivationAction s f h 1 n 'False snd -> [Leftmost s f h]
buildDerivation :: forall s f h (n :: Nat) (snd :: Bool).
DerivationAction s f h 1 n 'False snd -> [Leftmost s f h]
buildDerivation DerivationAction s f h 1 n 'False snd
build = forall w a. Writer w a -> w
MW.execWriter forall a b. (a -> b) -> a -> b
$ forall {k} {k} w (i :: k) (j :: k) a.
IndexedWriter w i j a -> Writer w a
runIW DerivationAction s f h 1 n 'False snd
build

{- | Turn a monadically constructed partial derivation into a left-most derivation.
 This function does not restrict the number of transitions in the starting configuration.
-}
buildPartialDerivation
  :: forall n n' snd s f h
   . DerivationAction s f h n n' 'False snd
  -> [Leftmost s f h]
buildPartialDerivation :: forall (n :: Nat) (n' :: Nat) (snd :: Bool) s f h.
DerivationAction s f h n n' 'False snd -> [Leftmost s f h]
buildPartialDerivation DerivationAction s f h n n' 'False snd
build = forall w a. Writer w a -> w
MW.execWriter forall a b. (a -> b) -> a -> b
$ forall {k} {k} w (i :: k) (j :: k) a.
IndexedWriter w i j a -> Writer w a
runIW DerivationAction s f h n n' 'False snd
build

-- | Turn a split operation into a monadic (left or single) split action.
split
  :: forall n s f h
   . (KnownNat n, 1 <= n)
  => s
  -> DerivationAction s f h n (n + 1) 'False 'False
split :: forall (n :: Nat) s f h.
(KnownNat n, 1 <= n) =>
s -> DerivationAction s f h n (n + 1) 'False 'False
split s
s
  | forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n) forall a. Eq a => a -> a -> Bool
== Nat
1 = forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [forall s f h. s -> Leftmost s f h
LMSplitOnly s
s]
  | Bool
otherwise = forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [forall s f h. s -> Leftmost s f h
LMSplitLeft s
s]

-- | Turn a freeze operation into a monadic (left or single) freeze action.
freeze
  :: forall n s h f
   . (KnownNat n, 1 <= n)
  => f
  -> DerivationAction s f h n (n - 1) 'False 'False
freeze :: forall (n :: Nat) s h f.
(KnownNat n, 1 <= n) =>
f -> DerivationAction s f h n (n - 1) 'False 'False
freeze f
f
  | forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n) forall a. Eq a => a -> a -> Bool
== Nat
1 = forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [forall f s h. f -> Leftmost s f h
LMFreezeOnly f
f]
  | Bool
otherwise = forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [forall f s h. f -> Leftmost s f h
LMFreezeLeft f
f]

-- | Turn a split operation into a monadic right-split action.
splitRight :: (2 <= n) => s -> DerivationAction s f h n (n + 1) snd 'True
splitRight :: forall (n :: Nat) s f h (snd :: Bool).
(2 <= n) =>
s -> DerivationAction s f h n (n + 1) snd 'True
splitRight s
s = forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [forall s f h. s -> Leftmost s f h
LMSplitRight s
s]

-- | Turn a spread operation into a monadic spread action.
spread :: (2 <= n) => h -> DerivationAction s f h n (n + 1) snd 'False
spread :: forall (n :: Nat) h s f (snd :: Bool).
(2 <= n) =>
h -> DerivationAction s f h n (n + 1) snd 'False
spread h
h = forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [forall h s f. h -> Leftmost s f h
LMSpread h
h]

-- useful semirings
-- ================

{- | The derivations semiring.
 Similar to a free semiring, encodes sequences, alternatives, and neutral values directly.
 However, semiring equivalences are not idendified by default.
-}
data Derivations a
  = -- | a single operation
    Do !a
  | -- | combines alternative derivations
    Or !(Derivations a) !(Derivations a)
  | -- | combines sequential derivations
    Then !(Derivations a) !(Derivations a)
  | -- | the neutral element to 'Then'
    NoOp
  | -- | the neutral element to 'Or'
    Cannot
  deriving (Derivations a -> Derivations a -> Bool
forall a. Eq a => Derivations a -> Derivations a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Derivations a -> Derivations a -> Bool
$c/= :: forall a. Eq a => Derivations a -> Derivations a -> Bool
== :: Derivations a -> Derivations a -> Bool
$c== :: forall a. Eq a => Derivations a -> Derivations a -> Bool
Eq, Derivations a -> Derivations a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Derivations a)
forall a. Ord a => Derivations a -> Derivations a -> Bool
forall a. Ord a => Derivations a -> Derivations a -> Ordering
forall a. Ord a => Derivations a -> Derivations a -> Derivations a
min :: Derivations a -> Derivations a -> Derivations a
$cmin :: forall a. Ord a => Derivations a -> Derivations a -> Derivations a
max :: Derivations a -> Derivations a -> Derivations a
$cmax :: forall a. Ord a => Derivations a -> Derivations a -> Derivations a
>= :: Derivations a -> Derivations a -> Bool
$c>= :: forall a. Ord a => Derivations a -> Derivations a -> Bool
> :: Derivations a -> Derivations a -> Bool
$c> :: forall a. Ord a => Derivations a -> Derivations a -> Bool
<= :: Derivations a -> Derivations a -> Bool
$c<= :: forall a. Ord a => Derivations a -> Derivations a -> Bool
< :: Derivations a -> Derivations a -> Bool
$c< :: forall a. Ord a => Derivations a -> Derivations a -> Bool
compare :: Derivations a -> Derivations a -> Ordering
$ccompare :: forall a. Ord a => Derivations a -> Derivations a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Derivations a) x -> Derivations a
forall a x. Derivations a -> Rep (Derivations a) x
$cto :: forall a x. Rep (Derivations a) x -> Derivations a
$cfrom :: forall a x. Derivations a -> Rep (Derivations a) x
Generic)

instance NFData a => NFData (Derivations a)

-- | A helper tag for pretty-printing derivations.
data DerivOp
  = OpNone
  | OpOr
  | OpThen
  deriving (DerivOp -> DerivOp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DerivOp -> DerivOp -> Bool
$c/= :: DerivOp -> DerivOp -> Bool
== :: DerivOp -> DerivOp -> Bool
$c== :: DerivOp -> DerivOp -> Bool
Eq)

instance Show a => Show (Derivations a) where
  show :: Derivations a -> String
show = forall {b} {a}.
(Integral b, Show a) =>
b -> DerivOp -> Derivations a -> String
go (Int
0 :: Int) DerivOp
OpNone
   where
    indent :: b -> a
indent b
n = forall b a. (Integral b, Monoid a) => b -> a -> a
stimesMonoid b
n a
"  "
    go :: b -> DerivOp -> Derivations a -> String
go b
n DerivOp
_ (Do a
a) = forall {b} {a}. (Integral b, Monoid a, IsString a) => b -> a
indent b
n forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
a
    go b
n DerivOp
_ Derivations a
NoOp = forall {b} {a}. (Integral b, Monoid a, IsString a) => b -> a
indent b
n forall a. Semigroup a => a -> a -> a
<> String
"NoOp"
    go b
n DerivOp
_ Derivations a
Cannot = forall {b} {a}. (Integral b, Monoid a, IsString a) => b -> a
indent b
n forall a. Semigroup a => a -> a -> a
<> String
"Cannot"
    go b
n DerivOp
OpOr (Or Derivations a
a Derivations a
b) = b -> DerivOp -> Derivations a -> String
go b
n DerivOp
OpOr Derivations a
a forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> b -> DerivOp -> Derivations a -> String
go b
n DerivOp
OpOr Derivations a
b
    go b
n DerivOp
_ (Or Derivations a
a Derivations a
b) =
      forall {b} {a}. (Integral b, Monoid a, IsString a) => b -> a
indent b
n forall a. Semigroup a => a -> a -> a
<> String
"Or\n" forall a. Semigroup a => a -> a -> a
<> b -> DerivOp -> Derivations a -> String
go (b
n forall a. Num a => a -> a -> a
+ b
1) DerivOp
OpOr Derivations a
a forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> b -> DerivOp -> Derivations a -> String
go (b
n forall a. Num a => a -> a -> a
+ b
1) DerivOp
OpOr Derivations a
b
    go b
n DerivOp
OpThen (Then Derivations a
a Derivations a
b) = b -> DerivOp -> Derivations a -> String
go b
n DerivOp
OpThen Derivations a
a forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> b -> DerivOp -> Derivations a -> String
go b
n DerivOp
OpThen Derivations a
b
    go b
n DerivOp
_ (Then Derivations a
a Derivations a
b) =
      forall {b} {a}. (Integral b, Monoid a, IsString a) => b -> a
indent b
n forall a. Semigroup a => a -> a -> a
<> String
"Then\n" forall a. Semigroup a => a -> a -> a
<> b -> DerivOp -> Derivations a -> String
go (b
n forall a. Num a => a -> a -> a
+ b
1) DerivOp
OpThen Derivations a
a forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> b -> DerivOp -> Derivations a -> String
go (b
n forall a. Num a => a -> a -> a
+ b
1) DerivOp
OpThen Derivations a
b

instance R.Semiring (Derivations a) where
  zero :: Derivations a
zero = forall a. Derivations a
Cannot
  one :: Derivations a
one = forall a. Derivations a
NoOp
  plus :: Derivations a -> Derivations a -> Derivations a
plus Derivations a
Cannot Derivations a
a = Derivations a
a
  plus Derivations a
a Derivations a
Cannot = Derivations a
a
  plus Derivations a
a Derivations a
b = forall a. Derivations a -> Derivations a -> Derivations a
Or Derivations a
a Derivations a
b
  times :: Derivations a -> Derivations a -> Derivations a
times Derivations a
Cannot Derivations a
_ = forall a. Derivations a
Cannot
  times Derivations a
_ Derivations a
Cannot = forall a. Derivations a
Cannot
  times Derivations a
NoOp Derivations a
a = Derivations a
a
  times Derivations a
a Derivations a
NoOp = Derivations a
a
  times Derivations a
a Derivations a
b = forall a. Derivations a -> Derivations a -> Derivations a
Then Derivations a
a Derivations a
b

-- | Map the 'Derivations' semiring to another semiring.
mapDerivations :: (R.Semiring r) => (a -> r) -> Derivations a -> r
mapDerivations :: forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations a -> r
f (Do a
a) = a -> r
f a
a
mapDerivations a -> r
_ Derivations a
NoOp = forall a. Semiring a => a
R.one
mapDerivations a -> r
_ Derivations a
Cannot = forall a. Semiring a => a
R.zero
mapDerivations a -> r
f (Or Derivations a
a Derivations a
b) = forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations a -> r
f Derivations a
a forall a. Semiring a => a -> a -> a
R.+ forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations a -> r
f Derivations a
b
mapDerivations a -> r
f (Then Derivations a
a Derivations a
b) = forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations a -> r
f Derivations a
a forall a. Semiring a => a -> a -> a
R.* forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations a -> r
f Derivations a
b

-- | Flatten the prefix-tree structure of 'Derivations' into a simple set of derivations.
flattenDerivations :: Ord a => Derivations a -> S.Set [a]
flattenDerivations :: forall a. Ord a => Derivations a -> Set [a]
flattenDerivations = forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations (\a
a -> forall a. a -> Set a
S.singleton [a
a])

{- | Flatten the prefix-tree structure of 'Derivations'
 into a simple list of (potentially redundant) derivations.
-}
flattenDerivationsRed :: Ord a => Derivations a -> [[a]]
flattenDerivationsRed :: forall a. Ord a => Derivations a -> [[a]]
flattenDerivationsRed (Do a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure [a
a]
flattenDerivationsRed Derivations a
NoOp = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
flattenDerivationsRed Derivations a
Cannot = []
flattenDerivationsRed (Or Derivations a
a Derivations a
b) =
  forall a. Ord a => Derivations a -> [[a]]
flattenDerivationsRed Derivations a
a forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => Derivations a -> [[a]]
flattenDerivationsRed Derivations a
b
flattenDerivationsRed (Then Derivations a
a Derivations a
b) = do
  [a]
as <- forall a. Ord a => Derivations a -> [[a]]
flattenDerivationsRed Derivations a
a
  [a]
bs <- forall a. Ord a => Derivations a -> [[a]]
flattenDerivationsRed Derivations a
b
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
as forall a. Semigroup a => a -> a -> a
<> [a]
bs)

-- | Obtain the first derivation from a 'Derivations' tree.
firstDerivation :: Ord a => Derivations a -> Maybe [a]
firstDerivation :: forall a. Ord a => Derivations a -> Maybe [a]
firstDerivation Derivations a
Cannot = forall a. Maybe a
Nothing
firstDerivation Derivations a
NoOp = forall a. a -> Maybe a
Just []
firstDerivation (Do a
a) = forall a. a -> Maybe a
Just [a
a]
firstDerivation (Or Derivations a
a Derivations a
_) = forall a. Ord a => Derivations a -> Maybe [a]
firstDerivation Derivations a
a
firstDerivation (Then Derivations a
a Derivations a
b) = do
  [a]
da <- forall a. Ord a => Derivations a -> Maybe [a]
firstDerivation Derivations a
a
  [a]
db <- forall a. Ord a => Derivations a -> Maybe [a]
firstDerivation Derivations a
b
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [a]
da forall a. Semigroup a => a -> a -> a
<> [a]
db

-- utilities
-- =========

-- | The global trace level. Only trace messages >= this level are shown.
traceLevel :: Int
traceLevel :: Int
traceLevel = Int
0

-- | A helper for conditionally tracing a message.
traceIf :: Int -> [Char] -> Bool -> Bool
traceIf :: Int -> String -> Bool -> Bool
traceIf Int
l String
msg Bool
value =
  if Int
traceLevel forall a. Ord a => a -> a -> Bool
>= Int
l Bool -> Bool -> Bool
&& Bool
value then forall a. String -> a -> a
trace String
msg Bool
value else Bool
value

-- toVariant :: ToJSON a => T.Text -> a -> Aeson.Value
-- toVariant typ val = Aeson.object ["type" .= typ, "value" .= val]

-- toVariantEnc :: (ToJSON a) => T.Text -> a -> Aeson.Encoding
-- toVariantEnc typ val = Aeson.pairs ("type" .= typ <> "value" .= val)

-- | Lowercase the first character in a string.
firstToLower :: String -> String
firstToLower :: ShowS
firstToLower String
"" = String
""
firstToLower (Char
h : String
rest) = Char -> Char
toLower Char
h forall a. a -> [a] -> [a]
: String
rest

-- | Aeson options for parsing "variant" types (generated in PureScript)
variantDefaults :: (String -> String) -> Aeson.Options
variantDefaults :: ShowS -> Options
variantDefaults ShowS
rename =
  Options
Aeson.defaultOptions
    { constructorTagModifier :: ShowS
Aeson.constructorTagModifier = ShowS
rename
    , sumEncoding :: SumEncoding
Aeson.sumEncoding = String -> String -> SumEncoding
Aeson.TaggedObject String
"type" String
"value"
    }

-- | Convert special characters to TeX commands.
showTex :: Show a => a -> String
showTex :: forall a. Show a => a -> String
showTex a
x = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeTex forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
x
 where
  escapeTex :: Char -> String
escapeTex Char
'♭' = String
"$\\flat$"
  escapeTex Char
'♯' = String
"$\\sharp$"
  escapeTex Char
'{' = String
"\\{"
  escapeTex Char
'}' = String
"\\}"
  escapeTex Char
'⋉' = String
"$\\ltimes$"
  escapeTex Char
'⋊' = String
"$\\rtimes$"
  escapeTex Char
c = [Char
c]

-- | Convert special characters to TeX commands (using 'T.Text')
showTexT :: Show a => a -> T.Text
showTexT :: forall a. Show a => a -> Text
showTexT = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
showTex