{-# 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
  , pathTake

    -- * 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#
  , cartProd
  , traverseSet
  , variantDefaults
  , firstToLower
  , 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.HashSet qualified as HS
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.String (IsString (..))
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
(Path around between -> Path around between -> Bool)
-> (Path around between -> Path around between -> Bool)
-> Eq (Path around between)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall around between.
(Eq between, Eq around) =>
Path around between -> Path around between -> Bool
$c== :: forall around between.
(Eq between, Eq around) =>
Path around between -> Path around between -> Bool
== :: Path around between -> Path around between -> Bool
$c/= :: forall around between.
(Eq between, Eq around) =>
Path around between -> Path around between -> Bool
/= :: Path around between -> Path around between -> Bool
Eq, Eq (Path around between)
Eq (Path around between) =>
(Path around between -> Path around between -> Ordering)
-> (Path around between -> Path around between -> Bool)
-> (Path around between -> Path around between -> Bool)
-> (Path around between -> Path around between -> Bool)
-> (Path around between -> Path around between -> Bool)
-> (Path around between
    -> Path around between -> Path around between)
-> (Path around between
    -> Path around between -> Path around between)
-> Ord (Path around between)
Path around between -> Path around between -> Bool
Path around between -> Path around between -> Ordering
Path around between -> Path around between -> Path around between
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 between, Ord around) =>
Eq (Path around between)
forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Bool
forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Ordering
forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Path around between
$ccompare :: forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Ordering
compare :: Path around between -> Path around between -> Ordering
$c< :: forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Bool
< :: Path around between -> Path around between -> Bool
$c<= :: forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Bool
<= :: Path around between -> Path around between -> Bool
$c> :: forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Bool
> :: Path around between -> Path around between -> Bool
$c>= :: forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Bool
>= :: Path around between -> Path around between -> Bool
$cmax :: forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Path around between
max :: Path around between -> Path around between -> Path around between
$cmin :: forall around between.
(Ord between, Ord around) =>
Path around between -> Path around between -> Path around between
min :: Path around between -> Path around between -> Path around between
Ord, (forall x. Path around between -> Rep (Path around between) x)
-> (forall x. Rep (Path around between) x -> Path around between)
-> Generic (Path around between)
forall x. Rep (Path around between) x -> Path around between
forall x. Path around between -> Rep (Path around between) x
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
$cfrom :: forall around between x.
Path around between -> Rep (Path around between) x
from :: forall x. Path around between -> Rep (Path around between) x
$cto :: forall around between x.
Rep (Path around between) x -> Path around between
to :: forall x. Rep (Path around between) x -> Path around between
Generic, (forall a b. (a -> b) -> Path around a -> Path around b)
-> (forall a b. a -> Path around b -> Path around a)
-> Functor (Path around)
forall a b. a -> Path around b -> Path around a
forall a b. (a -> b) -> Path around a -> Path around b
forall around a b. a -> Path around b -> Path around a
forall around a b. (a -> b) -> Path around a -> Path around b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall around a b. (a -> b) -> Path around a -> Path around b
fmap :: forall a b. (a -> b) -> Path around a -> Path around b
$c<$ :: forall around a b. a -> Path around b -> Path around a
<$ :: forall a b. a -> Path around b -> Path around a
Functor)

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) = b -> Path b d
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) = b -> d -> Path b d -> Path b d
forall around between.
around -> between -> Path around between -> Path around between
Path (a -> b
fa a
a) (c -> d
fb c
b) (Path b d -> Path b d) -> Path b d -> Path b d
forall a b. (a -> b) -> a -> b
$ (a -> b) -> (c -> d) -> Path a c -> Path b d
forall a b c d. (a -> b) -> (c -> d) -> Path a c -> Path b d
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) = a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n+-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> b -> String
forall a. Show a => a -> String
show b
b String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path a b -> String
forall a. Show a => a -> String
show Path a b
rst
  show (PathEnd a
a) = a -> String
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) = Path a b -> Int
forall a b. Path a b -> Int
pathLen Path a b
rest Int -> Int -> Int
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' = a -> b -> Path a b -> Path a b
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' = a -> Path a b
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) = a' -> b -> Path a' b -> Path a' b
forall around between.
around -> between -> Path around between -> Path around between
Path (a -> a'
f a
a) b
b (Path a' b -> Path a' b) -> Path a' b -> Path a' b
forall a b. (a -> b) -> a -> b
$ (a -> a') -> Path a b -> Path 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) = a' -> Path a' b
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) =
  a' -> b -> Path a' b -> Path a' b
forall around between.
around -> between -> Path around between -> Path around between
Path (Int -> a -> a'
f Int
i a
a) b
b (Int -> (Int -> a -> a') -> Path a b -> Path a' b
forall a a' b. Int -> (Int -> a -> a') -> Path a b -> Path a' b
mapAroundsWithIndex (Int
i Int -> Int -> Int
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) = a' -> Path a' b
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 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: (a -> b -> a -> c) -> Path a b -> [c]
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 = Path a b -> a
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 -> a -> Path a b
forall around between. around -> Path around between
PathEnd a
end
  Path a
a b
b Path a b
rest -> b -> Path a b -> Path a b -> Path a b
forall {t} {around}.
t -> Path around t -> Path around t -> Path around t
go b
b Path a b
rest (a -> Path a b
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 = around -> t -> Path around t -> Path around t
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 (Path around t -> Path around t) -> Path around t -> Path around t
forall a b. (a -> b) -> a -> b
$ around -> t -> Path around t -> Path around t
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Path a b -> [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 b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Path a b -> [b]
forall a b. Path a b -> [b]
pathBetweens Path a b
rst
pathBetweens Path a b
_ = []

{- | Takes at most @n@ '(a,b')' pairs from the path and returns it as a list,
applying a function over the /betweens/.
The last 'a' in the path (if taken) is paired with the provided @finalb@.
The function @f@ is used to be able to map /betweens/ to a type with a default value.
-}
pathTake :: Int -> (b -> b') -> b' -> Path a b -> [(a, b')]
pathTake :: forall b b' a. Int -> (b -> b') -> b' -> Path a b -> [(a, b')]
pathTake Int
n b -> b'
f b'
finalb Path a b
path = [(a, b')] -> [(a, b')]
forall a. [a] -> [a]
reverse ([(a, b')] -> [(a, b')]) -> [(a, b')] -> [(a, b')]
forall a b. (a -> b) -> a -> b
$ [(a, b')] -> Int -> Path a b -> [(a, b')]
go [] Int
n Path a b
path
 where
  go :: [(a, b')] -> Int -> Path a b -> [(a, b')]
go [(a, b')]
acc Int
0 Path a b
_ = [(a, b')]
acc
  go [(a, b')]
acc Int
_n (PathEnd a
a) = (a
a, b'
finalb) (a, b') -> [(a, b')] -> [(a, b')]
forall a. a -> [a] -> [a]
: [(a, b')]
acc
  go [(a, b')]
acc Int
n (Path a
a b
b Path a b
rst) = [(a, b')] -> Int -> Path a b -> [(a, b')]
go ((a
a, b -> b'
f b
b) (a, b') -> [(a, b')] -> [(a, b')]
forall a. a -> [a] -> [a]
: [(a, b')]
acc) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Path a b
rst

-- 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 (Eq (StartStop a)
Eq (StartStop a) =>
(StartStop a -> StartStop a -> Ordering)
-> (StartStop a -> StartStop a -> Bool)
-> (StartStop a -> StartStop a -> Bool)
-> (StartStop a -> StartStop a -> Bool)
-> (StartStop a -> StartStop a -> Bool)
-> (StartStop a -> StartStop a -> StartStop a)
-> (StartStop a -> StartStop a -> StartStop a)
-> Ord (StartStop a)
StartStop a -> StartStop a -> Bool
StartStop a -> StartStop a -> Ordering
StartStop a -> StartStop a -> StartStop a
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
$ccompare :: forall a. Ord a => StartStop a -> StartStop a -> Ordering
compare :: StartStop a -> StartStop a -> Ordering
$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
>= :: StartStop a -> StartStop a -> Bool
$cmax :: forall a. Ord a => StartStop a -> StartStop a -> StartStop a
max :: StartStop a -> StartStop a -> StartStop a
$cmin :: forall a. Ord a => StartStop a -> StartStop a -> StartStop a
min :: StartStop a -> StartStop a -> StartStop a
Ord, StartStop a -> StartStop a -> Bool
(StartStop a -> StartStop a -> Bool)
-> (StartStop a -> StartStop a -> Bool) -> Eq (StartStop a)
forall a. Eq a => StartStop a -> StartStop a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: StartStop a -> StartStop a -> Bool
Eq, (forall x. StartStop a -> Rep (StartStop a) x)
-> (forall x. Rep (StartStop a) x -> StartStop a)
-> Generic (StartStop a)
forall x. Rep (StartStop a) x -> StartStop a
forall x. StartStop a -> Rep (StartStop a) x
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
$cfrom :: forall a x. StartStop a -> Rep (StartStop a) x
from :: forall x. StartStop a -> Rep (StartStop a) x
$cto :: forall a x. Rep (StartStop a) x -> StartStop a
to :: forall x. Rep (StartStop a) x -> StartStop a
Generic, StartStop a -> ()
(StartStop a -> ()) -> NFData (StartStop a)
forall a. NFData a => StartStop a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => StartStop a -> ()
rnf :: StartStop a -> ()
NFData, Eq (StartStop a)
Eq (StartStop a) =>
(Int -> StartStop a -> Int)
-> (StartStop a -> Int) -> Hashable (StartStop a)
Int -> StartStop a -> Int
StartStop a -> Int
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
$chashWithSalt :: forall a. Hashable a => Int -> StartStop a -> Int
hashWithSalt :: Int -> StartStop a -> Int
$chash :: forall a. Hashable a => StartStop a -> Int
hash :: StartStop a -> Int
Hashable, (forall a b. (a -> b) -> StartStop a -> StartStop b)
-> (forall a b. a -> StartStop b -> StartStop a)
-> Functor StartStop
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
$cfmap :: forall a b. (a -> b) -> StartStop a -> StartStop b
fmap :: forall a b. (a -> b) -> StartStop a -> StartStop b
$c<$ :: forall a b. a -> StartStop b -> StartStop a
<$ :: forall a b. a -> StartStop b -> StartStop a
Functor, (forall m. Monoid m => StartStop m -> m)
-> (forall m a. Monoid m => (a -> m) -> StartStop a -> m)
-> (forall m a. Monoid m => (a -> m) -> StartStop a -> m)
-> (forall a b. (a -> b -> b) -> b -> StartStop a -> b)
-> (forall a b. (a -> b -> b) -> b -> StartStop a -> b)
-> (forall b a. (b -> a -> b) -> b -> StartStop a -> b)
-> (forall b a. (b -> a -> b) -> b -> StartStop a -> b)
-> (forall a. (a -> a -> a) -> StartStop a -> a)
-> (forall a. (a -> a -> a) -> StartStop a -> a)
-> (forall a. StartStop a -> [a])
-> (forall a. StartStop a -> Bool)
-> (forall a. StartStop a -> Int)
-> (forall a. Eq a => a -> StartStop a -> Bool)
-> (forall a. Ord a => StartStop a -> a)
-> (forall a. Ord a => StartStop a -> a)
-> (forall a. Num a => StartStop a -> a)
-> (forall a. Num a => StartStop a -> a)
-> Foldable StartStop
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
$cfold :: forall m. Monoid m => StartStop m -> m
fold :: forall m. Monoid m => StartStop m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> StartStop a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> StartStop a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> StartStop a -> a
foldr1 :: forall a. (a -> a -> a) -> StartStop a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> StartStop a -> a
foldl1 :: forall a. (a -> a -> a) -> StartStop a -> a
$ctoList :: forall a. StartStop a -> [a]
toList :: forall a. StartStop a -> [a]
$cnull :: forall a. StartStop a -> Bool
null :: forall a. StartStop a -> Bool
$clength :: forall a. StartStop a -> Int
length :: forall a. StartStop a -> Int
$celem :: forall a. Eq a => a -> StartStop a -> Bool
elem :: forall a. Eq a => a -> StartStop a -> Bool
$cmaximum :: forall a. Ord a => StartStop a -> a
maximum :: forall a. Ord a => StartStop a -> a
$cminimum :: forall a. Ord a => StartStop a -> a
minimum :: forall a. Ord a => StartStop a -> a
$csum :: forall a. Num a => StartStop a -> a
sum :: forall a. Num a => StartStop a -> a
$cproduct :: forall a. Num a => StartStop a -> a
product :: forall a. Num a => StartStop a -> a
Foldable, Functor StartStop
Foldable StartStop
(Functor StartStop, Foldable StartStop) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> StartStop a -> f (StartStop b))
-> (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 (m :: * -> *) a.
    Monad m =>
    StartStop (m a) -> m (StartStop a))
-> Traversable 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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StartStop a -> f (StartStop b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
StartStop (f a) -> f (StartStop a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
StartStop (f a) -> f (StartStop a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> StartStop a -> m (StartStop b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> StartStop a -> m (StartStop b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
StartStop (m a) -> m (StartStop a)
sequence :: forall (m :: * -> *) a.
Monad m =>
StartStop (m a) -> m (StartStop a)
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) = a -> String
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) = a -> String
forall i. Notation i => i -> String
showNotation a
a
  parseNotation :: ReadP (StartStop a)
parseNotation = ReadP (StartStop a)
forall a. ReadP a
ReadP.pfail

instance (IsString a) => IsString (StartStop a) where
  fromString :: String -> StartStop a
fromString = a -> StartStop a
forall a. a -> StartStop a
Inner (a -> StartStop a) -> (String -> a) -> String -> StartStop a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. IsString a => String -> a
fromString

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

instance (ToJSON a) => ToJSON (StartStop a) where
  toJSON :: StartStop a -> Value
toJSON StartStop a
Start = Text -> Value
Aeson.String Text
"start"
  toJSON StartStop a
Stop = Text -> Value
Aeson.String Text
"stop"
  toJSON (Inner a
a) = a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
a

  toEncoding :: StartStop a -> Encoding
toEncoding StartStop a
Start = Encoding
"start"
  toEncoding StartStop a
Stop = Encoding
"stop"
  toEncoding (Inner a
a) = a -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding a
a

-- 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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [StartStop a] -> [a]
forall a. [StartStop a] -> [a]
onlyInner [StartStop a]
rst
onlyInner (StartStop a
_ : [StartStop a]
rst) = [StartStop a] -> [a]
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) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
getInner StartStop a
_ = Maybe 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) = a -> Either String a
forall a b. b -> Either a b
Right a
a
getInnerE StartStop a
Start = String -> Either String a
forall a b. a -> Either a b
Left String
"expected inner but found ⋊"
getInnerE StartStop a
Stop = String -> Either String a
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 = (StartStop a
forall a. StartStop a
Start, StartStop b
forall a. StartStop a
Start)
distStartStop StartStop (a, b)
Stop = (StartStop a
forall a. StartStop a
Stop, StartStop b
forall a. StartStop a
Stop)
distStartStop (Inner (a
a, b
b)) = (a -> StartStop a
forall a. a -> StartStop a
Inner a
a, b -> StartStop b
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 h v = (slc, tr, slc) -> [(slc, h, 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 h = (tr, slc) -> slc -> h -> [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 h = (slc, tr) -> slc -> h -> [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' h v = Eval
  { forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v -> UnspreadMiddle tr slc h v
evalUnspreadMiddle :: !(UnspreadMiddle tr slc h v)
  , forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v -> UnspreadLeft tr slc h
evalUnspreadLeft :: !(UnspreadLeft tr slc h)
  , forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v -> UnspreadRight tr slc h
evalUnspreadRight :: !(UnspreadRight tr slc h)
  , forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h v -> Unsplit tr slc v
evalUnsplit :: !(Unsplit tr slc v)
  , forall tr tr' slc slc' h v.
Eval tr tr' slc slc' h 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' h v. Eval tr tr' slc slc' h v -> slc' -> slc
evalSlice :: !(slc' -> slc)
  }

-- | Maps a function over all scores produced by the evaluator.
mapEvalScore :: (v -> w) -> Eval tr tr' slc slc' h v -> Eval tr tr' slc slc' h w
mapEvalScore :: forall v w tr tr' slc slc' h.
(v -> w) -> Eval tr tr' slc slc' h v -> Eval tr tr' slc slc' h w
mapEvalScore v -> w
f (Eval UnspreadMiddle tr slc h v
unspreadm UnspreadLeft tr slc h
unspreadl UnspreadRight tr slc h
unspreadr Unsplit tr slc v
unsplit StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)]
uf slc' -> slc
s) =
  UnspreadMiddle tr slc h w
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> Unsplit tr slc w
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, w)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h w
forall tr tr' slc slc' h v.
UnspreadMiddle tr slc h v
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h v
Eval
    UnspreadMiddle tr slc h w
unspreadm'
    UnspreadLeft tr slc h
unspreadl
    UnspreadRight tr slc h
unspreadr
    Unsplit tr slc w
unsplit'
    StartStop slc -> Maybe tr' -> StartStop slc -> Bool -> [(tr, w)]
uf'
    slc' -> slc
s
 where
  unspreadm' :: UnspreadMiddle tr slc h w
unspreadm' = ((slc, h, v) -> (slc, h, w)) -> [(slc, h, v)] -> [(slc, h, w)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((v -> w) -> (slc, h, v) -> (slc, h, w)
forall a b. (a -> b) -> (slc, h, a) -> (slc, h, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> w
f) ([(slc, h, v)] -> [(slc, h, w)])
-> UnspreadMiddle tr slc h v -> UnspreadMiddle tr slc h w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnspreadMiddle tr slc h v
unspreadm
  unsplit' :: Unsplit tr slc w
unsplit' StartStop slc
sl tr
tl slc
sm tr
tr StartStop slc
sr SplitType
typ = (v -> w) -> (tr, v) -> (tr, w)
forall a b. (a -> b) -> (tr, a) -> (tr, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> w
f ((tr, v) -> (tr, w)) -> [(tr, v)] -> [(tr, w)]
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 = (v -> w) -> (tr, v) -> (tr, w)
forall a b. (a -> b) -> (tr, a) -> (tr, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> w
f ((tr, v) -> (tr, w)) -> [(tr, v)] -> [(tr, w)]
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' h1 v1
  -> Eval tr2 tr' slc2 slc' h2 v2
  -> Eval (tr1, tr2) tr' (slc1, slc2) slc' (h1, h2) (v1, v2)
productEval :: forall tr1 tr' slc1 slc' h1 v1 tr2 slc2 h2 v2.
Eval tr1 tr' slc1 slc' h1 v1
-> Eval tr2 tr' slc2 slc' h2 v2
-> Eval (tr1, tr2) tr' (slc1, slc2) slc' (h1, h2) (v1, v2)
productEval (Eval UnspreadMiddle tr1 slc1 h1 v1
unspreadm1 UnspreadLeft tr1 slc1 h1
unspreadl1 UnspreadRight tr1 slc1 h1
unspreadr1 Unsplit tr1 slc1 v1
merge1 StartStop slc1
-> Maybe tr' -> StartStop slc1 -> Bool -> [(tr1, v1)]
thaw1 slc' -> slc1
slice1) (Eval UnspreadMiddle tr2 slc2 h2 v2
unspreadm2 UnspreadLeft tr2 slc2 h2
unspreadl2 UnspreadRight tr2 slc2 h2
unspreadr2 Unsplit tr2 slc2 v2
merge2 StartStop slc2
-> Maybe tr' -> StartStop slc2 -> Bool -> [(tr2, v2)]
thaw2 slc' -> slc2
slice2) =
  UnspreadMiddle (tr1, tr2) (slc1, slc2) (h1, h2) (v1, v2)
-> UnspreadLeft (tr1, tr2) (slc1, slc2) (h1, h2)
-> UnspreadRight (tr1, tr2) (slc1, slc2) (h1, h2)
-> Unsplit (tr1, tr2) (slc1, slc2) (v1, v2)
-> (StartStop (slc1, slc2)
    -> Maybe tr'
    -> StartStop (slc1, slc2)
    -> Bool
    -> [((tr1, tr2), (v1, v2))])
-> (slc' -> (slc1, slc2))
-> Eval (tr1, tr2) tr' (slc1, slc2) slc' (h1, h2) (v1, v2)
forall tr tr' slc slc' h v.
UnspreadMiddle tr slc h v
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h v
Eval UnspreadMiddle (tr1, tr2) (slc1, slc2) (h1, h2) (v1, v2)
unspreadm UnspreadLeft (tr1, tr2) (slc1, slc2) (h1, h2)
unspreadl UnspreadRight (tr1, tr2) (slc1, slc2) (h1, h2)
unspreadr Unsplit (tr1, tr2) (slc1, slc2) (v1, v2)
merge StartStop (slc1, slc2)
-> Maybe tr'
-> StartStop (slc1, slc2)
-> Bool
-> [((tr1, tr2), (v1, v2))]
thaw slc' -> (slc1, slc2)
slice
 where
  unspreadm :: UnspreadMiddle (tr1, tr2) (slc1, slc2) (h1, h2) (v1, v2)
unspreadm ((slc1
l1, slc2
l2), (tr1
m1, tr2
m2), (slc1
r1, slc2
r2)) = do
    (a, ha, va) <- UnspreadMiddle tr1 slc1 h1 v1
unspreadm1 (slc1
l1, tr1
m1, slc1
r1)
    (b, hb, vb) <- unspreadm2 (l2, m2, r2)
    pure ((a, b), (ha, hb), (va, vb))
  unspreadl :: UnspreadLeft (tr1, tr2) (slc1, slc2) (h1, h2)
unspreadl ((tr1
l1, tr2
l2), (slc1
c1, slc2
c2)) (slc1
p1, slc2
p2) (h1
h1, h2
h2) = do
    a <- UnspreadLeft tr1 slc1 h1
unspreadl1 (tr1
l1, slc1
c1) slc1
p1 h1
h1
    b <- unspreadl2 (l2, c2) p2 h2
    pure (a, b)
  unspreadr :: UnspreadRight (tr1, tr2) (slc1, slc2) (h1, h2)
unspreadr ((slc1
c1, slc2
c2), (tr1
r1, tr2
r2)) (slc1
p1, slc2
p2) (h1
h1, h2
h2) = do
    a <- UnspreadRight tr1 slc1 h1
unspreadr1 (slc1
c1, tr1
r1) slc1
p1 h1
h1
    b <- unspreadr2 (c2, r2) p2 h2
    pure (a, b)
  merge :: Unsplit (tr1, tr2) (slc1, slc2) (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
    (a, va) <- Unsplit tr1 slc1 v1
merge1 StartStop slc1
sl1 tr1
tl1 slc1
sm1 tr1
tr1 StartStop slc1
sr1 SplitType
typ
    (b, vb) <- merge2 sl2 tl2 sm2 tr2 sr2 typ
    pure ((a, b), (va, vb))
   where
    (StartStop slc1
sl1, StartStop slc2
sl2) = StartStop (slc1, slc2) -> (StartStop slc1, StartStop slc2)
forall a b. StartStop (a, b) -> (StartStop a, StartStop b)
distStartStop StartStop (slc1, slc2)
sl
    (StartStop slc1
sr1, StartStop slc2
sr2) = StartStop (slc1, slc2) -> (StartStop slc1, StartStop slc2)
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
    (a, va) <- StartStop slc1
-> Maybe tr' -> StartStop slc1 -> Bool -> [(tr1, v1)]
thaw1 StartStop slc1
l1 Maybe tr'
e StartStop slc1
r1 Bool
isLast
    (b, vb) <- thaw2 l2 e r2 isLast
    pure ((a, b), (va, vb))
   where
    (StartStop slc1
l1, StartStop slc2
l2) = StartStop (slc1, slc2) -> (StartStop slc1, StartStop slc2)
forall a b. StartStop (a, b) -> (StartStop a, StartStop b)
distStartStop StartStop (slc1, slc2)
l
    (StartStop slc1
r1, StartStop slc2
r2) = StartStop (slc1, slc2) -> (StartStop slc1, StartStop slc2)
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
(RightBranchSpread -> RightBranchSpread -> Bool)
-> (RightBranchSpread -> RightBranchSpread -> Bool)
-> Eq RightBranchSpread
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RightBranchSpread -> RightBranchSpread -> Bool
== :: RightBranchSpread -> RightBranchSpread -> Bool
$c/= :: RightBranchSpread -> RightBranchSpread -> Bool
/= :: RightBranchSpread -> RightBranchSpread -> Bool
Eq, Eq RightBranchSpread
Eq RightBranchSpread =>
(RightBranchSpread -> RightBranchSpread -> Ordering)
-> (RightBranchSpread -> RightBranchSpread -> Bool)
-> (RightBranchSpread -> RightBranchSpread -> Bool)
-> (RightBranchSpread -> RightBranchSpread -> Bool)
-> (RightBranchSpread -> RightBranchSpread -> Bool)
-> (RightBranchSpread -> RightBranchSpread -> RightBranchSpread)
-> (RightBranchSpread -> RightBranchSpread -> RightBranchSpread)
-> Ord 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
$ccompare :: RightBranchSpread -> RightBranchSpread -> Ordering
compare :: RightBranchSpread -> RightBranchSpread -> Ordering
$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
>= :: RightBranchSpread -> RightBranchSpread -> Bool
$cmax :: RightBranchSpread -> RightBranchSpread -> RightBranchSpread
max :: RightBranchSpread -> RightBranchSpread -> RightBranchSpread
$cmin :: RightBranchSpread -> RightBranchSpread -> RightBranchSpread
min :: RightBranchSpread -> RightBranchSpread -> RightBranchSpread
Ord, Int -> RightBranchSpread -> ShowS
[RightBranchSpread] -> ShowS
RightBranchSpread -> String
(Int -> RightBranchSpread -> ShowS)
-> (RightBranchSpread -> String)
-> ([RightBranchSpread] -> ShowS)
-> Show RightBranchSpread
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RightBranchSpread -> ShowS
showsPrec :: Int -> RightBranchSpread -> ShowS
$cshow :: RightBranchSpread -> String
show :: RightBranchSpread -> String
$cshowList :: [RightBranchSpread] -> ShowS
showList :: [RightBranchSpread] -> ShowS
Show, (forall x. RightBranchSpread -> Rep RightBranchSpread x)
-> (forall x. Rep RightBranchSpread x -> RightBranchSpread)
-> Generic RightBranchSpread
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
$cfrom :: forall x. RightBranchSpread -> Rep RightBranchSpread x
from :: forall x. RightBranchSpread -> Rep RightBranchSpread x
$cto :: forall x. Rep RightBranchSpread x -> RightBranchSpread
to :: forall x. Rep RightBranchSpread x -> RightBranchSpread
Generic, RightBranchSpread -> ()
(RightBranchSpread -> ()) -> NFData RightBranchSpread
forall a. (a -> ()) -> NFData a
$crnf :: RightBranchSpread -> ()
rnf :: RightBranchSpread -> ()
NFData, Eq RightBranchSpread
Eq RightBranchSpread =>
(Int -> RightBranchSpread -> Int)
-> (RightBranchSpread -> Int) -> Hashable RightBranchSpread
Int -> RightBranchSpread -> Int
RightBranchSpread -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> RightBranchSpread -> Int
hashWithSalt :: Int -> RightBranchSpread -> Int
$chash :: RightBranchSpread -> Int
hash :: 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 = UnspreadMiddle RightBranchSpread () () ()
-> UnspreadLeft RightBranchSpread () ()
-> UnspreadRight RightBranchSpread () ()
-> Unsplit RightBranchSpread () ()
-> (StartStop ()
    -> Maybe tr' -> StartStop () -> Bool -> [(RightBranchSpread, ())])
-> (slc' -> ())
-> Eval RightBranchSpread tr' () slc' () ()
forall tr tr' slc slc' h v.
UnspreadMiddle tr slc h v
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h v
Eval UnspreadMiddle RightBranchSpread () () ()
forall {a} {c}. (a, RightBranchSpread, c) -> [((), (), ())]
unspreadm UnspreadLeft RightBranchSpread () ()
forall {p} {p} {p}. p -> p -> p -> [RightBranchSpread]
unspreadl UnspreadRight RightBranchSpread () ()
forall {p} {p} {p}. p -> p -> p -> [RightBranchSpread]
unspreadr Unsplit RightBranchSpread () ()
forall {p} {p} {p} {p} {p} {p}.
p -> p -> p -> p -> p -> p -> [(RightBranchSpread, ())]
merge StartStop ()
-> Maybe tr' -> StartStop () -> Bool -> [(RightBranchSpread, ())]
forall {p} {p} {p} {p}.
p -> p -> p -> p -> [(RightBranchSpread, ())]
thaw slc' -> ()
forall {p}. p -> ()
slice
 where
  unspreadm :: (a, RightBranchSpread, c) -> [((), (), ())]
unspreadm (a
_, RightBranchSpread
RBBranches, c
_) = []
  unspreadm (a
_, RightBranchSpread
RBClear, c
_) = [((), (), ())]
  unspreadl :: p -> p -> p -> [RightBranchSpread]
unspreadl p
_ p
_ p
_ = [RightBranchSpread
RBClear]
  unspreadr :: p -> p -> p -> [RightBranchSpread]
unspreadr p
_ 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' h w -> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) w
rightBranchSpread :: forall tr tr' slc slc' h w.
Eval tr tr' slc slc' h w
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) w
rightBranchSpread = (((), w) -> w)
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) ((), w)
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) w
forall v w tr tr' slc slc' h.
(v -> w) -> Eval tr tr' slc slc' h v -> Eval tr tr' slc slc' h w
mapEvalScore ((), w) -> w
forall a b. (a, b) -> b
snd (Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) ((), w)
 -> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) w)
-> (Eval tr tr' slc slc' h w
    -> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) ((), w))
-> Eval tr tr' slc slc' h w
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval RightBranchSpread tr' () slc' () ()
-> Eval tr tr' slc slc' h w
-> Eval (RightBranchSpread, tr) tr' ((), slc) slc' ((), h) ((), w)
forall tr1 tr' slc1 slc' h1 v1 tr2 slc2 h2 v2.
Eval tr1 tr' slc1 slc' h1 v1
-> Eval tr2 tr' slc2 slc' h2 v2
-> Eval (tr1, tr2) tr' (slc1, slc2) slc' (h1, h2) (v1, v2)
productEval Eval RightBranchSpread tr' () slc' () ()
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
(Merged -> Merged -> Bool)
-> (Merged -> Merged -> Bool) -> Eq Merged
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Merged -> Merged -> Bool
== :: Merged -> Merged -> Bool
$c/= :: Merged -> Merged -> Bool
/= :: Merged -> Merged -> Bool
Eq, Eq Merged
Eq Merged =>
(Merged -> Merged -> Ordering)
-> (Merged -> Merged -> Bool)
-> (Merged -> Merged -> Bool)
-> (Merged -> Merged -> Bool)
-> (Merged -> Merged -> Bool)
-> (Merged -> Merged -> Merged)
-> (Merged -> Merged -> Merged)
-> Ord 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
$ccompare :: Merged -> Merged -> Ordering
compare :: Merged -> Merged -> Ordering
$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
>= :: Merged -> Merged -> Bool
$cmax :: Merged -> Merged -> Merged
max :: Merged -> Merged -> Merged
$cmin :: Merged -> Merged -> Merged
min :: Merged -> Merged -> Merged
Ord, Int -> Merged -> ShowS
[Merged] -> ShowS
Merged -> String
(Int -> Merged -> ShowS)
-> (Merged -> String) -> ([Merged] -> ShowS) -> Show Merged
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Merged -> ShowS
showsPrec :: Int -> Merged -> ShowS
$cshow :: Merged -> String
show :: Merged -> String
$cshowList :: [Merged] -> ShowS
showList :: [Merged] -> ShowS
Show, (forall x. Merged -> Rep Merged x)
-> (forall x. Rep Merged x -> Merged) -> Generic Merged
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
$cfrom :: forall x. Merged -> Rep Merged x
from :: forall x. Merged -> Rep Merged x
$cto :: forall x. Rep Merged x -> Merged
to :: forall x. Rep Merged x -> Merged
Generic, Merged -> ()
(Merged -> ()) -> NFData Merged
forall a. (a -> ()) -> NFData a
$crnf :: Merged -> ()
rnf :: Merged -> ()
NFData, Eq Merged
Eq Merged =>
(Int -> Merged -> Int) -> (Merged -> Int) -> Hashable Merged
Int -> Merged -> Int
Merged -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Merged -> Int
hashWithSalt :: Int -> Merged -> Int
$chash :: Merged -> Int
hash :: 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 = UnspreadMiddle Merged () () ()
-> UnspreadLeft Merged () ()
-> UnspreadRight Merged () ()
-> Unsplit Merged () ()
-> (StartStop ()
    -> Maybe tr' -> StartStop () -> Bool -> [(Merged, ())])
-> (slc' -> ())
-> Eval Merged tr' () slc' () ()
forall tr tr' slc slc' h v.
UnspreadMiddle tr slc h v
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h v
Eval UnspreadMiddle Merged () () ()
forall {p}. p -> [((), (), ())]
unspreadm UnspreadLeft Merged () ()
forall {b} {p} {p}. (Merged, b) -> p -> p -> [Merged]
unspreadl UnspreadRight Merged () ()
forall {a} {p} {p}. (a, Merged) -> p -> p -> [Merged]
unspreadr Unsplit Merged () ()
forall {p} {p} {p} {p} {p} {p}.
p -> p -> p -> p -> p -> p -> [(Merged, ())]
merge StartStop () -> Maybe tr' -> StartStop () -> Bool -> [(Merged, ())]
forall {p} {p} {p} {p}. p -> p -> p -> p -> [(Merged, ())]
thaw slc' -> ()
forall {p}. p -> ()
slice
 where
  unspreadm :: p -> [((), (), ())]
unspreadm p
_ = [((), (), ())]
  unspreadl :: (Merged, b) -> p -> p -> [Merged]
unspreadl (Merged
Merged, b
_) p
_ p
_ = []
  unspreadl (Merged
NotMerged, b
_) p
_ p
_ = [Merged
NotMerged]
  unspreadr :: (a, Merged) -> p -> p -> [Merged]
unspreadr (a
_, Merged
Merged) p
_ p
_ = []
  unspreadr (a
_, Merged
NotMerged) p
_ 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' h w -> Eval (Merged, tr) tr' ((), slc) slc' ((), h) w
splitFirst :: forall tr tr' slc slc' h w.
Eval tr tr' slc slc' h w
-> Eval (Merged, tr) tr' ((), slc) slc' ((), h) w
splitFirst = (((), w) -> w)
-> Eval (Merged, tr) tr' ((), slc) slc' ((), h) ((), w)
-> Eval (Merged, tr) tr' ((), slc) slc' ((), h) w
forall v w tr tr' slc slc' h.
(v -> w) -> Eval tr tr' slc slc' h v -> Eval tr tr' slc slc' h w
mapEvalScore ((), w) -> w
forall a b. (a, b) -> b
snd (Eval (Merged, tr) tr' ((), slc) slc' ((), h) ((), w)
 -> Eval (Merged, tr) tr' ((), slc) slc' ((), h) w)
-> (Eval tr tr' slc slc' h w
    -> Eval (Merged, tr) tr' ((), slc) slc' ((), h) ((), w))
-> Eval tr tr' slc slc' h w
-> Eval (Merged, tr) tr' ((), slc) slc' ((), h) w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval Merged tr' () slc' () ()
-> Eval tr tr' slc slc' h w
-> Eval (Merged, tr) tr' ((), slc) slc' ((), h) ((), w)
forall tr1 tr' slc1 slc' h1 v1 tr2 slc2 h2 v2.
Eval tr1 tr' slc1 slc' h1 v1
-> Eval tr2 tr' slc2 slc' h2 v2
-> Eval (tr1, tr2) tr' (slc1, slc2) slc' (h1, h2) (v1, v2)
productEval Eval Merged tr' () slc' () ()
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
(LeftmostSingle s f -> LeftmostSingle s f -> Bool)
-> (LeftmostSingle s f -> LeftmostSingle s f -> Bool)
-> Eq (LeftmostSingle s f)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s f.
(Eq s, Eq f) =>
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
/= :: LeftmostSingle s f -> LeftmostSingle s f -> Bool
Eq, Eq (LeftmostSingle s f)
Eq (LeftmostSingle s f) =>
(LeftmostSingle s f -> LeftmostSingle s f -> Ordering)
-> (LeftmostSingle s f -> LeftmostSingle s f -> Bool)
-> (LeftmostSingle s f -> LeftmostSingle s f -> Bool)
-> (LeftmostSingle s f -> LeftmostSingle s f -> Bool)
-> (LeftmostSingle s f -> LeftmostSingle s f -> Bool)
-> (LeftmostSingle s f -> LeftmostSingle s f -> LeftmostSingle s f)
-> (LeftmostSingle s f -> LeftmostSingle s f -> LeftmostSingle s f)
-> Ord (LeftmostSingle s f)
LeftmostSingle s f -> LeftmostSingle s f -> Bool
LeftmostSingle s f -> LeftmostSingle s f -> Ordering
LeftmostSingle s f -> LeftmostSingle s f -> LeftmostSingle s f
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
$ccompare :: forall s f.
(Ord s, Ord f) =>
LeftmostSingle s f -> LeftmostSingle s f -> Ordering
compare :: LeftmostSingle s f -> LeftmostSingle s f -> Ordering
$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
>= :: LeftmostSingle s f -> LeftmostSingle s f -> Bool
$cmax :: 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
$cmin :: 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
Ord, Int -> LeftmostSingle s f -> ShowS
[LeftmostSingle s f] -> ShowS
LeftmostSingle s f -> String
(Int -> LeftmostSingle s f -> ShowS)
-> (LeftmostSingle s f -> String)
-> ([LeftmostSingle s f] -> ShowS)
-> Show (LeftmostSingle s f)
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
$cshowsPrec :: forall s f. (Show s, Show f) => Int -> LeftmostSingle s f -> ShowS
showsPrec :: Int -> LeftmostSingle s f -> ShowS
$cshow :: forall s f. (Show s, Show f) => LeftmostSingle s f -> String
show :: LeftmostSingle s f -> String
$cshowList :: forall s f. (Show s, Show f) => [LeftmostSingle s f] -> ShowS
showList :: [LeftmostSingle s f] -> ShowS
Show, (forall x. LeftmostSingle s f -> Rep (LeftmostSingle s f) x)
-> (forall x. Rep (LeftmostSingle s f) x -> LeftmostSingle s f)
-> Generic (LeftmostSingle s f)
forall x. Rep (LeftmostSingle s f) x -> LeftmostSingle s f
forall x. LeftmostSingle s f -> Rep (LeftmostSingle s f) x
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
$cfrom :: forall s f x. LeftmostSingle s f -> Rep (LeftmostSingle s f) x
from :: forall x. LeftmostSingle s f -> Rep (LeftmostSingle s f) x
$cto :: forall s f x. Rep (LeftmostSingle s f) x -> LeftmostSingle s f
to :: forall x. Rep (LeftmostSingle s f) x -> LeftmostSingle s f
Generic, LeftmostSingle s f -> ()
(LeftmostSingle s f -> ()) -> NFData (LeftmostSingle s f)
forall a. (a -> ()) -> NFData a
forall s f. (NFData s, NFData f) => LeftmostSingle s f -> ()
$crnf :: forall s f. (NFData s, NFData f) => LeftmostSingle s f -> ()
rnf :: LeftmostSingle s f -> ()
NFData, (forall a b. (a -> b) -> LeftmostSingle s a -> LeftmostSingle s b)
-> (forall a b. a -> LeftmostSingle s b -> LeftmostSingle s a)
-> Functor (LeftmostSingle s)
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
$cfmap :: forall s a b. (a -> b) -> LeftmostSingle s a -> LeftmostSingle s b
fmap :: forall a b. (a -> b) -> LeftmostSingle s a -> LeftmostSingle s b
$c<$ :: forall s a b. a -> LeftmostSingle s b -> LeftmostSingle s a
<$ :: forall a b. a -> LeftmostSingle s b -> LeftmostSingle s a
Functor, (forall m. Monoid m => LeftmostSingle s m -> m)
-> (forall m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m)
-> (forall m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m)
-> (forall a b. (a -> b -> b) -> b -> LeftmostSingle s a -> b)
-> (forall a b. (a -> b -> b) -> b -> LeftmostSingle s a -> b)
-> (forall b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b)
-> (forall b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b)
-> (forall a. (a -> a -> a) -> LeftmostSingle s a -> a)
-> (forall a. (a -> a -> a) -> LeftmostSingle s a -> a)
-> (forall a. LeftmostSingle s a -> [a])
-> (forall a. LeftmostSingle s a -> Bool)
-> (forall a. LeftmostSingle s a -> Int)
-> (forall a. Eq a => a -> LeftmostSingle s a -> Bool)
-> (forall a. Ord a => LeftmostSingle s a -> a)
-> (forall a. Ord a => LeftmostSingle s a -> a)
-> (forall a. Num a => LeftmostSingle s a -> a)
-> (forall a. Num a => LeftmostSingle s a -> a)
-> Foldable (LeftmostSingle s)
forall a. Eq a => a -> LeftmostSingle s a -> Bool
forall a. Num a => LeftmostSingle s a -> a
forall a. Ord a => LeftmostSingle s a -> a
forall m. Monoid m => LeftmostSingle s m -> m
forall a. LeftmostSingle s a -> Bool
forall a. LeftmostSingle s a -> Int
forall a. LeftmostSingle s a -> [a]
forall a. (a -> a -> a) -> LeftmostSingle s a -> a
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 s m. Monoid m => LeftmostSingle s m -> m
forall m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m
forall s a. LeftmostSingle s a -> Bool
forall s a. LeftmostSingle s a -> Int
forall s a. LeftmostSingle s a -> [a]
forall b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b
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
$cfold :: forall s m. Monoid m => LeftmostSingle s m -> m
fold :: forall m. Monoid m => LeftmostSingle s m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> LeftmostSingle s a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> LeftmostSingle s a -> b
$cfoldr1 :: forall s a. (a -> a -> a) -> LeftmostSingle s a -> a
foldr1 :: forall a. (a -> a -> a) -> LeftmostSingle s a -> a
$cfoldl1 :: forall s a. (a -> a -> a) -> LeftmostSingle s a -> a
foldl1 :: forall a. (a -> a -> a) -> LeftmostSingle s a -> a
$ctoList :: forall s a. LeftmostSingle s a -> [a]
toList :: forall a. LeftmostSingle s a -> [a]
$cnull :: forall s a. LeftmostSingle s a -> Bool
null :: forall a. LeftmostSingle s a -> Bool
$clength :: forall s a. LeftmostSingle s a -> Int
length :: forall a. LeftmostSingle s a -> Int
$celem :: forall s a. Eq a => a -> LeftmostSingle s a -> Bool
elem :: forall a. Eq a => a -> LeftmostSingle s a -> Bool
$cmaximum :: forall s a. Ord a => LeftmostSingle s a -> a
maximum :: forall a. Ord a => LeftmostSingle s a -> a
$cminimum :: forall s a. Ord a => LeftmostSingle s a -> a
minimum :: forall a. Ord a => LeftmostSingle s a -> a
$csum :: forall s a. Num a => LeftmostSingle s a -> a
sum :: forall a. Num a => LeftmostSingle s a -> a
$cproduct :: forall s a. Num a => LeftmostSingle s a -> a
product :: forall a. Num a => LeftmostSingle s a -> a
Foldable, Functor (LeftmostSingle s)
Foldable (LeftmostSingle s)
(Functor (LeftmostSingle s), Foldable (LeftmostSingle s)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> LeftmostSingle s a -> f (LeftmostSingle s b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    LeftmostSingle s (f a) -> f (LeftmostSingle s a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> LeftmostSingle s a -> m (LeftmostSingle s b))
-> (forall (m :: * -> *) a.
    Monad m =>
    LeftmostSingle s (m a) -> m (LeftmostSingle s a))
-> Traversable (LeftmostSingle s)
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 (m :: * -> *) a.
Monad m =>
LeftmostSingle s (m a) -> m (LeftmostSingle s a)
forall (f :: * -> *) a.
Applicative f =>
LeftmostSingle s (f a) -> f (LeftmostSingle s a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LeftmostSingle s a -> m (LeftmostSingle s b)
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)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LeftmostSingle s a -> f (LeftmostSingle s b)
$csequenceA :: forall s (f :: * -> *) a.
Applicative f =>
LeftmostSingle s (f a) -> f (LeftmostSingle s a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
LeftmostSingle s (f a) -> f (LeftmostSingle s a)
$cmapM :: forall s (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LeftmostSingle s a -> m (LeftmostSingle s b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LeftmostSingle s a -> m (LeftmostSingle s b)
$csequence :: forall s (m :: * -> *) a.
Monad m =>
LeftmostSingle s (m a) -> m (LeftmostSingle s a)
sequence :: forall (m :: * -> *) a.
Monad m =>
LeftmostSingle s (m a) -> m (LeftmostSingle s a)
Traversable)

instance (ToJSON s, ToJSON f) => ToJSON (LeftmostSingle s f) where
  toJSON :: LeftmostSingle s f -> Value
toJSON =
    Options -> LeftmostSingle s f -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON (Options -> LeftmostSingle s f -> Value)
-> Options -> LeftmostSingle s f -> Value
forall a b. (a -> b) -> a -> b
$ ShowS -> Options
variantDefaults ((String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Only") ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
firstToLower ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
8)
  toEncoding :: LeftmostSingle s f -> Encoding
toEncoding =
    Options -> LeftmostSingle s f -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding (Options -> LeftmostSingle s f -> Encoding)
-> Options -> LeftmostSingle s f -> Encoding
forall a b. (a -> b) -> a -> b
$
      ShowS -> Options
variantDefaults ((String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Only") ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
firstToLower ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
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
(LeftmostDouble s f h -> LeftmostDouble s f h -> Bool)
-> (LeftmostDouble s f h -> LeftmostDouble s f h -> Bool)
-> Eq (LeftmostDouble s f h)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s f h.
(Eq f, Eq s, Eq h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
$c== :: forall s f h.
(Eq f, Eq s, 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 f, Eq s, Eq h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
/= :: LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
Eq, Eq (LeftmostDouble s f h)
Eq (LeftmostDouble s f h) =>
(LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering)
-> (LeftmostDouble s f h -> LeftmostDouble s f h -> Bool)
-> (LeftmostDouble s f h -> LeftmostDouble s f h -> Bool)
-> (LeftmostDouble s f h -> LeftmostDouble s f h -> Bool)
-> (LeftmostDouble s f h -> LeftmostDouble s f h -> Bool)
-> (LeftmostDouble s f h
    -> LeftmostDouble s f h -> LeftmostDouble s f h)
-> (LeftmostDouble s f h
    -> LeftmostDouble s f h -> LeftmostDouble s f h)
-> Ord (LeftmostDouble s f h)
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering
LeftmostDouble s f h
-> LeftmostDouble s f h -> LeftmostDouble s f h
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 f, Ord s, Ord h) => Eq (LeftmostDouble s f h)
forall s f h.
(Ord f, Ord s, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
forall s f h.
(Ord f, Ord s, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering
forall s f h.
(Ord f, Ord s, Ord h) =>
LeftmostDouble s f h
-> LeftmostDouble s f h -> LeftmostDouble s f h
$ccompare :: forall s f h.
(Ord f, Ord s, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering
compare :: LeftmostDouble s f h -> LeftmostDouble s f h -> Ordering
$c< :: forall s f h.
(Ord f, Ord s, 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 f, Ord s, 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 f, Ord s, 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 f, Ord s, Ord h) =>
LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
>= :: LeftmostDouble s f h -> LeftmostDouble s f h -> Bool
$cmax :: forall s f h.
(Ord f, Ord s, 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
$cmin :: forall s f h.
(Ord f, Ord s, 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
Ord, Int -> LeftmostDouble s f h -> ShowS
[LeftmostDouble s f h] -> ShowS
LeftmostDouble s f h -> String
(Int -> LeftmostDouble s f h -> ShowS)
-> (LeftmostDouble s f h -> String)
-> ([LeftmostDouble s f h] -> ShowS)
-> Show (LeftmostDouble s f h)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s f h.
(Show f, Show s, Show h) =>
Int -> LeftmostDouble s f h -> ShowS
forall s f h.
(Show f, Show s, Show h) =>
[LeftmostDouble s f h] -> ShowS
forall s f h.
(Show f, Show s, Show h) =>
LeftmostDouble s f h -> String
$cshowsPrec :: forall s f h.
(Show f, Show s, Show h) =>
Int -> LeftmostDouble s f h -> ShowS
showsPrec :: Int -> LeftmostDouble s f h -> ShowS
$cshow :: forall s f h.
(Show f, Show s, Show h) =>
LeftmostDouble s f h -> String
show :: LeftmostDouble s f h -> String
$cshowList :: forall s f h.
(Show f, Show s, Show h) =>
[LeftmostDouble s f h] -> ShowS
showList :: [LeftmostDouble s f h] -> ShowS
Show, (forall x. LeftmostDouble s f h -> Rep (LeftmostDouble s f h) x)
-> (forall x. Rep (LeftmostDouble s f h) x -> LeftmostDouble s f h)
-> Generic (LeftmostDouble s f h)
forall x. Rep (LeftmostDouble s f h) x -> LeftmostDouble s f h
forall x. LeftmostDouble s f h -> Rep (LeftmostDouble s f h) x
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
$cfrom :: forall s f h x.
LeftmostDouble s f h -> Rep (LeftmostDouble s f h) x
from :: forall 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
to :: forall x. Rep (LeftmostDouble s f h) x -> LeftmostDouble s f h
Generic, LeftmostDouble s f h -> ()
(LeftmostDouble s f h -> ()) -> NFData (LeftmostDouble s f h)
forall a. (a -> ()) -> NFData a
forall s f h.
(NFData s, NFData f, NFData h) =>
LeftmostDouble s f h -> ()
$crnf :: forall s f h.
(NFData s, NFData f, NFData h) =>
LeftmostDouble s f h -> ()
rnf :: LeftmostDouble s f h -> ()
NFData)

-- | Helper function for `LeftmostDouble`'s 'ToJSON' instance.
lmDoubleToJSONName :: ShowS
lmDoubleToJSONName String
"LMDoubleSpread" = String
"hori"
lmDoubleToJSONName String
str = ShowS
firstToLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
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 = Options -> LeftmostDouble s f h -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON (Options -> LeftmostDouble s f h -> Value)
-> Options -> LeftmostDouble s f h -> Value
forall a b. (a -> b) -> a -> b
$ ShowS -> Options
variantDefaults ShowS
lmDoubleToJSONName
  toEncoding :: LeftmostDouble s f h -> Encoding
toEncoding =
    Options -> LeftmostDouble s f h -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding (Options -> LeftmostDouble s f h -> Encoding)
-> Options -> LeftmostDouble s f h -> Encoding
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
(Leftmost s f h -> Leftmost s f h -> Bool)
-> (Leftmost s f h -> Leftmost s f h -> Bool)
-> Eq (Leftmost s f h)
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
$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
/= :: Leftmost s f h -> Leftmost s f h -> Bool
Eq, Eq (Leftmost s f h)
Eq (Leftmost s f h) =>
(Leftmost s f h -> Leftmost s f h -> Ordering)
-> (Leftmost s f h -> Leftmost s f h -> Bool)
-> (Leftmost s f h -> Leftmost s f h -> Bool)
-> (Leftmost s f h -> Leftmost s f h -> Bool)
-> (Leftmost s f h -> Leftmost s f h -> Bool)
-> (Leftmost s f h -> Leftmost s f h -> Leftmost s f h)
-> (Leftmost s f h -> Leftmost s f h -> Leftmost s f h)
-> Ord (Leftmost s f h)
Leftmost s f h -> Leftmost s f h -> Bool
Leftmost s f h -> Leftmost s f h -> Ordering
Leftmost s f h -> Leftmost s f h -> Leftmost s f h
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
$ccompare :: forall s f h.
(Ord s, Ord f, Ord h) =>
Leftmost s f h -> Leftmost s f h -> Ordering
compare :: Leftmost s f h -> Leftmost s f h -> Ordering
$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
>= :: Leftmost s f h -> Leftmost s f h -> Bool
$cmax :: 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
$cmin :: 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
Ord, Int -> Leftmost s f h -> ShowS
[Leftmost s f h] -> ShowS
Leftmost s f h -> String
(Int -> Leftmost s f h -> ShowS)
-> (Leftmost s f h -> String)
-> ([Leftmost s f h] -> ShowS)
-> Show (Leftmost s f h)
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
$cshowsPrec :: forall s f h.
(Show s, Show f, Show h) =>
Int -> Leftmost s f h -> ShowS
showsPrec :: Int -> Leftmost s f h -> ShowS
$cshow :: forall s f h. (Show s, Show f, Show h) => Leftmost s f h -> String
show :: Leftmost s f h -> String
$cshowList :: forall s f h. (Show s, Show f, Show h) => [Leftmost s f h] -> ShowS
showList :: [Leftmost s f h] -> ShowS
Show, (forall x. Leftmost s f h -> Rep (Leftmost s f h) x)
-> (forall x. Rep (Leftmost s f h) x -> Leftmost s f h)
-> Generic (Leftmost s f h)
forall x. Rep (Leftmost s f h) x -> Leftmost s f h
forall x. Leftmost s f h -> Rep (Leftmost s f h) x
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
$cfrom :: forall s f h x. Leftmost s f h -> Rep (Leftmost s f h) x
from :: forall 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
to :: forall x. Rep (Leftmost s f h) x -> Leftmost s f h
Generic, Leftmost s f h -> ()
(Leftmost s f h -> ()) -> NFData (Leftmost s f h)
forall a. (a -> ()) -> NFData a
forall s f h.
(NFData s, NFData f, NFData h) =>
Leftmost s f h -> ()
$crnf :: forall s f h.
(NFData s, NFData f, NFData h) =>
Leftmost s f h -> ()
rnf :: 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 = String
-> (Object -> Parser (Leftmost s f h))
-> Value
-> Parser (Leftmost s f h)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Leftmost" ((Object -> Parser (Leftmost s f h))
 -> Value -> Parser (Leftmost s f h))
-> (Object -> Parser (Leftmost s f h))
-> Value
-> Parser (Leftmost s f h)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    typ <- Object
obj Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
    val <- obj .: "value"
    case typ of
      Value
"freezeLeft" -> f -> Leftmost s f h
forall f s h. f -> Leftmost s f h
LMFreezeLeft (f -> Leftmost s f h) -> Parser f -> Parser (Leftmost s f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser f
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"freezeOnly" -> f -> Leftmost s f h
forall f s h. f -> Leftmost s f h
LMFreezeOnly (f -> Leftmost s f h) -> Parser f -> Parser (Leftmost s f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser f
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"splitLeft" -> s -> Leftmost s f h
forall s f h. s -> Leftmost s f h
LMSplitLeft (s -> Leftmost s f h) -> Parser s -> Parser (Leftmost s f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser s
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"splitRight" -> s -> Leftmost s f h
forall s f h. s -> Leftmost s f h
LMSplitRight (s -> Leftmost s f h) -> Parser s -> Parser (Leftmost s f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser s
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"splitOnly" -> s -> Leftmost s f h
forall s f h. s -> Leftmost s f h
LMSplitOnly (s -> Leftmost s f h) -> Parser s -> Parser (Leftmost s f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser s
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      Value
"hori" -> h -> Leftmost s f h
forall h s f. h -> Leftmost s f h
LMSpread (h -> Leftmost s f h) -> Parser h -> Parser (Leftmost s f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser h
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val -- the JSON encoding uses "hori" instead of "spread"
      Value
other -> Value -> Parser (Leftmost s f h)
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) = LeftmostSingle s f -> Value
forall a. ToJSON a => a -> Value
toJSON LeftmostSingle s f
sg
  toJSON (LMDouble LeftmostDouble s f h
db) = LeftmostDouble s f h -> Value
forall a. ToJSON a => a -> Value
toJSON LeftmostDouble s f h
db
  toEncoding :: Leftmost s f h -> Encoding
toEncoding (LMSingle LeftmostSingle s f
sg) = LeftmostSingle s f -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding LeftmostSingle s f
sg
  toEncoding (LMDouble LeftmostDouble s f h
db) = LeftmostDouble s f h -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding LeftmostDouble s f h
db

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

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

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

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

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

pattern LMFreezeOnly :: f -> Leftmost s f h
pattern $mLMFreezeOnly :: forall {r} {f} {s} {h}.
Leftmost s f h -> (f -> r) -> ((# #) -> r) -> r
$bLMFreezeOnly :: forall f s h. f -> Leftmost s f h
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
(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)
-> Eq (Analysis s f h tr slc)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s f h tr slc.
(Eq s, Eq f, Eq h, Eq slc, Eq tr) =>
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 slc, Eq tr) =>
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 slc, Eq tr) =>
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
Eq, Eq (Analysis s f h tr slc)
Eq (Analysis s f h tr slc) =>
(Analysis s f h tr slc -> Analysis s f h tr slc -> Ordering)
-> (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)
-> (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)
-> (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 -> Analysis s f h tr slc)
-> Ord (Analysis s f h tr 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 -> Ordering
Analysis s f h tr slc
-> Analysis s f h tr slc -> Analysis s f h tr slc
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 slc, Ord tr) =>
Eq (Analysis s f h tr slc)
forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord slc, Ord tr) =>
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 slc, Ord tr) =>
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 slc, Ord tr) =>
Analysis s f h tr slc
-> Analysis s f h tr slc -> Analysis s f h tr slc
$ccompare :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord slc, Ord tr) =>
Analysis s f h tr slc -> Analysis s f h tr slc -> Ordering
compare :: Analysis s f h tr slc -> Analysis s f h tr slc -> Ordering
$c< :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord slc, Ord tr) =>
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 slc, Ord tr) =>
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 slc, Ord tr) =>
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 slc, Ord tr) =>
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
$cmax :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord slc, Ord tr) =>
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
$cmin :: forall s f h tr slc.
(Ord s, Ord f, Ord h, Ord slc, Ord tr) =>
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
Ord, Int -> Analysis s f h tr slc -> ShowS
[Analysis s f h tr slc] -> ShowS
Analysis s f h tr slc -> String
(Int -> Analysis s f h tr slc -> ShowS)
-> (Analysis s f h tr slc -> String)
-> ([Analysis s f h tr slc] -> ShowS)
-> Show (Analysis s f h tr slc)
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
$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
showsPrec :: Int -> Analysis s f h tr slc -> ShowS
$cshow :: forall s f h tr slc.
(Show s, Show f, Show h, Show tr, Show slc) =>
Analysis s f h tr slc -> String
show :: Analysis s f h tr slc -> String
$cshowList :: forall s f h tr slc.
(Show s, Show f, Show h, Show tr, Show slc) =>
[Analysis s f h tr slc] -> ShowS
showList :: [Analysis s f h tr slc] -> ShowS
Show, (forall x. Analysis s f h tr slc -> Rep (Analysis s f h tr slc) x)
-> (forall x.
    Rep (Analysis s f h tr slc) x -> Analysis s f h tr slc)
-> Generic (Analysis s f h tr slc)
forall x. Rep (Analysis s f h tr slc) x -> Analysis s f h tr slc
forall x. Analysis s f h tr slc -> Rep (Analysis s f h tr slc) x
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
$cfrom :: forall s f h tr slc x.
Analysis s f h tr slc -> Rep (Analysis s f h tr slc) x
from :: forall 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
to :: forall x. Rep (Analysis s f h tr slc) x -> Analysis s f h tr slc
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 = String
-> (Object -> Parser (Analysis s f h tr slc))
-> Value
-> Parser (Analysis s f h tr slc)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Analysis" ((Object -> Parser (Analysis s f h tr slc))
 -> Value -> Parser (Analysis s f h tr slc))
-> (Object -> Parser (Analysis s f h tr slc))
-> Value
-> Parser (Analysis s f h tr slc)
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    deriv <- Object
v Object -> Key -> Parser [Leftmost s f h]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"derivation"
    start <- v .: "start" >>= parseSlice
    case start of
      StartStop slc
Start -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      StartStop slc
_ -> String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Start slice is not ⋊."
    segments <- v .: "topSegments"
    top <- parseTop segments
    pure $ Analysis{anaDerivation = deriv, anaTop = top}
   where
    parseTop :: [Aeson.Value] -> Aeson.Parser (Path tr slc)
    parseTop :: [Value] -> Parser (Path tr slc)
parseTop [Value]
segs = do
      segments <- (Value -> Parser (tr, StartStop slc))
-> [Value] -> Parser [(tr, StartStop slc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Parser (tr, StartStop slc)
parseSegment [Value]
segs
      mkPath 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)] = Path e a -> Parser (Path e a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path e a -> Parser (Path e a)) -> Path e a -> Parser (Path e a)
forall a b. (a -> b) -> a -> b
$ e -> Path e a
forall around between. around -> Path around between
PathEnd e
t
      mkPath ((e
t, Inner a
s) : [(e, StartStop a)]
rest) = e -> a -> Path e a -> Path e a
forall around between.
around -> between -> Path around between -> Path around between
Path e
t a
s (Path e a -> Path e a) -> Parser (Path e a) -> Parser (Path e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(e, StartStop a)] -> Parser (Path e a)
forall e a. [(e, StartStop a)] -> Parser (Path e a)
mkPath [(e, StartStop a)]
rest
      mkPath [(e, StartStop a)]
_ = String -> Parser (Path e a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid top path."
    parseSlice :: Value -> Parser (StartStop slc)
parseSlice = String
-> (Object -> Parser (StartStop slc))
-> Value
-> Parser (StartStop slc)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Slice" ((Object -> Parser (StartStop slc))
 -> Value -> Parser (StartStop slc))
-> (Object -> Parser (StartStop slc))
-> Value
-> Parser (StartStop slc)
forall a b. (a -> b) -> a -> b
$ \Object
v -> Object
v Object -> Key -> Parser (StartStop slc)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"notes"
    parseTrans :: Value -> Parser tr
parseTrans = String -> (Object -> Parser tr) -> Value -> Parser tr
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Transition" ((Object -> Parser tr) -> Value -> Parser tr)
-> (Object -> Parser tr) -> Value -> Parser tr
forall a b. (a -> b) -> a -> b
$ \Object
v -> Object
v Object -> Key -> Parser tr
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"edges"
    parseSegment :: Value -> Parser (tr, StartStop slc)
parseSegment = String
-> (Object -> Parser (tr, StartStop slc))
-> Value
-> Parser (tr, StartStop slc)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Segment" ((Object -> Parser (tr, StartStop slc))
 -> Value -> Parser (tr, StartStop slc))
-> (Object -> Parser (tr, StartStop slc))
-> Value
-> Parser (tr, StartStop slc)
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
      trans <- Object
v Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"trans" Parser Value -> (Value -> Parser tr) -> Parser tr
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser tr
parseTrans
      rslice <- v .: "rslice" >>= parseSlice
      pure (trans, rslice)

instance forall s f h tr slc. (ToJSON s, ToJSON f, ToJSON h, ToJSON tr, ToJSON slc) => ToJSON (Analysis s f h tr slc) where
  toJSON :: Analysis s f h tr slc -> Value
toJSON (Analysis [Leftmost s f h]
deriv Path tr slc
top) =
    [Pair] -> Value
Aeson.object
      [ Key
"derivation" Key -> [Leftmost s f h] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Leftmost s f h]
deriv
      , Key
"start" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object [Key
"notes" Key -> StartStop slc -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (StartStop slc
forall a. StartStop a
Start :: StartStop slc)]
      , Key
"topSegments" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Value]
segments
      , Key
"styles" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
Aeson.Null
      ]
   where
    toSegment :: v -> v -> Value
toSegment v
tr v
slc =
      [Pair] -> Value
Aeson.object
        [ Key
"trans" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object [Key
"edges" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
tr]
        , Key
"rslice" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object [Key
"notes" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
slc]
        ]
    trs :: [tr]
trs = Path tr slc -> [tr]
forall a b. Path a b -> [a]
pathArounds Path tr slc
top
    slcs :: [StartStop slc]
slcs = (slc -> StartStop slc
forall a. a -> StartStop a
Inner (slc -> StartStop slc) -> [slc] -> [StartStop slc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path tr slc -> [slc]
forall a b. Path a b -> [b]
pathBetweens Path tr slc
top) [StartStop slc] -> [StartStop slc] -> [StartStop slc]
forall a. Semigroup a => a -> a -> a
<> [StartStop slc
forall a. StartStop a
Stop]
    segments :: [Value]
segments = (tr -> StartStop slc -> Value)
-> [tr] -> [StartStop slc] -> [Value]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith tr -> StartStop slc -> Value
forall {v} {v}. (ToJSON v, ToJSON v) => v -> v -> Value
toSegment [tr]
trs [StartStop slc]
slcs

  toEncoding :: Analysis s f h tr slc -> Encoding
toEncoding (Analysis [Leftmost s f h]
deriv Path tr slc
top) =
    Series -> Encoding
Aeson.pairs
      ( Key
"derivation" Key -> [Leftmost s f h] -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Leftmost s f h]
deriv
          Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"start" Key -> Value -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object [Key
"notes" Key -> StartStop slc -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (StartStop slc
forall a. StartStop a
Start :: StartStop slc)]
          Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"topSegments" Key -> [Value] -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Value]
segments
          Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"styles" Key -> Value -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
Aeson.Null
      )
   where
    toSegment :: v -> v -> Value
toSegment v
tr v
slc =
      [Pair] -> Value
Aeson.object
        [ Key
"trans" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object [Key
"edges" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
tr]
        , Key
"rslice" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object [Key
"notes" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
slc]
        ]
    trs :: [tr]
trs = Path tr slc -> [tr]
forall a b. Path a b -> [a]
pathArounds Path tr slc
top
    slcs :: [StartStop slc]
slcs = (slc -> StartStop slc
forall a. a -> StartStop a
Inner (slc -> StartStop slc) -> [slc] -> [StartStop slc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path tr slc -> [slc]
forall a b. Path a b -> [b]
pathBetweens Path tr slc
top) [StartStop slc] -> [StartStop slc] -> [StartStop slc]
forall a. Semigroup a => a -> a -> a
<> [StartStop slc
forall a. StartStop a
Stop]
    segments :: [Value]
segments = (tr -> StartStop slc -> Value)
-> [tr] -> [StartStop slc] -> [Value]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith tr -> StartStop slc -> Value
forall {v} {v}. (ToJSON v, ToJSON v) => v -> v -> Value
toSegment [tr]
trs [StartStop slc]
slcs

-- | 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) =
  ExceptT String IO () -> IO (Either String ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO () -> IO (Either String ()))
-> ExceptT String IO () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$
    StartStop slc
-> Path tr slc -> Bool -> [Leftmost s f h] -> ExceptT String IO ()
go StartStop slc
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 [] = Either String () -> ExceptT String IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String () -> ExceptT String IO ())
-> Either String () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
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
    IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nCurrent surface: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path tr slc -> String
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
            IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"freezing only (terminating)"
            _ <- Either String tr -> ExceptT String IO tr
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String tr -> ExceptT String IO tr)
-> Either String tr -> ExceptT String IO tr
forall a b. (a -> b) -> a -> b
$ f -> tr -> Either String tr
doFreeze f
freezeOp tr
trans
            pure ()
          LMSingleSplit s
splitOp -> do
            IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"splitting only: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> s -> String
forall a. Show a => a -> String
show s
splitOp
            (ctl, cs, ctr) <- Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr))
-> Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr)
forall a b. (a -> b) -> a -> b
$ s -> tr -> Either String (tr, slc, tr)
doSplit s
splitOp tr
trans
            go sl (Path ctl cs (PathEnd ctr)) False rest
      LMDouble LeftmostDouble s f h
_ -> Either String () -> ExceptT String IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String () -> ExceptT String IO ())
-> Either String () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
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
    IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nCurrent surface: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path tr slc -> String
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, StartStop slc
forall a. StartStop a
Stop) tr -> Path tr slc
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
    IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nCurrent surface: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path tr slc -> String
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, slc -> StartStop slc
forall a. a -> StartStop a
Inner slc
sr) ((tr -> Path tr slc) -> ExceptT String IO ())
-> (tr -> Path tr slc) -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$
      \tr
tr' -> tr -> slc -> Path tr slc -> Path tr slc
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
_ ->
      Either String () -> ExceptT String IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String () -> ExceptT String IO ())
-> Either String () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
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
          Bool -> ExceptT String IO () -> ExceptT String IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ars (ExceptT String IO () -> ExceptT String IO ())
-> ExceptT String IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ Either String () -> ExceptT String IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String () -> ExceptT String IO ())
-> Either String () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"FreezeLeft after SplitRight."
          IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"freezing left"
          _ <- Either String tr -> ExceptT String IO tr
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String tr -> ExceptT String IO tr)
-> Either String tr -> ExceptT String IO tr
forall a b. (a -> b) -> a -> b
$ f -> tr -> Either String tr
doFreeze f
freezeOp tr
tl
          go (Inner sm) (mkRest tr) False rest
        LMDoubleSplitLeft s
splitOp -> do
          Bool -> ExceptT String IO () -> ExceptT String IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ars (ExceptT String IO () -> ExceptT String IO ())
-> ExceptT String IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ Either String () -> ExceptT String IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String () -> ExceptT String IO ())
-> Either String () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"SplitLeft after SplitRight."
          IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"splitting left: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> s -> String
forall a. Show a => a -> String
show s
splitOp
          (ctl, cs, ctr) <- Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr))
-> Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr)
forall a b. (a -> b) -> a -> b
$ s -> tr -> Either String (tr, slc, tr)
doSplit s
splitOp tr
tl
          go sl (Path ctl cs $ Path ctr sm $ mkRest tr) False rest
        LMDoubleSplitRight s
splitOp -> do
          IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"splitting right: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> s -> String
forall a. Show a => a -> String
show s
splitOp
          (ctl, cs, ctr) <- Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr))
-> Either String (tr, slc, tr) -> ExceptT String IO (tr, slc, tr)
forall a b. (a -> b) -> a -> b
$ s -> tr -> Either String (tr, slc, tr)
doSplit s
splitOp tr
tr
          go sl (Path tl sm $ Path ctl cs $ mkRest ctr) True rest
        LMDoubleSpread h
spreadOp -> do
          IO () -> ExceptT String IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"spreading: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> h -> String
forall a. Show a => a -> String
show h
spreadOp
          (ctl, csl, ctm, csr, ctr) <- Either String (tr, slc, tr, slc, tr)
-> ExceptT String IO (tr, slc, tr, slc, tr)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String (tr, slc, tr, slc, tr)
 -> ExceptT String IO (tr, slc, tr, slc, tr))
-> Either String (tr, slc, tr, slc, tr)
-> ExceptT String IO (tr, slc, tr, slc, tr)
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
          go sl (Path ctl csl $ Path ctm csr $ mkRest ctr) False 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
  :: forall tr tr' slc slc' s f h
   . UnspreadMiddle tr slc h h
  -> UnspreadLeft tr slc h
  -> UnspreadRight tr slc h
  -> (StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)])
  -> (StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)])
  -> (slc' -> slc)
  -> Eval tr tr' slc slc' h (Leftmost s f h)
mkLeftmostEval :: forall tr tr' slc slc' s f h.
UnspreadMiddle tr slc h h
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> (StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)])
-> (StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h (Leftmost s f h)
mkLeftmostEval UnspreadMiddle tr slc h h
unspreadm UnspreadLeft tr slc h
unspreadl UnspreadRight tr slc h
unspreadr StartStop slc -> tr -> slc -> tr -> StartStop slc -> [(tr, s)]
unsplit StartStop slc -> Maybe tr' -> StartStop slc -> [(tr, f)]
uf =
  UnspreadMiddle tr slc h (Leftmost s f h)
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> Unsplit tr slc (Leftmost s f h)
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, Leftmost s f h)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h (Leftmost s f h)
forall tr tr' slc slc' h v.
UnspreadMiddle tr slc h v
-> UnspreadLeft tr slc h
-> UnspreadRight tr slc h
-> Unsplit tr slc v
-> (StartStop slc
    -> Maybe tr' -> StartStop slc -> Bool -> [(tr, v)])
-> (slc' -> slc)
-> Eval tr tr' slc slc' h v
Eval
    UnspreadMiddle tr slc h (Leftmost s f h)
unspreadm'
    UnspreadLeft tr slc h
unspreadl
    UnspreadRight tr slc h
unspreadr
    Unsplit tr slc (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 = (p a b -> p a c) -> f (p a b) -> f (p a c)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> c) -> p a b -> p a c
forall b c a. (b -> c) -> p a b -> p a c
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' :: UnspreadMiddle tr slc h (Leftmost s f h)
  unspreadm' :: UnspreadMiddle tr slc h (Leftmost s f h)
unspreadm' (slc, tr, slc)
vert = ((slc, h, h) -> (slc, h, Leftmost s f h))
-> [(slc, h, h)] -> [(slc, h, Leftmost s f h)]
forall a b. (a -> b) -> [a] -> [b]
map (\(slc
top, h
op, h
v) -> (slc
top, h
op, h -> Leftmost s f h
forall h s f. h -> Leftmost s f h
LMSpread h
v)) ([(slc, h, h)] -> [(slc, h, Leftmost s f h)])
-> [(slc, h, h)] -> [(slc, h, Leftmost s f h)]
forall a b. (a -> b) -> a -> b
$ UnspreadMiddle tr slc h h
unspreadm (slc, tr, slc)
vert
  unsplit' :: Unsplit tr slc (Leftmost s f h)
unsplit' StartStop slc
sl tr
tl slc
sm tr
tr StartStop slc
sr SplitType
typ = (s -> Leftmost s f h) -> [(tr, s)] -> [(tr, Leftmost s f h)]
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 -> s -> Leftmost s f h
forall s f h. s -> Leftmost s f h
LMSplitLeft
      SplitType
SingleOfOne -> s -> Leftmost s f h
forall s f h. s -> Leftmost s f h
LMSplitOnly
      SplitType
RightOfTwo -> s -> Leftmost s f h
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 = (f -> Leftmost s f h) -> [(tr, f)] -> [(tr, Leftmost s f h)]
forall {f :: * -> *} {p :: * -> * -> *} {b} {c} {a}.
(Functor f, Bifunctor p) =>
(b -> c) -> f (p a b) -> f (p a c)
smap f -> Leftmost s f h
forall f s h. f -> Leftmost s f h
LMFreezeOnly [(tr, f)]
res
    | Bool
otherwise = (f -> Leftmost s f h) -> [(tr, f)] -> [(tr, Leftmost s f h)]
forall {f :: * -> *} {p :: * -> * -> *} {b} {c} {a}.
(Functor f, Bifunctor p) =>
(b -> c) -> f (p a b) -> f (p a c)
smap f -> Leftmost s f h
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) = Writer w b -> IndexedWriter w j k2 b
forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW (Writer w b -> IndexedWriter w j k2 b)
-> Writer w b -> IndexedWriter w j k2 b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> Writer w a -> Writer w b
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 = Writer w a -> IndexedWriter w i i a
forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW (Writer w a -> IndexedWriter w i i a)
-> Writer w a -> IndexedWriter w i i a
forall a b. (a -> b) -> a -> b
$ a -> Writer w a
forall a. a -> WriterT w Identity a
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) = Writer w b -> IndexedWriter w i k1 b
forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW (Writer w (a -> b)
wf Writer w (a -> b) -> Writer w a -> Writer w b
forall a b.
WriterT w Identity (a -> b)
-> WriterT w Identity a -> WriterT w Identity b
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) = Writer w b -> IndexedWriter w i k1 b
forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW (Writer w b -> IndexedWriter w i k1 b)
-> Writer w b -> IndexedWriter w i k1 b
forall a b. (a -> b) -> a -> b
$ (IndexedWriter w j k1 b -> Writer w b
forall {k} {k} w (i :: k) (j :: k) a.
IndexedWriter w i j a -> Writer w a
runIW (IndexedWriter w j k1 b -> Writer w b)
-> (a -> IndexedWriter w j k1 b) -> a -> Writer w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IndexedWriter w j k1 b
f) (a -> Writer w b) -> Writer w a -> Writer w b
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 = Writer w () -> IndexedWriter w i j ()
forall {k} {k} w (i :: k) (j :: k) a.
Writer w a -> IndexedWriter w i j a
IW (Writer w () -> IndexedWriter w i j ())
-> (w -> Writer w ()) -> w -> IndexedWriter w i j ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Writer w ()
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 = Writer [Leftmost s f h] () -> [Leftmost s f h]
forall w a. Writer w a -> w
MW.execWriter (Writer [Leftmost s f h] () -> [Leftmost s f h])
-> Writer [Leftmost s f h] () -> [Leftmost s f h]
forall a b. (a -> b) -> a -> b
$ DerivationAction s f h 1 n 'False snd -> Writer [Leftmost s f h] ()
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 = Writer [Leftmost s f h] () -> [Leftmost s f h]
forall w a. Writer w a -> w
MW.execWriter (Writer [Leftmost s f h] () -> [Leftmost s f h])
-> Writer [Leftmost s f h] () -> [Leftmost s f h]
forall a b. (a -> b) -> a -> b
$ DerivationAction s f h n n' 'False snd
-> Writer [Leftmost s f h] ()
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
  | Proxy n -> Nat
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal (Proxy n
forall {k} (t :: k). Proxy t
Proxy :: Proxy n) Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
1 = [Leftmost s f h]
-> IndexedWriter
     [Leftmost s f h]
     (DerivationInfo n 'False)
     (DerivationInfo (n + 1) 'False)
     ()
forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [s -> Leftmost s f h
forall s f h. s -> Leftmost s f h
LMSplitOnly s
s]
  | Bool
otherwise = [Leftmost s f h]
-> IndexedWriter
     [Leftmost s f h]
     (DerivationInfo n 'False)
     (DerivationInfo (n + 1) 'False)
     ()
forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [s -> Leftmost s f h
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
  | Proxy n -> Nat
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal (Proxy n
forall {k} (t :: k). Proxy t
Proxy :: Proxy n) Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
1 = [Leftmost s f h]
-> IndexedWriter
     [Leftmost s f h]
     (DerivationInfo n 'False)
     (DerivationInfo (n - 1) 'False)
     ()
forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [f -> Leftmost s f h
forall f s h. f -> Leftmost s f h
LMFreezeOnly f
f]
  | Bool
otherwise = [Leftmost s f h]
-> IndexedWriter
     [Leftmost s f h]
     (DerivationInfo n 'False)
     (DerivationInfo (n - 1) 'False)
     ()
forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [f -> Leftmost s f h
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 = [Leftmost s f h]
-> IndexedWriter
     [Leftmost s f h]
     (DerivationInfo n snd)
     (DerivationInfo (n + 1) 'True)
     ()
forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [s -> Leftmost s f h
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 = [Leftmost s f h]
-> IndexedWriter
     [Leftmost s f h]
     (DerivationInfo n snd)
     (DerivationInfo (n + 1) 'False)
     ()
forall {k} {k} w (i :: k) (j :: k).
Monoid w =>
w -> IndexedWriter w i j ()
itell [h -> Leftmost s f h
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
(Derivations a -> Derivations a -> Bool)
-> (Derivations a -> Derivations a -> Bool) -> Eq (Derivations a)
forall a. Eq a => Derivations a -> Derivations a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Derivations a -> Derivations a -> Bool
Eq, Eq (Derivations a)
Eq (Derivations a) =>
(Derivations a -> Derivations a -> Ordering)
-> (Derivations a -> Derivations a -> Bool)
-> (Derivations a -> Derivations a -> Bool)
-> (Derivations a -> Derivations a -> Bool)
-> (Derivations a -> Derivations a -> Bool)
-> (Derivations a -> Derivations a -> Derivations a)
-> (Derivations a -> Derivations a -> Derivations a)
-> Ord (Derivations a)
Derivations a -> Derivations a -> Bool
Derivations a -> Derivations a -> Ordering
Derivations a -> Derivations a -> Derivations a
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
$ccompare :: forall a. Ord a => Derivations a -> Derivations a -> Ordering
compare :: Derivations a -> Derivations a -> Ordering
$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
>= :: Derivations a -> Derivations a -> Bool
$cmax :: forall a. Ord a => Derivations a -> Derivations a -> Derivations a
max :: Derivations a -> Derivations a -> Derivations a
$cmin :: forall a. Ord a => Derivations a -> Derivations a -> Derivations a
min :: Derivations a -> Derivations a -> Derivations a
Ord, (forall x. Derivations a -> Rep (Derivations a) x)
-> (forall x. Rep (Derivations a) x -> Derivations a)
-> Generic (Derivations a)
forall x. Rep (Derivations a) x -> Derivations a
forall x. Derivations a -> Rep (Derivations a) x
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
$cfrom :: forall a x. Derivations a -> Rep (Derivations a) x
from :: forall x. Derivations a -> Rep (Derivations a) x
$cto :: forall a x. Rep (Derivations a) x -> Derivations a
to :: forall x. Rep (Derivations a) x -> Derivations a
Generic)

instance (NFData a) => NFData (Derivations a)

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

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

instance R.Semiring (Derivations a) where
  zero :: Derivations a
zero = Derivations a
forall a. Derivations a
Cannot
  one :: Derivations a
one = Derivations a
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 = Derivations a -> Derivations a -> Derivations a
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
_ = Derivations a
forall a. Derivations a
Cannot
  times Derivations a
_ Derivations a
Cannot = Derivations a
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 = Derivations a -> Derivations a -> Derivations a
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 = r
forall a. Semiring a => a
R.one
mapDerivations a -> r
_ Derivations a
Cannot = r
forall a. Semiring a => a
R.zero
mapDerivations a -> r
f (Or Derivations a
a Derivations a
b) = (a -> r) -> Derivations a -> r
forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations a -> r
f Derivations a
a r -> r -> r
forall a. Semiring a => a -> a -> a
R.+ (a -> r) -> Derivations 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) = (a -> r) -> Derivations a -> r
forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations a -> r
f Derivations a
a r -> r -> r
forall a. Semiring a => a -> a -> a
R.* (a -> r) -> Derivations 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 = (a -> Set [a]) -> Derivations a -> Set [a]
forall r a. Semiring r => (a -> r) -> Derivations a -> r
mapDerivations (\a
a -> [a] -> Set [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) = [a] -> [[a]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a
a]
flattenDerivationsRed Derivations a
NoOp = [a] -> [[a]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
flattenDerivationsRed Derivations a
Cannot = []
flattenDerivationsRed (Or Derivations a
a Derivations a
b) =
  Derivations a -> [[a]]
forall a. Ord a => Derivations a -> [[a]]
flattenDerivationsRed Derivations a
a [[a]] -> [[a]] -> [[a]]
forall a. Semigroup a => a -> a -> a
<> Derivations a -> [[a]]
forall a. Ord a => Derivations a -> [[a]]
flattenDerivationsRed Derivations a
b
flattenDerivationsRed (Then Derivations a
a Derivations a
b) = do
  as <- Derivations a -> [[a]]
forall a. Ord a => Derivations a -> [[a]]
flattenDerivationsRed Derivations a
a
  bs <- flattenDerivationsRed b
  pure (as <> 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 = Maybe [a]
forall a. Maybe a
Nothing
firstDerivation Derivations a
NoOp = [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
firstDerivation (Do a
a) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
a]
firstDerivation (Or Derivations a
a Derivations a
_) = Derivations a -> Maybe [a]
forall a. Ord a => Derivations a -> Maybe [a]
firstDerivation Derivations a
a
firstDerivation (Then Derivations a
a Derivations a
b) = do
  da <- Derivations a -> Maybe [a]
forall a. Ord a => Derivations a -> Maybe [a]
firstDerivation Derivations a
a
  db <- firstDerivation b
  pure $ da <> db

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

-- | Compute the cartesian product for a list of lists
cartProd :: [[a]] -> [[a]]
cartProd :: forall a. [[a]] -> [[a]]
cartProd [] = [a] -> [[a]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
cartProd ([a]
g : [[a]]
gs) = do
  matching <- [a]
g
  rest <- cartProd gs
  pure $ matching : rest

-- | 'traverse' on a 'HashSet'
traverseSet
  :: (Applicative f, Eq n', Hashable n')
  => (n -> f n')
  -> HS.HashSet n
  -> f (HS.HashSet n')
traverseSet :: forall (f :: * -> *) n' n.
(Applicative f, Eq n', Hashable n') =>
(n -> f n') -> HashSet n -> f (HashSet n')
traverseSet n -> f n'
f HashSet n
set = [n'] -> HashSet n'
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([n'] -> HashSet n') -> f [n'] -> f (HashSet n')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (n -> f n') -> [n] -> f [n']
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse n -> f n'
f (HashSet n -> [n]
forall a. HashSet a -> [a]
HS.toList HashSet n
set)

-- | 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l Bool -> Bool -> Bool
&& Bool
value then String -> Bool -> Bool
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 Char -> ShowS
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
    { Aeson.constructorTagModifier = rename
    , Aeson.sumEncoding = Aeson.TaggedObject "type" "value"
    }

-- | Convert special characters to TeX commands.
showTex :: (Show a) => a -> String
showTex :: forall a. Show a => a -> String
showTex a
x = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeTex ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ a -> String
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 (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
showTex