> {-# OPTIONS_HADDOCK show-extensions #-}
> {-# Language CPP #-}

#if !defined(MIN_VERSION_base)
# define MIN_VERSION_base(a,b,c) 0
#endif

> {-|
> Module:    LTK.Porters.Pleb
> Copyright: (c) 2018-2023 Dakotah Lambert
> License:   MIT

> The (P)iecewise / (L)ocal (E)xpression (B)uilder.
> This module defines a parser for a representation of
> logical formulae over subsequence- and adjacency-factors,
> as well as a mechanism for evaluating (creating an 'FSA' from)
> the resulting expression tree.

> There are two special variables:
> 
> * @it@ describes the most recent expression, and
> 
> * @universe@ collects all symbols used.
> -}
> module LTK.Porters.Pleb
>        ( Dictionary
>        , Parse(..)
>        , Env
>        , Expr
>        , SymSet
>        , Token
>        , compileEnv
>        , groundEnv
>        , insertExpr
>        , fromAutomaton
>        , fromSemanticAutomaton
>        , makeAutomaton
>        , doStatements
>        , parseExpr
>        , readPleb
>        , restrictUniverse
>        , tokenize
>        ) where

#if !MIN_VERSION_base(4,8,0)
> import Data.Functor ((<$>))
> import Data.Monoid (mconcat)
> import Control.Applicative (Applicative, pure, (<*>))
#endif
> import Control.Applicative ( Alternative
>                            , empty, many, some, (<|>))
> import Data.Char (isLetter, isSpace)
> import Data.Foldable (asum)
> import Data.List (intersperse,foldl1')
> import Data.Set (Set)
> import qualified Data.Set as Set

> import LTK.FSA
> import LTK.Factors (Factor(..), buildLiteral, required)
> import LTK.Extract.SP (subsequenceClosure)

> -- |A syntactic unit.
> data Token = TSymbol Char
>            | TName String
>              deriving (Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq, Eq Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmax :: Token -> Token -> Token
>= :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c< :: Token -> Token -> Bool
compare :: Token -> Token -> Ordering
$ccompare :: Token -> Token -> Ordering
Ord, ReadPrec [Token]
ReadPrec Token
Int -> ReadS Token
ReadS [Token]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Token]
$creadListPrec :: ReadPrec [Token]
readPrec :: ReadPrec Token
$creadPrec :: ReadPrec Token
readList :: ReadS [Token]
$creadList :: ReadS [Token]
readsPrec :: Int -> ReadS Token
$creadsPrec :: Int -> ReadS Token
Read, Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)

> -- |Convert a string into a stream of tokens ready for parsing.
> tokenize  :: String -> [Token]
> tokenize :: String -> [Token]
tokenize String
"" = []
> tokenize (Char
x:String
xs)
>     | Char
x forall a. Eq a => a -> a -> Bool
== Char
'#'    =  String -> [Token]
tokenize (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
xs)
>     | Char -> Bool
isSpace Char
x   =  String -> [Token]
tokenize (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
xs)
>     | Char -> Bool
isLetter Char
x  =  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b) -> (a, c) -> (b, c)
mapfst String -> Token
TName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [Token]
tokenize forall a b. (a -> b) -> a -> b
$
>                      forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\Char
s -> Char
s forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char -> Bool
isDelim Char
s Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
s) (Char
xforall a. a -> [a] -> [a]
:String
xs)
>     | Bool
otherwise   =  Char -> Token
TSymbol Char
x forall a. a -> [a] -> [a]
: String -> [Token]
tokenize String
xs
>     where isDelim :: Char -> Bool
isDelim Char
c = Char -> Char
matchingDelimiter Char
c forall a. Eq a => a -> a -> Bool
/= Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'|'

> -- |The environment: defined sets of symbols, defined expressions, and
> -- possibly a value for the special variable @(it)@.
> type Env = (Dictionary SymSet, Dictionary Expr, Maybe Expr)

> -- |An expression, the root of an expression tree.
> data Expr
>     = NAry NAryExpr
>     | Unary UnaryExpr
>     | Factor PLFactor
>     | Automaton (FSA Integer (Maybe String))
>       deriving (Expr -> Expr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c== :: Expr -> Expr -> Bool
Eq, Eq Expr
Expr -> Expr -> Bool
Expr -> Expr -> Ordering
Expr -> Expr -> Expr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Expr -> Expr -> Expr
$cmin :: Expr -> Expr -> Expr
max :: Expr -> Expr -> Expr
$cmax :: Expr -> Expr -> Expr
>= :: Expr -> Expr -> Bool
$c>= :: Expr -> Expr -> Bool
> :: Expr -> Expr -> Bool
$c> :: Expr -> Expr -> Bool
<= :: Expr -> Expr -> Bool
$c<= :: Expr -> Expr -> Bool
< :: Expr -> Expr -> Bool
$c< :: Expr -> Expr -> Bool
compare :: Expr -> Expr -> Ordering
$ccompare :: Expr -> Expr -> Ordering
Ord, ReadPrec [Expr]
ReadPrec Expr
Int -> ReadS Expr
ReadS [Expr]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Expr]
$creadListPrec :: ReadPrec [Expr]
readPrec :: ReadPrec Expr
$creadPrec :: ReadPrec Expr
readList :: ReadS [Expr]
$creadList :: ReadS [Expr]
readsPrec :: Int -> ReadS Expr
$creadsPrec :: Int -> ReadS Expr
Read, Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show)

> -- |A subexpression that consists of an n-ary operator and its operands.
> data NAryExpr
>     = Concatenation [Expr]
>     | Conjunction   [Expr]
>     | Disjunction   [Expr]
>     | Domination    [Expr]
>     | Infiltration  [Expr] -- ^@since 1.1
>     | Shuffle       [Expr] -- ^@since 1.1
>     | QuotientL     [Expr] -- ^@since 1.0
>     | QuotientR     [Expr] -- ^@since 1.0
>       deriving (NAryExpr -> NAryExpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NAryExpr -> NAryExpr -> Bool
$c/= :: NAryExpr -> NAryExpr -> Bool
== :: NAryExpr -> NAryExpr -> Bool
$c== :: NAryExpr -> NAryExpr -> Bool
Eq, Eq NAryExpr
NAryExpr -> NAryExpr -> Bool
NAryExpr -> NAryExpr -> Ordering
NAryExpr -> NAryExpr -> NAryExpr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NAryExpr -> NAryExpr -> NAryExpr
$cmin :: NAryExpr -> NAryExpr -> NAryExpr
max :: NAryExpr -> NAryExpr -> NAryExpr
$cmax :: NAryExpr -> NAryExpr -> NAryExpr
>= :: NAryExpr -> NAryExpr -> Bool
$c>= :: NAryExpr -> NAryExpr -> Bool
> :: NAryExpr -> NAryExpr -> Bool
$c> :: NAryExpr -> NAryExpr -> Bool
<= :: NAryExpr -> NAryExpr -> Bool
$c<= :: NAryExpr -> NAryExpr -> Bool
< :: NAryExpr -> NAryExpr -> Bool
$c< :: NAryExpr -> NAryExpr -> Bool
compare :: NAryExpr -> NAryExpr -> Ordering
$ccompare :: NAryExpr -> NAryExpr -> Ordering
Ord, ReadPrec [NAryExpr]
ReadPrec NAryExpr
Int -> ReadS NAryExpr
ReadS [NAryExpr]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NAryExpr]
$creadListPrec :: ReadPrec [NAryExpr]
readPrec :: ReadPrec NAryExpr
$creadPrec :: ReadPrec NAryExpr
readList :: ReadS [NAryExpr]
$creadList :: ReadS [NAryExpr]
readsPrec :: Int -> ReadS NAryExpr
$creadsPrec :: Int -> ReadS NAryExpr
Read, Int -> NAryExpr -> ShowS
[NAryExpr] -> ShowS
NAryExpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NAryExpr] -> ShowS
$cshowList :: [NAryExpr] -> ShowS
show :: NAryExpr -> String
$cshow :: NAryExpr -> String
showsPrec :: Int -> NAryExpr -> ShowS
$cshowsPrec :: Int -> NAryExpr -> ShowS
Show)

> -- |A subexpression that consists of a unary operator and its operand.
> data UnaryExpr
>     = DownClose Expr -- ^@since 1.0
>     | Iteration Expr
>     | Negation Expr
>     | Neutralize [SymSet] Expr -- ^@since 1.1
>     | Reversal Expr -- ^@since 1.1
>     | Tierify [SymSet] Expr
>     | UpClose Expr -- ^@since 1.1
>       deriving (UnaryExpr -> UnaryExpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnaryExpr -> UnaryExpr -> Bool
$c/= :: UnaryExpr -> UnaryExpr -> Bool
== :: UnaryExpr -> UnaryExpr -> Bool
$c== :: UnaryExpr -> UnaryExpr -> Bool
Eq, Eq UnaryExpr
UnaryExpr -> UnaryExpr -> Bool
UnaryExpr -> UnaryExpr -> Ordering
UnaryExpr -> UnaryExpr -> UnaryExpr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnaryExpr -> UnaryExpr -> UnaryExpr
$cmin :: UnaryExpr -> UnaryExpr -> UnaryExpr
max :: UnaryExpr -> UnaryExpr -> UnaryExpr
$cmax :: UnaryExpr -> UnaryExpr -> UnaryExpr
>= :: UnaryExpr -> UnaryExpr -> Bool
$c>= :: UnaryExpr -> UnaryExpr -> Bool
> :: UnaryExpr -> UnaryExpr -> Bool
$c> :: UnaryExpr -> UnaryExpr -> Bool
<= :: UnaryExpr -> UnaryExpr -> Bool
$c<= :: UnaryExpr -> UnaryExpr -> Bool
< :: UnaryExpr -> UnaryExpr -> Bool
$c< :: UnaryExpr -> UnaryExpr -> Bool
compare :: UnaryExpr -> UnaryExpr -> Ordering
$ccompare :: UnaryExpr -> UnaryExpr -> Ordering
Ord, ReadPrec [UnaryExpr]
ReadPrec UnaryExpr
Int -> ReadS UnaryExpr
ReadS [UnaryExpr]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UnaryExpr]
$creadListPrec :: ReadPrec [UnaryExpr]
readPrec :: ReadPrec UnaryExpr
$creadPrec :: ReadPrec UnaryExpr
readList :: ReadS [UnaryExpr]
$creadList :: ReadS [UnaryExpr]
readsPrec :: Int -> ReadS UnaryExpr
$creadsPrec :: Int -> ReadS UnaryExpr
Read, Int -> UnaryExpr -> ShowS
[UnaryExpr] -> ShowS
UnaryExpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnaryExpr] -> ShowS
$cshowList :: [UnaryExpr] -> ShowS
show :: UnaryExpr -> String
$cshow :: UnaryExpr -> String
showsPrec :: Int -> UnaryExpr -> ShowS
$cshowsPrec :: Int -> UnaryExpr -> ShowS
Show)

> -- |A subexpression representing a single Piecewise-Local factor.
> data PLFactor
>     = PLFactor Bool Bool [[SymSet]]
>       deriving (PLFactor -> PLFactor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PLFactor -> PLFactor -> Bool
$c/= :: PLFactor -> PLFactor -> Bool
== :: PLFactor -> PLFactor -> Bool
$c== :: PLFactor -> PLFactor -> Bool
Eq, Eq PLFactor
PLFactor -> PLFactor -> Bool
PLFactor -> PLFactor -> Ordering
PLFactor -> PLFactor -> PLFactor
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PLFactor -> PLFactor -> PLFactor
$cmin :: PLFactor -> PLFactor -> PLFactor
max :: PLFactor -> PLFactor -> PLFactor
$cmax :: PLFactor -> PLFactor -> PLFactor
>= :: PLFactor -> PLFactor -> Bool
$c>= :: PLFactor -> PLFactor -> Bool
> :: PLFactor -> PLFactor -> Bool
$c> :: PLFactor -> PLFactor -> Bool
<= :: PLFactor -> PLFactor -> Bool
$c<= :: PLFactor -> PLFactor -> Bool
< :: PLFactor -> PLFactor -> Bool
$c< :: PLFactor -> PLFactor -> Bool
compare :: PLFactor -> PLFactor -> Ordering
$ccompare :: PLFactor -> PLFactor -> Ordering
Ord, ReadPrec [PLFactor]
ReadPrec PLFactor
Int -> ReadS PLFactor
ReadS [PLFactor]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PLFactor]
$creadListPrec :: ReadPrec [PLFactor]
readPrec :: ReadPrec PLFactor
$creadPrec :: ReadPrec PLFactor
readList :: ReadS [PLFactor]
$creadList :: ReadS [PLFactor]
readsPrec :: Int -> ReadS PLFactor
$creadsPrec :: Int -> ReadS PLFactor
Read, Int -> PLFactor -> ShowS
[PLFactor] -> ShowS
PLFactor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PLFactor] -> ShowS
$cshowList :: [PLFactor] -> ShowS
show :: PLFactor -> String
$cshow :: PLFactor -> String
showsPrec :: Int -> PLFactor -> ShowS
$cshowsPrec :: Int -> PLFactor -> ShowS
Show)

> -- |A set of symbols.
> type SymSet = Set String

> -- |Parse an input string and create a stringset-automaton from the result.
> -- If there is an error while parsing, the result is the string "no parse".
> readPleb :: String -> Either String (FSA Integer String)
> readPleb :: String -> Either String (FSA Integer String)
readPleb = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left String
"no parse") (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Ord a, Ord b) => FSA a (Maybe b) -> FSA a b
desemantify) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (Env -> Maybe (FSA Integer (Maybe String))
makeAutomaton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>            forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse (Env -> Parse Env
parseStatements (forall a. Set a
Set.empty, forall a. Set a
Set.empty, forall a. Maybe a
Nothing)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>            String -> [Token]
tokenize

> -- |Parse an input string and update the environment
> -- according to the result of the parse.
> doStatements :: Env -> String -> Env
> doStatements :: Env -> String -> Env
doStatements Env
d String
str  =  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Env
d) forall {a}. (Env, [a]) -> Env
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                        forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse (Env -> Parse Env
parseStatements Env
d) forall a b. (a -> b) -> a -> b
$
>                        String -> [Token]
tokenize String
str
>     where f :: (Env, [a]) -> Env
f (Env
x, [])  =  Env
x
>           f (Env, [a])
_        =  Env
d

> -- |Add a new expression to the environment, call it "@(it)@".
> insertExpr :: Env -> Expr -> Env
> insertExpr :: Env -> Expr -> Env
insertExpr (Set (String, SymSet)
dict, Set (String, Expr)
subexprs, Maybe Expr
_) Expr
e
>     = Env -> String -> Env
doStatements (Set (String, SymSet)
dict, forall a. Ord a => String -> a -> Dictionary a -> Dictionary a
define String
"it" Expr
e Set (String, Expr)
subexprs, forall a. a -> Maybe a
Just Expr
e) String
"= it it"

> -- |Transform all saved expressions into automata to prevent reevaluation.
> compileEnv :: Env -> Env
> compileEnv :: Env -> Env
compileEnv (Set (String, SymSet)
dict, Set (String, Expr)
subexprs, Maybe Expr
e) = (Set (String, SymSet)
dict, forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapsnd Expr -> Expr
f) Set (String, Expr)
subexprs, Expr -> Expr
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Expr
e)
>     where f :: Expr -> Expr
f = FSA Integer (Maybe String) -> Expr
Automaton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> FSA Integer (Maybe String)
automatonFromExpr

> -- |Convert saved automata from descriptions of constraints to
> -- descriptions of stringsets.
> -- This action effectively removes metadata describing constraint types
> -- from the environment.
> groundEnv :: Env -> Env
> groundEnv :: Env -> Env
groundEnv (Set (String, SymSet)
dict, Set (String, Expr)
subexprs, Maybe Expr
e) = (Set (String, SymSet)
dict, forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapsnd Expr -> Expr
f) Set (String, Expr)
subexprs, Expr -> Expr
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Expr
e)
>     where f :: Expr -> Expr
f = FSA Integer (Maybe String) -> Expr
Automaton forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>               forall e e1 n.
(Ord e, Ord e1, Ord n) =>
(e -> e1) -> FSA n e -> FSA n e1
renameSymbolsBy forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>               forall a b. (Ord a, Ord b) => FSA a (Maybe b) -> FSA a b
desemantify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b.
(Ord a, Ord b) =>
Set b -> FSA a (Maybe b) -> FSA a (Maybe b)
semanticallyExtendAlphabetTo SymSet
universe forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>               Expr -> FSA Integer (Maybe String)
automatonFromExpr
>           universe :: SymSet
universe = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Set a
Set.empty) forall a. a -> a
id (forall a. Ord a => String -> Dictionary a -> Either String a
definition String
"universe" Set (String, SymSet)
dict)

=====
Note:
=====

@restrictUniverse@ previously deleted symbolsets bound to the empty set.
However, it is now possible to manually define the empty set: [/a,/b].
Therefore, this cleanup step has been removed.

> -- |Remove any symbols not present in @(universe)@ from the environment.
> restrictUniverse :: Env -> Env
> restrictUniverse :: Env -> Env
restrictUniverse (Set (String, SymSet)
dict, Set (String, Expr)
subexprs, Maybe Expr
v)
>     = ( forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapsnd SymSet -> SymSet
restrictUniverseS) Set (String, SymSet)
dict
>       , forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapsnd Expr -> Expr
restrictUniverseE) Set (String, Expr)
subexprs
>       , Expr -> Expr
restrictUniverseE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Expr
v
>       )
>     where universe :: SymSet
universe           =  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Set a
Set.empty) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
>                                 forall a. Ord a => String -> Dictionary a -> Either String a
definition String
"universe" Set (String, SymSet)
dict
>           restrictUniverseS :: SymSet -> SymSet
restrictUniverseS  =  forall c a. (Container c a, Eq a) => c -> c -> c
intersection SymSet
universe
>           restrictUniverseE :: Expr -> Expr
restrictUniverseE Expr
e
>               = case Expr
e
>                 of Automaton FSA Integer (Maybe String)
x
>                        ->  FSA Integer (Maybe String) -> Expr
Automaton forall a b. (a -> b) -> a -> b
$
>                            forall a b. (Ord a, Ord b) => Set b -> FSA a b -> FSA a b
contractAlphabetTo
>                            (forall c a. Container c a => a -> c -> c
insert forall a. Maybe a
Nothing (forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap forall a. a -> Maybe a
Just SymSet
universe))
>                            FSA Integer (Maybe String)
x
>                    Factor (PLFactor Bool
h Bool
t [[SymSet]]
ps)
>                        -> Bool -> Bool -> [[SymSet]] -> Expr
fixFactor Bool
h Bool
t forall a b. (a -> b) -> a -> b
$ forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap (forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap SymSet -> SymSet
restrictUniverseS) [[SymSet]]
ps
>                    NAry (Concatenation [Expr]
es)  ->  ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
Concatenation [Expr]
es
>                    NAry (Conjunction [Expr]
es)    ->  ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
Conjunction [Expr]
es
>                    NAry (Disjunction [Expr]
es)    ->  ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
Disjunction [Expr]
es
>                    NAry (Domination [Expr]
es)     ->  ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
Domination [Expr]
es
>                    NAry (Infiltration [Expr]
es)   ->  ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
Infiltration [Expr]
es
>                    NAry (Shuffle [Expr]
es)        ->  ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
Shuffle [Expr]
es
>                    NAry (QuotientL [Expr]
es)      ->  ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
QuotientL [Expr]
es
>                    NAry (QuotientR [Expr]
es)      ->  ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
QuotientR [Expr]
es
>                    Unary (DownClose Expr
ex)     ->  (Expr -> UnaryExpr) -> Expr -> Expr
g Expr -> UnaryExpr
DownClose Expr
ex
>                    Unary (Iteration Expr
ex)     ->  (Expr -> UnaryExpr) -> Expr -> Expr
g Expr -> UnaryExpr
Iteration Expr
ex
>                    Unary (Negation Expr
ex)      ->  (Expr -> UnaryExpr) -> Expr -> Expr
g Expr -> UnaryExpr
Negation Expr
ex
>                    Unary (Neutralize [SymSet]
ts Expr
ex)
>                        -> (Expr -> UnaryExpr) -> Expr -> Expr
g ([SymSet] -> Expr -> UnaryExpr
Neutralize (forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap SymSet -> SymSet
restrictUniverseS [SymSet]
ts)) Expr
ex
>                    Unary (Reversal Expr
ex)      ->  (Expr -> UnaryExpr) -> Expr -> Expr
g Expr -> UnaryExpr
Reversal Expr
ex
>                    Unary (Tierify [SymSet]
ts Expr
ex)
>                        -> (Expr -> UnaryExpr) -> Expr -> Expr
g ([SymSet] -> Expr -> UnaryExpr
Tierify (forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap SymSet -> SymSet
restrictUniverseS [SymSet]
ts)) Expr
ex
>                    Unary (UpClose Expr
ex)       ->  (Expr -> UnaryExpr) -> Expr -> Expr
g Expr -> UnaryExpr
UpClose Expr
ex
>           f :: ([Expr] -> NAryExpr) -> [Expr] -> Expr
f [Expr] -> NAryExpr
t [Expr]
es = NAryExpr -> Expr
NAry ([Expr] -> NAryExpr
t forall a b. (a -> b) -> a -> b
$ forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap Expr -> Expr
restrictUniverseE [Expr]
es)
>           g :: (Expr -> UnaryExpr) -> Expr -> Expr
g Expr -> UnaryExpr
t Expr
e  = UnaryExpr -> Expr
Unary (Expr -> UnaryExpr
t forall a b. (a -> b) -> a -> b
$ Expr -> Expr
restrictUniverseE Expr
e)
>           fixFactor :: Bool -> Bool -> [[SymSet]] -> Expr
fixFactor Bool
h Bool
t [[SymSet]]
ps
>               | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall c a. Container c a => c -> Bool
isEmpty) [[SymSet]]
ps
>                   = UnaryExpr -> Expr
Unary (Expr -> UnaryExpr
Negation (PLFactor -> Expr
Factor (Bool -> Bool -> [[SymSet]] -> PLFactor
PLFactor Bool
False Bool
False [])))
>                     -- <> and ~<> are essentially True and False
>               | Bool
otherwise = PLFactor -> Expr
Factor (Bool -> Bool -> [[SymSet]] -> PLFactor
PLFactor Bool
h Bool
t [[SymSet]]
ps)

> -- |Create an 'FSA' from an expression tree and environment,
> -- complete with metadata regarding the constraint(s) it represents.
> makeAutomaton :: Env -> Maybe (FSA Integer (Maybe String))
> makeAutomaton :: Env -> Maybe (FSA Integer (Maybe String))
makeAutomaton (Set (String, SymSet)
dict, Set (String, Expr)
_, Maybe Expr
e) = forall e n. (Ord e, Ord n) => FSA n e -> FSA Integer e
normalize
>                              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b.
(Ord a, Ord b) =>
Set b -> FSA a (Maybe b) -> FSA a (Maybe b)
semanticallyExtendAlphabetTo SymSet
symsets
>                              forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> FSA Integer (Maybe String)
automatonFromExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Expr
e
>     where symsets :: SymSet
symsets = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Set a
Set.empty) forall a. a -> a
id
>                     forall a b. (a -> b) -> a -> b
$ forall a. Ord a => String -> Dictionary a -> Either String a
definition String
"universe" Set (String, SymSet)
dict

The properties of semantic automata are used here to prevent having to
pass alphabet information to the individual constructors, which in turn
prevents having to descend through the tree to find this information.

> -- |Create an 'FSA' from an expression tree,
> -- complete with metadata regarding the constraint(s) it represents.
> automatonFromExpr :: Expr -> FSA Integer (Maybe String)
> automatonFromExpr :: Expr -> FSA Integer (Maybe String)
automatonFromExpr Expr
e
>     = case Expr
e
>       of Automaton FSA Integer (Maybe String)
x             -> FSA Integer (Maybe String)
x
>          Factor PLFactor
x                -> PLFactor -> FSA Integer (Maybe String)
automatonFromPLFactor PLFactor
x
>          NAry (Concatenation [Expr]
es) -> forall {e} {n} {n1}.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f FSA Integer (Maybe String)
emptyStr forall a. Monoid a => [a] -> a
mconcat [Expr]
es
>          NAry (Conjunction [Expr]
es)   -> forall {e} {n} {n1}.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f FSA Integer (Maybe String)
univLang forall n e.
(Enum n, Ord n, NFData n, Ord e, NFData e) =>
[FSA n e] -> FSA n e
flatIntersection [Expr]
es
>          NAry (Disjunction [Expr]
es)   -> forall {e} {n} {n1}.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f forall e n. (Ord e, Ord n, Enum n) => FSA n e
emptyLanguage forall n e.
(Enum n, Ord n, NFData n, Ord e, NFData e) =>
[FSA n e] -> FSA n e
flatUnion [Expr]
es
>          NAry (Domination [Expr]
es)
>              -> forall {e} {n} {n1}.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f FSA Integer (Maybe String)
emptyStr
>                 (forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                  forall a. a -> [a] -> [a]
intersperse (forall e n. (Ord e, Enum n, Ord n) => Set e -> FSA n e
totalWithAlphabet (forall c a. Container c a => a -> c
singleton forall a. Maybe a
Nothing))
>                 ) [Expr]
es
>          NAry (Infiltration [Expr]
es)  -> forall {e} {n} {n1}.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f FSA Integer (Maybe String)
emptyStr forall n e.
(Enum n, Ord n, NFData n, Ord e, NFData e) =>
[FSA n e] -> FSA n e
flatInfiltration [Expr]
es
>          NAry (Shuffle [Expr]
es)       -> forall {e} {n} {n1}.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f FSA Integer (Maybe String)
emptyStr forall n e.
(Enum n, Ord n, NFData n, Ord e, NFData e) =>
[FSA n e] -> FSA n e
flatShuffle [Expr]
es
>          NAry (QuotientL [Expr]
es)     -> forall {e} {n} {n1}.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f FSA Integer (Maybe String)
emptyStr forall {n2} {a}.
(Enum n2, Ord a, Ord n2) =>
[FSA n2 (Maybe a)] -> FSA n2 (Maybe a)
ql [Expr]
es
>          NAry (QuotientR [Expr]
es)     -> forall {e} {n} {n1}.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f FSA Integer (Maybe String)
emptyStr forall {t :: * -> *} {n2} {a}.
(Foldable t, Enum n2, Ord a, Ord n2) =>
t (FSA n2 (Maybe a)) -> FSA n2 (Maybe a)
qr [Expr]
es
>          Unary (DownClose Expr
ex)
>              -> forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. (Ord n, Ord e) => FSA n e -> FSA n e
subsequenceClosure forall a b. (a -> b) -> a -> b
$
>                 Expr -> FSA Integer (Maybe String)
automatonFromExpr Expr
ex
>          Unary (Iteration Expr
ex)
>              -> forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. (Ord n, Ord e) => FSA n e -> FSA (Either n Bool) e
kleeneClosure forall a b. (a -> b) -> a -> b
$
>                 Expr -> FSA Integer (Maybe String)
automatonFromExpr Expr
ex
>          Unary (Negation Expr
ex)
>              -> forall e n. (Ord e, Ord n) => FSA n e -> FSA n e
complementDeterministic forall a b. (a -> b) -> a -> b
$ Expr -> FSA Integer (Maybe String)
automatonFromExpr Expr
ex
>          Unary (Neutralize [SymSet]
ts Expr
ex)
>              -> forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize
>                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Ord a, Ord b) => Set b -> FSA a b -> FSA a b
neutralize (forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall c a (s :: * -> *).
(Container c a, Collapsible s) =>
s c -> c
unionAll [SymSet]
ts)
>                 forall a b. (a -> b) -> a -> b
$ Expr -> FSA Integer (Maybe String)
automatonFromExpr Expr
ex
>          Unary (Reversal Expr
ex)
>              -> forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA n e
LTK.FSA.reverse
>                 forall a b. (a -> b) -> a -> b
$ Expr -> FSA Integer (Maybe String)
automatonFromExpr Expr
ex
>          Unary (Tierify [SymSet]
ts Expr
ex)
>              -> forall a b.
(Ord a, Ord b) =>
Set b -> FSA a (Maybe b) -> FSA a (Maybe b)
tierify (forall c a (s :: * -> *).
(Container c a, Collapsible s) =>
s c -> c
unionAll [SymSet]
ts) forall a b. (a -> b) -> a -> b
$ Expr -> FSA Integer (Maybe String)
automatonFromExpr Expr
ex
>          Unary (UpClose Expr
ex)
>              -> forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set n) e
determinize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. (Ord n, Ord e) => FSA n e -> FSA n e
loopify forall a b. (a -> b) -> a -> b
$
>                 Expr -> FSA Integer (Maybe String)
automatonFromExpr Expr
ex
>     where f :: FSA n1 e
-> ([FSA Integer (Maybe String)] -> FSA n e) -> [Expr] -> FSA n1 e
f FSA n1 e
z [FSA Integer (Maybe String)] -> FSA n e
tl [Expr]
xs = case [Expr] -> [FSA Integer (Maybe String)]
automata [Expr]
xs
>                       of [] -> FSA n1 e
z
>                          [FSA Integer (Maybe String)]
a -> forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize forall a b. (a -> b) -> a -> b
$ [FSA Integer (Maybe String)] -> FSA n e
tl [FSA Integer (Maybe String)]
a
>           automata :: [Expr] -> [FSA Integer (Maybe String)]
automata [Expr]
es
>               =  let as :: [FSA Integer (Maybe String)]
as = forall a b. (a -> b) -> [a] -> [b]
map Expr -> FSA Integer (Maybe String)
automatonFromExpr [Expr]
es
>                  in forall a b. (a -> b) -> [a] -> [b]
map (forall a b.
(Ord a, Ord b) =>
Set b -> FSA a (Maybe b) -> FSA a (Maybe b)
semanticallyExtendAlphabetTo forall a b. (a -> b) -> a -> b
$ [FSA Integer (Maybe String)] -> SymSet
bigAlpha [FSA Integer (Maybe String)]
as) [FSA Integer (Maybe String)]
as
>           univLang :: FSA Integer (Maybe String)
univLang = forall e n. (Ord e, Enum n, Ord n) => Set e -> FSA n e
totalWithAlphabet (forall a. a -> Set a
Set.singleton forall a. Maybe a
Nothing)
>           emptyStr :: FSA Integer (Maybe String)
emptyStr = forall e n. (Ord e, Enum n, Ord n) => Set e -> FSA n e
totalWithAlphabet forall a. Set a
Set.empty
>           bigAlpha :: [FSA Integer (Maybe String)] -> SymSet
bigAlpha = forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall c a. Container c a => a -> c -> c
insert) forall a. Set a
Set.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall c a. Container c a => c -> c -> c
union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet) forall a. Set a
Set.empty
>           ql :: [FSA n2 (Maybe a)] -> FSA n2 (Maybe a)
ql [FSA n2 (Maybe a)]
xs = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FSA n2 (Maybe a)]
xs
>                   then forall e n. (Ord e, Enum n, Ord n) => Set e -> FSA n e
emptyWithAlphabet (forall a. a -> Set a
Set.singleton forall a. Maybe a
Nothing)
>                   else forall a. (a -> a -> a) -> [a] -> a
foldl1' (\FSA n2 (Maybe a)
a FSA n2 (Maybe a)
b -> forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall a b. (a -> b) -> a -> b
$ forall e n1 n2.
(Ord e, Ord n1, Ord n2) =>
FSA n1 e -> FSA n2 e -> FSA (Maybe (Either n1 ()), Maybe n2) e
quotLeft FSA n2 (Maybe a)
a FSA n2 (Maybe a)
b) [FSA n2 (Maybe a)]
xs
>           qr :: t (FSA n2 (Maybe a)) -> FSA n2 (Maybe a)
qr t (FSA n2 (Maybe a))
xs = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (FSA n2 (Maybe a))
xs
>                   then forall e n. (Ord e, Enum n, Ord n) => Set e -> FSA n e
emptyWithAlphabet (forall a. a -> Set a
Set.singleton forall a. Maybe a
Nothing)
>                   else forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\FSA n2 (Maybe a)
a FSA n2 (Maybe a)
b -> forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall a b. (a -> b) -> a -> b
$ forall e n1 n2.
(Ord e, Ord n1, Ord n2) =>
FSA n1 e -> FSA n2 e -> FSA Integer e
quotRight FSA n2 (Maybe a)
a FSA n2 (Maybe a)
b) t (FSA n2 (Maybe a))
xs

> automatonFromPLFactor :: PLFactor -> FSA Integer (Maybe String)
> automatonFromPLFactor :: PLFactor -> FSA Integer (Maybe String)
automatonFromPLFactor (PLFactor Bool
h Bool
t [[SymSet]]
pieces)
>     = case forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap (forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap (forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap forall a. a -> Maybe a
Just)) [[SymSet]]
pieces of
>         []      ->  Factor (Maybe String) -> FSA Integer (Maybe String)
bl (forall e. [Set e] -> Bool -> Bool -> Factor e
Substring [] Bool
h Bool
t)
>         [[Set (Maybe String)]
p]     ->  Factor (Maybe String) -> FSA Integer (Maybe String)
bl (forall e. [Set e] -> Bool -> Bool -> Factor e
Substring [Set (Maybe String)]
p  Bool
h Bool
t)
>         ([Set (Maybe String)]
p:[[Set (Maybe String)]]
ps)  ->  if Bool
isPF
>                     then Factor (Maybe String) -> FSA Integer (Maybe String)
bl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Set e] -> Factor e
Subsequence forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Set (Maybe String)]
pforall a. a -> [a] -> [a]
:[[Set (Maybe String)]]
ps)
>                     else forall e n n1.
(Ord e, Ord n, Ord n1, Enum n1) =>
FSA n e -> FSA n1 e
renameStates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. (Ord e, Ord n) => FSA n e -> FSA (Set (Set n)) e
minimize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat
>                          forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Factor (Maybe String) -> FSA Integer (Maybe String)
bl [Factor (Maybe String)]
lfs
>                         where lfs :: [Factor (Maybe String)]
lfs  =  forall e. [Set e] -> Bool -> Bool -> Factor e
Substring [Set (Maybe String)]
p Bool
h Bool
False forall a. a -> [a] -> [a]
: forall {e}. [[Set e]] -> [Factor e]
lfs' [[Set (Maybe String)]]
ps
>     where as :: Set (Maybe String)
as           =  forall c a. Container c a => a -> c -> c
insert forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
>                           forall c a (s :: * -> *).
(Container c a, Collapsible s) =>
s c -> c
unionAll (forall c a (s :: * -> *).
(Container c a, Collapsible s) =>
s c -> c
unionAll [[SymSet]]
pieces)
>           bl :: Factor (Maybe String) -> FSA Integer (Maybe String)
bl           =  forall n e. (Enum n, Ord n, Ord e) => Set e -> Literal e -> FSA n e
buildLiteral Set (Maybe String)
as forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Factor e -> Literal e
required
>           isPF :: Bool
isPF         =  Bool -> Bool
not Bool
h Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
t Bool -> Bool -> Bool
&&
>                           forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
(==) [()] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const ())) [[SymSet]]
pieces
>           lfs' :: [[Set e]] -> [Factor e]
lfs' [[Set e]
x]     =  forall e. [Set e] -> Bool -> Bool -> Factor e
Substring [Set e]
x Bool
False Bool
t forall a. a -> [a] -> [a]
: [[Set e]] -> [Factor e]
lfs' []
>           lfs' ([Set e]
x:[[Set e]]
xs)  =  forall e. [Set e] -> Bool -> Bool -> Factor e
Substring [Set e]
x Bool
False Bool
False forall a. a -> [a] -> [a]
: [[Set e]] -> [Factor e]
lfs' [[Set e]]
xs
>           lfs' [[Set e]]
_       =  []

> usedSymbols :: Expr -> SymSet
> usedSymbols :: Expr -> SymSet
usedSymbols Expr
e = case Expr
e
>                 of Automaton FSA Integer (Maybe String)
a  ->  forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall c a. Container c a => a -> c -> c
insert) forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$
>                                     forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet FSA Integer (Maybe String)
a
>                    Factor PLFactor
f     ->  PLFactor -> SymSet
usedSymbolsF PLFactor
f
>                    NAry NAryExpr
n       ->  NAryExpr -> SymSet
usedSymbolsN NAryExpr
n
>                    Unary UnaryExpr
u      ->  UnaryExpr -> SymSet
usedSymbolsU UnaryExpr
u
>     where us :: [Expr] -> SymSet
us = forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall c a. Container c a => c -> c -> c
union forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> SymSet
usedSymbols) forall a. Set a
Set.empty
>           usedSymbolsN :: NAryExpr -> SymSet
usedSymbolsN (Concatenation [Expr]
es)  =  [Expr] -> SymSet
us [Expr]
es
>           usedSymbolsN (Conjunction [Expr]
es)    =  [Expr] -> SymSet
us [Expr]
es
>           usedSymbolsN (Disjunction [Expr]
es)    =  [Expr] -> SymSet
us [Expr]
es
>           usedSymbolsN (Domination [Expr]
es)     =  [Expr] -> SymSet
us [Expr]
es
>           usedSymbolsN (Infiltration [Expr]
es)   =  [Expr] -> SymSet
us [Expr]
es
>           usedSymbolsN (Shuffle [Expr]
es)        =  [Expr] -> SymSet
us [Expr]
es
>           usedSymbolsN (QuotientL [Expr]
es)      =  [Expr] -> SymSet
us [Expr]
es
>           usedSymbolsN (QuotientR [Expr]
es)      =  [Expr] -> SymSet
us [Expr]
es
>           usedSymbolsU :: UnaryExpr -> SymSet
usedSymbolsU (DownClose Expr
ex)      =  Expr -> SymSet
usedSymbols Expr
ex
>           usedSymbolsU (Iteration Expr
ex)      =  Expr -> SymSet
usedSymbols Expr
ex
>           usedSymbolsU (Negation Expr
ex)       =  Expr -> SymSet
usedSymbols Expr
ex
>           usedSymbolsU (Neutralize [SymSet]
ts Expr
ex)  =  forall a. Ord a => Set a -> Set a -> Set a
Set.union
>                                               (Expr -> SymSet
usedSymbols Expr
ex)
>                                               (forall c a (s :: * -> *).
(Container c a, Collapsible s) =>
s c -> c
unionAll [SymSet]
ts)
>           usedSymbolsU (Reversal Expr
ex)       =  Expr -> SymSet
usedSymbols Expr
ex
>           usedSymbolsU (Tierify [SymSet]
ts Expr
_)      =  forall c a (s :: * -> *).
(Container c a, Collapsible s) =>
s c -> c
unionAll [SymSet]
ts
>           usedSymbolsU (UpClose Expr
ex)        =  Expr -> SymSet
usedSymbols Expr
ex
>           usedSymbolsF :: PLFactor -> SymSet
usedSymbolsF (PLFactor Bool
_ Bool
_ [[SymSet]]
ps)   =  forall c a (s :: * -> *).
(Container c a, Collapsible s) =>
s c -> c
unionAll forall a b. (a -> b) -> a -> b
$ forall c a (s :: * -> *).
(Container c a, Collapsible s) =>
s c -> c
unionAll [[SymSet]]
ps

> parseStatements :: Env -> Parse Env
> parseStatements :: Env -> Parse Env
parseStatements (Set (String, SymSet)
dict, Set (String, Expr)
subexprs, Maybe Expr
prev)
>     = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
>       [ forall {a}. Parse [a]
start
>         forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool -> String -> Maybe Expr -> Env
f Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse String
getName forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs))
>         forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> Parse Env
parseStatements
>       , forall {a}. Parse [a]
start forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {a}. a -> (a, Set (String, Expr), Maybe Expr)
putFst
>         forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> SymSet -> Set (String, SymSet) -> Set (String, SymSet)
mkSyms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse String
getName forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set (String, SymSet) -> Parse SymSet
parseSymExpr Set (String, SymSet)
dict forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Set (String, SymSet)
dict)
>         forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> Parse Env
parseStatements
>       , Bool -> String -> Maybe Expr -> Env
f Bool
True String
"it" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs
>       , forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall a b. (a -> b) -> a -> b
$ \[Token]
ts ->
>         case [Token]
ts
>         of []  ->  forall a b. b -> Either a b
Right ((Set (String, SymSet)
dict, Set (String, Expr)
subexprs, Maybe Expr
prev), [])
>            [Token]
_   ->  forall a b. a -> Either a b
Left String
"not finished"
>       ]
>    where getName :: Parse String
getName
>              = forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall a b. (a -> b) -> a -> b
$ \[Token]
ts ->
>                case [Token]
ts
>                of (TName String
n : [Token]
ts') -> forall a b. b -> Either a b
Right (String
n, [Token]
ts')
>                   (Token
x : [Token]
_)
>                       -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
>                          String
"could not find name at " forall a. [a] -> [a] -> [a]
++
>                          Bool -> ShowS -> ShowS
showParen Bool
True (forall a. Show a => a -> ShowS
shows Token
x) String
""
>                   [Token]
_ -> forall a b. a -> Either a b
Left String
"end of input looking for name"
>          start :: Parse [a]
start = forall a. String -> a -> Parse a
eat String
"≝" [] forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. String -> a -> Parse a
eat String
"=" []
>          putFst :: a -> (a, Set (String, Expr), Maybe Expr)
putFst a
a = (a
a, Set (String, Expr)
subexprs, Maybe Expr
prev)
>          universe :: SymSet
universe = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Set a
Set.empty) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
>                     forall a. Ord a => String -> Dictionary a -> Either String a
definition String
"universe" Set (String, SymSet)
dict
>          mkSyms :: String -> SymSet -> Set (String, SymSet) -> Set (String, SymSet)
mkSyms String
name SymSet
value
>              = forall a. Ord a => String -> a -> Dictionary a -> Dictionary a
define String
"universe"
>                (if String
name forall a. Eq a => a -> a -> Bool
/= String
"universe"
>                 then SymSet
universe forall c a. Container c a => c -> c -> c
`union` SymSet
value
>                 else SymSet
value
>                ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => String -> a -> Dictionary a -> Dictionary a
define String
name SymSet
value
>          f :: Bool -> String -> Maybe Expr -> Env
f Bool
isL String
name Maybe Expr
me
>              = let nd :: Set (String, SymSet)
nd = forall b a. b -> (a -> b) -> Maybe a -> b
maybe
>                         Set (String, SymSet)
dict
>                         (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. Ord a => String -> a -> Dictionary a -> Dictionary a
define String
"universe") Set (String, SymSet)
dict forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                          forall c a. Container c a => c -> c -> c
union SymSet
universe forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                          Expr -> SymSet
usedSymbols
>                         )
>                         Maybe Expr
me
>                in ( Set (String, SymSet)
nd
>                   , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set (String, Expr)
subexprs (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. Ord a => String -> a -> Dictionary a -> Dictionary a
define String
name) Set (String, Expr)
subexprs) Maybe Expr
me
>                   , if Bool
isL then Maybe Expr
me else Maybe Expr
prev)

> -- |Parse an expression from a 'Token' stream.
> parseExpr :: Dictionary SymSet -> Dictionary Expr -> Parse Expr
> parseExpr :: Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
>                           [ Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseNAryExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs
>                           , Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseUnaryExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs
>                           , PLFactor -> Expr
Factor  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  Set (String, SymSet) -> Set (String, Expr) -> Parse PLFactor
parsePLFactor Set (String, SymSet)
dict Set (String, Expr)
subexprs
>                           , forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse [Token] -> Either String (Expr, [Token])
expandVar
>                           ]
>     where expandVar :: [Token] -> Either String (Expr, [Token])
expandVar (TName String
n : [Token]
ts)
>               = forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) [Token]
ts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => String -> Dictionary a -> Either String a
definition String
n Set (String, Expr)
subexprs
>           expandVar [Token]
_ = forall a b. a -> Either a b
Left String
"not a variable"

> parseNAryExpr :: Dictionary SymSet -> Dictionary Expr -> Parse Expr
> parseNAryExpr :: Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseNAryExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs
>     = forall a. [([String], a)] -> Parse a
makeLifter
>       [ ([String
"⋀", String
"⋂", String
"∧", String
"∩", String
"/\\"],  NAryExpr -> Expr
NAry forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> NAryExpr
Conjunction)
>       , ([String
"⋁", String
"⋃", String
"∨", String
"∪", String
"\\/"],  NAryExpr -> Expr
NAry forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> NAryExpr
Disjunction)
>       , ([String
"\\\\"],                     NAryExpr -> Expr
NAry forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> NAryExpr
QuotientL)
>       , ([String
"//"],                       NAryExpr -> Expr
NAry forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> NAryExpr
QuotientR)
>       , ([String
"∙∙", String
"@@"],                 NAryExpr -> Expr
NAry forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> NAryExpr
Domination)
>       , ([String
"∙" , String
"@" ],                 NAryExpr -> Expr
NAry forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> NAryExpr
Concatenation)
>       , ([String
"⧢", String
"|_|_|"],               NAryExpr -> Expr
NAry forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> NAryExpr
Shuffle)
>       , ([String
"⇑", String
".^."],                 NAryExpr -> Expr
NAry forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expr] -> NAryExpr
Infiltration)
>       ] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parse [Expr]
pd
>     where pd :: Parse [Expr]
pd = forall {a}. Parse [a]
parseEmpty
>                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. String -> Parse [a] -> Parse [a]
parseDelimited [Char
'(', Char
'{']
>                    (forall a. String -> Parse a -> Parse [a]
parseSeparated String
"," forall a b. (a -> b) -> a -> b
$ Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs)
>           parseEmpty :: Parse [a]
parseEmpty = forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall a b. (a -> b) -> a -> b
$ \[Token]
xs ->
>                        case [Token]
xs of
>                          (TSymbol Char
'(':TSymbol Char
')':[Token]
ts) -> forall a b. b -> Either a b
Right ([], [Token]
ts)
>                          (TSymbol Char
'{':TSymbol Char
'}':[Token]
ts) -> forall a b. b -> Either a b
Right ([], [Token]
ts)
>                          [Token]
_ -> forall a b. a -> Either a b
Left String
"not an empty expr"

> parseUnaryExpr :: Dictionary SymSet -> Dictionary Expr -> Parse Expr
> parseUnaryExpr :: Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseUnaryExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs
>     = (forall a. [([String], a)] -> Parse a
makeLifter
>        [ ([String
"↓", String
"$"],       UnaryExpr -> Expr
Unary forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> UnaryExpr
DownClose)
>        , ([String
"↑", String
"^"],       UnaryExpr -> Expr
Unary forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> UnaryExpr
UpClose)
>        , ([String
"*", String
"∗"],       UnaryExpr -> Expr
Unary forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> UnaryExpr
Iteration)
>        , ([String
"+"],            NAryExpr -> Expr
NAry  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> NAryExpr
plus)
>        , ([String
"¬", String
"~", String
"!"],  UnaryExpr -> Expr
Unary forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> UnaryExpr
Negation)
>        , ([String
"⇄", String
"-"],       UnaryExpr -> Expr
Unary forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> UnaryExpr
Reversal)
>        ] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs
>       ) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (UnaryExpr -> Expr
Unary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([SymSet] -> Expr -> UnaryExpr
Tierify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse [SymSet]
pt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs))
>         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (UnaryExpr -> Expr
Unary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([SymSet] -> Expr -> UnaryExpr
Neutralize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse [SymSet]
pn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set (String, SymSet) -> Set (String, Expr) -> Parse Expr
parseExpr Set (String, SymSet)
dict Set (String, Expr)
subexprs))
>     where pt :: Parse [SymSet]
pt = forall a. String -> Parse [a] -> Parse [a]
parseDelimited [Char
'[']
>                (forall a. String -> Parse a -> Parse [a]
parseSeparated String
"," (Set (String, SymSet) -> Parse SymSet
parseSymExpr Set (String, SymSet)
dict))
>           pn :: Parse [SymSet]
pn = forall a. String -> Parse [a] -> Parse [a]
parseDelimited [Char
'|']
>                (forall a. String -> Parse a -> Parse [a]
parseSeparated String
"," (Set (String, SymSet) -> Parse SymSet
parseSymExpr Set (String, SymSet)
dict))
>           plus :: Expr -> NAryExpr
plus Expr
e = [Expr] -> NAryExpr
Concatenation [Expr
e, UnaryExpr -> Expr
Unary forall a b. (a -> b) -> a -> b
$ Expr -> UnaryExpr
Iteration Expr
e]

> parsePLFactor :: Dictionary SymSet -> Dictionary Expr -> Parse PLFactor
> parsePLFactor :: Set (String, SymSet) -> Set (String, Expr) -> Parse PLFactor
parsePLFactor Set (String, SymSet)
dict Set (String, Expr)
subexprs
>     = String -> (PLFactor -> PLFactor -> PLFactor) -> Parse PLFactor
combine String
".." PLFactor -> PLFactor -> PLFactor
plGap forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
>       String -> (PLFactor -> PLFactor -> PLFactor) -> Parse PLFactor
combine String
"‥" PLFactor -> PLFactor -> PLFactor
plGap forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
>       String -> (PLFactor -> PLFactor -> PLFactor) -> Parse PLFactor
combine String
"." PLFactor -> PLFactor -> PLFactor
plCatenate forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
>       Parse PLFactor
pplf
>     where combine :: String -> (PLFactor -> PLFactor -> PLFactor) -> Parse PLFactor
combine String
s PLFactor -> PLFactor -> PLFactor
f = forall a. String -> a -> Parse a
eat String
s (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 PLFactor -> PLFactor -> PLFactor
f) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
>                         forall a. String -> Parse [a] -> Parse [a]
parseDelimited [Char
'<', Char
'⟨']
>                         (forall a. String -> Parse a -> Parse [a]
parseSeparated String
"," Parse PLFactor
pplf)
>           pplf :: Parse PLFactor
pplf = Set (String, SymSet) -> Parse PLFactor
parseBasicPLFactor Set (String, SymSet)
dict forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse [Token] -> Either String (PLFactor, [Token])
expandVar
>           expandVar :: [Token] -> Either String (PLFactor, [Token])
expandVar (TName String
n : [Token]
ts)
>               = case Either String Expr
v
>                 of Right (Factor PLFactor
x) -> forall a b. b -> Either a b
Right (PLFactor
x, [Token]
ts)
>                    Either String Expr
_ -> forall a b. a -> Either a b
Left String
"expression does not represent a factor"
>               where v :: Either String Expr
v = forall a. Ord a => String -> Dictionary a -> Either String a
definition String
n Set (String, Expr)
subexprs
>           expandVar [Token]
_ = forall a b. a -> Either a b
Left String
"not a variable"

> parseBasicPLFactor :: Dictionary SymSet -> Parse PLFactor
> parseBasicPLFactor :: Set (String, SymSet) -> Parse PLFactor
parseBasicPLFactor Set (String, SymSet)
dict
>     = forall a. [([String], a)] -> Parse a
makeLifter
>       [ ([String
"⋊⋉", String
"%||%"], Bool -> Bool -> [[SymSet]] -> PLFactor
PLFactor Bool
True Bool
True)
>       , ([String
"⋊", String
"%|"], Bool -> Bool -> [[SymSet]] -> PLFactor
PLFactor Bool
True Bool
False)
>       , ([String
"⋉", String
"|%"], Bool -> Bool -> [[SymSet]] -> PLFactor
PLFactor Bool
False Bool
True)
>       , ([String
""], Bool -> Bool -> [[SymSet]] -> PLFactor
PLFactor Bool
False Bool
False)
>       ]
>       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. String -> Parse [a] -> Parse [a]
parseDelimited [Char
'<', Char
'⟨']
>           (forall a. String -> Parse a -> Parse [a]
parseSeparated String
"," forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Set (String, SymSet) -> Parse SymSet
parseSymExpr Set (String, SymSet)
dict)
>            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse (\[Token]
ts -> forall a b. b -> Either a b
Right ([], [Token]
ts)))

> parseSymExpr :: Dictionary SymSet -> Parse SymSet
> parseSymExpr :: Set (String, SymSet) -> Parse SymSet
parseSymExpr Set (String, SymSet)
dict
>     = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
>        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> Parse [a] -> Parse [a]
parseDelimited [Char
'{', Char
'(']
>        forall a b. (a -> b) -> a -> b
$ forall a. String -> Parse a -> Parse [a]
parseSeparated String
"," (Set (String, SymSet) -> Parse SymSet
parseSymExpr Set (String, SymSet)
dict))
>       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Ord a => Set a -> Set a -> Set a
Set.intersection)
>           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> Parse [a] -> Parse [a]
parseDelimited [Char
'[']
>           forall a b. (a -> b) -> a -> b
$ forall a. String -> Parse a -> Parse [a]
parseSeparated String
"," (Set (String, SymSet) -> Parse SymSet
parseSymExpr Set (String, SymSet)
dict))
>       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Set (String, SymSet) -> Parse SymSet
parseSymSet Set (String, SymSet)
dict

> parseSymSet :: Dictionary SymSet -> Parse SymSet
> parseSymSet :: Set (String, SymSet) -> Parse SymSet
parseSymSet Set (String, SymSet)
dict
>     = forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall a b. (a -> b) -> a -> b
$ \[Token]
xs ->
>       case [Token]
xs
>       of (TName String
n : [Token]
ts)
>              -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) [Token]
ts) (forall a. Ord a => String -> Dictionary a -> Either String a
definition String
n Set (String, SymSet)
dict)
>          (TSymbol Char
'/' : TName String
n : [Token]
ts)
>              -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) [Token]
ts forall a b. (a -> b) -> a -> b
$ forall c a. Container c a => a -> c
singleton String
n
>          (Token
a:[Token]
_)
>              -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"cannot start a SymSet with " forall a. [a] -> [a] -> [a]
++
>                 Bool -> ShowS -> ShowS
showParen Bool
True (forall a. Show a => a -> ShowS
shows Token
a) String
""
>          [Token]
_ -> forall a b. a -> Either a b
Left String
"unexpected end of input in SymSet"

> makeLifter :: [([String], a)] -> Parse a
> makeLifter :: forall a. [([String], a)] -> Parse a
makeLifter = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. String -> a -> Parse a
eat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. ([a], b) -> [(a, b)]
f)
>     where f :: ([a], b) -> [(a, b)]
f ([], b
_)    =  []
>           f (a
x:[a]
xs, b
g)  =  (a
x, b
g) forall a. a -> [a] -> [a]
: ([a], b) -> [(a, b)]
f ([a]
xs, b
g)

> eat :: String -> a -> Parse a
> eat :: forall a. String -> a -> Parse a
eat String
str a
f = forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall a b. (a -> b) -> a -> b
$ \[Token]
ts ->
>             if forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Token]
ts (forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap Char -> Token
TSymbol String
str)
>             then forall a b. b -> Either a b
Right (a
f, forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) [Token]
ts)
>             else forall a b. a -> Either a b
Left String
""

> parseDelimited :: [Char] -> Parse [a] -> Parse [a]
> parseDelimited :: forall a. String -> Parse [a] -> Parse [a]
parseDelimited String
ds Parse [a]
pl = String -> Parse Char
parseOpeningDelimiter String
ds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> Parse [a]
f
>     where f :: Char -> Parse [a]
f Char
d = forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse [a]
pl forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Char -> Parse [a]
parseClosingDelimiter Char
d

> parseOpeningDelimiter :: [Char] -> Parse Char
> parseOpeningDelimiter :: String -> Parse Char
parseOpeningDelimiter String
ds = forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse [Token] -> Either String (Char, [Token])
openingDelimiter
>     where openingDelimiter :: [Token] -> Either String (Char, [Token])
openingDelimiter (TSymbol Char
x : [Token]
ts)
>               | forall c a. (Container c a, Eq a) => c -> a -> Bool
isIn String
ds Char
x  =  forall a b. b -> Either a b
Right (Char
x, [Token]
ts)
>               | Bool
otherwise  =  forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
>                               String
"invalid opening delimiter: " forall a. [a] -> [a] -> [a]
++
>                               forall a. Show a => a -> String
show Char
x
>           openingDelimiter [Token]
_
>               = forall a b. a -> Either a b
Left String
"unexpected end of input looking for opening delimiter"

> parseClosingDelimiter :: Char -> Parse [a]
> parseClosingDelimiter :: forall a. Char -> Parse [a]
parseClosingDelimiter = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. String -> a -> Parse a
eat [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a. Container c a => a -> c
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
matchingDelimiter

> parseSeparated :: String -> Parse a -> Parse [a]
> parseSeparated :: forall a. String -> Parse a -> Parse [a]
parseSeparated String
string Parse a
p = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall a. String -> a -> Parse a
eat String
string [] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parse a
p)



> plCatenate :: PLFactor -> PLFactor -> PLFactor
> plCatenate :: PLFactor -> PLFactor -> PLFactor
plCatenate (PLFactor Bool
h Bool
_ [[SymSet]]
xs) (PLFactor Bool
_ Bool
t [[SymSet]]
ys) = Bool -> Bool -> [[SymSet]] -> PLFactor
PLFactor Bool
h Bool
t (forall {a}. [[a]] -> [[a]] -> [[a]]
pc [[SymSet]]
xs [[SymSet]]
ys)
>     where pc :: [[a]] -> [[a]] -> [[a]]
pc [] [[a]]
bs       =  [[a]]
bs
>           pc [[a]
a] []      =  [[a]
a]
>           pc [[a]
a] ([a]
b:[[a]]
bs)  =  ([a]
a forall a. [a] -> [a] -> [a]
++ [a]
b) forall a. a -> [a] -> [a]
: [[a]]
bs
>           pc ([a]
a:[[a]]
as) [[a]]
bs   =  [a]
a forall a. a -> [a] -> [a]
: [[a]] -> [[a]] -> [[a]]
pc [[a]]
as [[a]]
bs

> plGap :: PLFactor -> PLFactor -> PLFactor
> plGap :: PLFactor -> PLFactor -> PLFactor
plGap (PLFactor Bool
h Bool
_ [[SymSet]]
xs) (PLFactor Bool
_ Bool
t [[SymSet]]
ys) = Bool -> Bool -> [[SymSet]] -> PLFactor
PLFactor Bool
h Bool
t ([[SymSet]]
xs forall a. [a] -> [a] -> [a]
++ [[SymSet]]
ys)



> -- |An association between names and values.
> type Dictionary a = Set (String, a)

> define :: (Ord a) => String -> a -> Dictionary a -> Dictionary a
> define :: forall a. Ord a => String -> a -> Dictionary a -> Dictionary a
define String
name a
value = forall c a. Container c a => a -> c -> c
insert (String
name, a
value) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) a.
(Collapsible s, Container (s a) a) =>
(a -> Bool) -> s a -> s a
keep ((forall a. Eq a => a -> a -> Bool
/= String
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

> definition :: (Ord a) => String -> Dictionary a -> Either String a
> definition :: forall a. Ord a => String -> Dictionary a -> Either String a
definition String
a = forall b a. b -> (a -> b) -> Maybe a -> b
maybe
>                (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"undefined variable \"" forall a. [a] -> [a] -> [a]
++ String
a forall a. [a] -> [a] -> [a]
++ String
"\"")
>                forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                forall {a}. Eq a => Set a -> Maybe a
lookupMin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) a.
(Collapsible s, Container (s a) a) =>
(a -> Bool) -> s a -> s a
keep ((forall a. Eq a => a -> a -> Bool
== String
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
>     where lookupMin :: Set a -> Maybe a
lookupMin Set a
xs
>               | Set a
xs forall a. Eq a => a -> a -> Bool
== forall a. Set a
Set.empty = forall a. Maybe a
Nothing
>               | Bool
otherwise       = forall a. a -> Maybe a
Just (forall a. Set a -> a
Set.findMin Set a
xs)

> -- |The base type for a combinatorial parser.
> newtype Parse a = Parse
>     {forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse :: [Token] -> Either String (a, [Token])}

> instance Functor Parse
>     where fmap :: forall a b. (a -> b) -> Parse a -> Parse b
fmap a -> b
g (Parse [Token] -> Either String (a, [Token])
f) = forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b) -> (a, c) -> (b, c)
mapfst a -> b
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Either String (a, [Token])
f)

> instance Applicative Parse
>     where pure :: forall a. a -> Parse a
pure     =  forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,)
>           Parse (a -> b)
f <*> :: forall a b. Parse (a -> b) -> Parse a -> Parse b
<*> Parse a
x  =  forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall a b. (a -> b) -> a -> b
$ \[Token]
s0 ->
>                       let h :: (a -> b, [Token]) -> Either String (b, [Token])
h (a -> b
g, [Token]
s1) = forall a b c. (a -> b) -> (a, c) -> (b, c)
mapfst a -> b
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse Parse a
x [Token]
s1
>                       in forall {b}. (a -> b, [Token]) -> Either String (b, [Token])
h forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse Parse (a -> b)
f [Token]
s0

> instance Alternative Parse
>     where empty :: forall a. Parse a
empty    =  forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
""
>           Parse a
p <|> :: forall a. Parse a -> Parse a -> Parse a
<|> Parse a
q  =  forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall a b. (a -> b) -> a -> b
$ \[Token]
ts ->
>                       let f :: String -> ShowS
f String
s1 String
s2
>                             = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= String
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines)
>                               [String
s1, String
s2]
>                           h :: String -> Either String (a, [Token])
h String
s = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
f String
s) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse Parse a
q [Token]
ts
>                       in forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Either String (a, [Token])
h forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse Parse a
p [Token]
ts

> instance Monad Parse
>     where Parse a
p >>= :: forall a b. Parse a -> (a -> Parse b) -> Parse b
>>= a -> Parse b
f   =  forall a. ([Token] -> Either String (a, [Token])) -> Parse a
Parse forall a b. (a -> b) -> a -> b
$ \[Token]
s0 ->
>                        let h :: (a, [Token]) -> Either String (b, [Token])
h (a
a, [Token]
s1) = forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse (a -> Parse b
f a
a) [Token]
s1
>                        in (a, [Token]) -> Either String (b, [Token])
h forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Parse a -> [Token] -> Either String (a, [Token])
doParse Parse a
p [Token]
s0
#if !MIN_VERSION_base(4,8,0)
>           return    =  pure
#endif



> -- |Generate an expression (sub)tree from an 'FSA' that
> -- contains metadata regarding the constraint(s) it represents.
> fromSemanticAutomaton :: FSA Integer (Maybe String) -> Expr
> fromSemanticAutomaton :: FSA Integer (Maybe String) -> Expr
fromSemanticAutomaton = FSA Integer (Maybe String) -> Expr
Automaton

> -- |Generate an expression (sub)tree from an 'FSA'.
> fromAutomaton :: FSA Integer String -> Expr
> fromAutomaton :: FSA Integer String -> Expr
fromAutomaton = FSA Integer (Maybe String) -> Expr
fromSemanticAutomaton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e e1 n.
(Ord e, Ord e1, Ord n) =>
(e -> e1) -> FSA n e -> FSA n e1
renameSymbolsBy forall a. a -> Maybe a
Just



> isPrefixOf :: Eq a => [a] -> [a] -> Bool
> isPrefixOf :: forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
_ []  =  Bool
True
> isPrefixOf [] [a]
_  =  Bool
False
> isPrefixOf (a
a:[a]
as) (a
b:[a]
bs)
>     | a
a forall a. Eq a => a -> a -> Bool
== a
b     =  forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
as [a]
bs
>     | Bool
otherwise  =  Bool
False

> mapfst :: (a -> b) -> (a, c) -> (b, c)
> mapfst :: forall a b c. (a -> b) -> (a, c) -> (b, c)
mapfst a -> b
f (a
a, c
c) = (a -> b
f a
a, c
c)

> mapsnd :: (b -> c) -> (a, b) -> (a, c)
> mapsnd :: forall b c a. (b -> c) -> (a, b) -> (a, c)
mapsnd b -> c
f (a
a, b
b) = (a
a, b -> c
f b
b)

> matchingDelimiter :: Char -> Char
> matchingDelimiter :: Char -> Char
matchingDelimiter Char
x = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Char, Char) -> Char -> Char
f Char
x [(Char, Char)]
delimiters
>     where f :: (Char, Char) -> Char -> Char
f (Char
a, Char
b) Char
u
>               | Char
a forall a. Eq a => a -> a -> Bool
== Char
x     =  Char
b
>               | Char
b forall a. Eq a => a -> a -> Bool
== Char
x     =  Char
a
>               | Bool
otherwise  =  Char
u
>           delimiters :: [(Char, Char)]
delimiters
>               = [ (Char
'<', Char
'>')
>                 , (Char
'⟨', Char
'⟩')
>                 , (Char
'(', Char
')')
>                 , (Char
'[', Char
']')
>                 , (Char
'{', Char
'}')
>                 , (Char
'|', Char
'|')
>                 ]