{-# LANGUAGE TypeOperators, FlexibleInstances #-}

{-| 
This module provides a combinator library in which combinators act as an interface
to a back-end parser. This technique is inspired by Tom Ridge (2014) and 
 Peter Ljunglöf (2002). The back-end parser is provided in "GLL.Parser".
The library is fully general: it enables writing parsers for arbitrary context-free
grammars.

The user writes a combinator expression representing a grammar.
The represented grammar is extracted and given, together with an input string,
to a back-end parser.
The derivations constructed by the parser act as a guide in the "semantic phase"
in which the combinator expressions are evaluated to produce semantic results
for all derivations. Infinitely many derivations would result in a loop. 
This problem is avoided by discarding the derivations that would arise from such a loop.

This library uses "GLL.Parser" as the back-end parser and provides 
"Control.Applicative"-like parser combinators: '<**>' for sequencing, '<||>' for 
choice, '<$$>' for application, 'satisfy' instead of pure and derived 
combinators '<**', '**>', '<$$', 'many', 'some' and 'optional'.

The semantic phase might benefit from memoisation (see 'memo'). 
Using memoisation voids pureness waranty". 

=== Example usage
This library differs from parser combinator libraries in that combinator expressions
are used to describe a grammar rather than a parser.

A rule is considered to be of the form X ::= a | .. | z, and represented by the combinator
expression.

@
pX = \"X\" '<::=>' altA '<||>' ... '<||>' altZ
@

Alternates (\'a\' ... \'z\') start with the application of 
a semantic action using '<$$>' (or variants '<$$' and 'satisfy'). 
The alternate is extended with '<**>' (or variants '**>', '<**').

@
altA = action1 '<$$>' 'keychar' \'a\' '<**>' pX
altZ = action2 '<$$>' 'keychar' \'z\'
@

Usability is improved by automatic lifting between expressions that represent symbols
and alternates. The main difference with "Control.Applicative" style parser combinator
libraries is that the user must use '<:=>' (or '<::=>') to represent all recursive 
nonterminals and must use '<::=>' to represent all nonterminals that potentially lead
to an infinite number of derivations. It is, however, possible to represent left-recursive
nonterminals.

=== Example

In this example we define expressions for parsing (and evaluating) simple arithmetic 
expressions for single digit integers. 

The library is capable of parsing arbitrary token types that are 'Parseable', orderable
and have a 'Show' instance.
This example demonstrates the usage of the builtin 'Token' datatype and uses the
elementary parsers 'keychar' and 'int_lit' to create parsers for character- and integer-terminals.

We define a very simpler lexer first.

@
lexer :: String -> [Token]
lexer [] = []
lexer (x:xs)
    | isDigit x = 'IntLit' (Just (read [x])) : lexer xs
    | otherwise = 'Char' x                   : lexer xs
@

Note that the Char constructor of the 'Token' type is used for character-level parsing.
Char contains no lexeme, unlike the Int constructor.

Consider the following (highly ambiguous and left-recursive) grammar:

@
Expr ::= Expr \'-\' Expr
       | Expr \'+\' Expr
       | Expr \'*\' Expr
       | Expr \'/\' Expr
       | INT
       | \'(\' Expr \')\'
@

The grammar is translated to the following combinator expression, adding the expected
evaluation functions as semantic actions.

@
pExpr :: BNF Token Int
pExpr = \"Expr\" '<::=>' (-) '<$$>' pExpr '<**' 'keychar' \'-\' '<**>' pExpr
                 '<||>' (+) '<$$>' pExpr '<**' 'keychar' \'+\' '<**>' pExpr
                 '<||>' (*) '<$$>' pExpr '<**' 'keychar' \'*\' '<**>' pExpr
                 '<||>' div '<$$>' pExpr '<**' 'keychar' \'/\' '<**>' pExpr
                 '<||>' 'int_lit'
                 '<||>' parens pExpr
@

Note that '<**' is used to ignore the parse result of the second argument and that '**>' 
is used to ignore the parse result of the first argument. These combinators
help us to define the /derived combinator/s /within/ and /parens/.

@
within :: 'BNF' 'Token' a -> 'BNF' 'Token' b -> 'BNF' 'Token' a -> 'BNF' 'Token' b
within l p r = 'mkRule' $ l '**>' p '<**' r

parens :: 'BNF' 'Token' a -> 'BNF' 'Token' a
parens p = within ('keychar' '(') p ('keychar' ')')
@

All possible evaluations are obtained by invoking the 'parse' function.

@
run1 = 'parse' pExpr (lexer "1+2*2-5")            -- [0,1,0,-5,-9] 
run2 = 'parse' pExpr (lexer "((1+(2*2))-3)-5")    -- [-3]
@

With every introduction of an operator '+', '-', '*' or '/' the number of ambiguities is 
multiplied. The number of ambiguities behaves like the sequence https://oeis.org/A000108.

=== Simple disambiguation

This library offers simple disambiguation strategies that are applied post-parse 
(the parser still faces the ambiguity, but the semantic evaluation only yields 
the results according to the strategy). The disambiguations strategies are still
in the /experimental/ phase. 

We group the operators according to their priorities and use 
'<::=' to turn the choice operator '<||>' into a left-biased operator locally
(use 'leftBiased' for the same effect globally).

@
pExpr1 :: BNF Token Int
pExpr1 = \"Expr\" '<::='  (      (-) '<$$>' pExpr1 '<**' 'keychar' \'-\' '<**>' pExpr1
                        '<||>' (+) '<$$>' pExpr1 '<**' 'keychar' \'+\' '<**>' pExpr1 )
                 '<||>' (      (*) '<$$>' pExpr1 '<**' 'keychar' \'*\' '<**>' pExpr1
                        '<||>' div '<$$>' pExpr1 '<**' 'keychar' \'/\' '<**>' pExpr1 )
                 '<||>' (      'int_lit'
                        '<||>' 'parens' pExpr1 )

run3 = 'parseWithOptions' ['maximumPivotAtNt'] pExpr1 (lexer "1+2*2-5") -- [0]
@

The option 'maximumPivotAtNt' enables the 'longest-match' disambiguation strategy 
and makes the arithmetic operators left-associative.

=== Grammar rewrites

To deal with the particular ambiguities associated with operators we can 
rewrite the grammar to disambiguate pre-parse.

We define the /chainl/ combinator for parsing chains of left-associative operators.

@
chainl :: 'BNF' 'Token' a -> 'BNF' 'Token' (a -> a -> a) -> 'BNF' 'Token' a
chainl p s = 'mkRule' $
    foldl (flip ($)) '<$$>' p '<**>' many (flip '<$$>' s '<**>' p)
@

The expression parser is written with chainl as follows:

@
pExpr2 :: BNF Token Int
pExpr2 = pE1
 where  pE1 = chainl pE2 (\"E1\" '<::=>' (+) '<$$' 'keychar' \'+\' '<||>' (-) '<$$' 'keychar' \'-\')
        pE2 = chainl pE3 (\"E2\" '<::=>' (*) '<$$' 'keychar' \'*\' '<||>' div '<$$' 'keychar' \'/\')
        pE3 = \"E3\" '<::=>' 'int_lit' '<||>' parens pExpr2

run4 = 'parse' 'pExpr2' (lexer "1+2*2-5")       -- [0]
@

Pre-parse disambiguation is desirable, as the parsing process could 
speed up dramatically. In general however, it is not always possible to find 
the appropriate grammar rewrite and implement it in a high-level combinator such 
as chainl, /motivating the existence of this library/.

More simple examples can be found in "GLL.Combinators.Test.Interface".

-}
module GLL.Combinators.Interface (
    -- * Elementary parsers
    term_parser, satisfy,
    -- ** Elementary parsers using the 'Token' datatype 
    keychar, keyword, int_lit, float_lit, bool_lit, char_lit, string_lit, alt_id_lit, id_lit, token,
    -- ** Elementary character-level parsers
    char, 
    -- * Elementary combinators
    -- *** Sequencing
    (<**>),
    -- *** Choice
    (<||>),
    -- *** Semantic actions
    (<$$>),
    -- *** Nonterminal introduction
    (<:=>),(<::=>),chooses,chooses_prec,
    -- * Types
    -- ** Grammar (combinator expression) types
    BNF, SymbExpr, AltExpr, AltExprs,
    -- ** Parseable token types 
    Token(..), Parseable(..), SubsumesToken(..), unlexTokens, unlexToken,  
    -- * Running a parser 
    grammarOf, parse, printParseData, evaluatorWithParseData,
    -- **  Running a parser with options
    parseWithOptions, parseWithParseOptions, printParseDataWithOptions, evaluatorWithParseDataAndOptions, printGrammarData,
    -- *** Possible options
    CombinatorOptions, CombinatorOption, 
             GLL.Combinators.Options.maximumErrors, throwErrors, 
             maximumPivot, maximumPivotAtNt,leftBiased,
    -- **** Parser options
    fullSPPF, allNodes, packedNodesOnly, strictBinarisation, 
      GLL.Parser.noSelectTest,
    -- *** Running a parser with options and explicit failure
    parseWithOptionsAndError, parseWithParseOptionsAndError,
    -- ** Runing a parser to obtain 'ParseResult'.
    parseResult, parseResultWithOptions,ParseResult(..),
    -- ** Builtin lexers.
    default_lexer, 
    -- *** Lexer settings
        lexer, lexerEither, LexerSettings(..), emptyLanguage,
    -- * Derived combinators
    mkNt, 
    -- *** Ignoring semantic results
    (<$$), (**>), (<**),
    -- *** EBNF patterns
    optional, preferably, reluctantly, optionalWithDef,
    multiple, multiple1, multipleSepBy, multipleSepBy1,
      multipleSepBy2, within, parens, braces, brackets, angles,
      foldr_multiple, foldr_multipleSepBy,
    -- *** Operator expressions
    fromOpTable, opTableFromList, OpTable, Assoc(..), Fixity(..),
     -- *** Disambiguation  
            (<:=), (<::=),(<<<**>), (<**>>>), (<<**>), (<<<**), (**>>>), (<**>>),
            longest_match,shortest_match,
            many, many1, some, some1, 
            manySepBy, manySepBy1, manySepBy2, 
              someSepBy, someSepBy1,someSepBy2,
    -- * Lifting
    HasAlts(..), IsSymbExpr(..), IsAltExpr(..),
     -- * Memoisation
    memo, newMemoTable, memClear, MemoTable, MemoRef, useMemoisation,
    ) where

import GLL.Combinators.Options
import GLL.Combinators.Visit.Join
import GLL.Combinators.Visit.Sem (emptyAncestors)
import GLL.Combinators.Memoisation
import GLL.Combinators.Lexer
import GLL.Types.Grammar
import GLL.Parser hiding (parse, parseWithOptions)
import qualified GLL.Parser as GLL

import Control.Monad (when)
import GLL.Types.TypeCompose (OO(..))
import Control.Arrow
import qualified Data.Array as A
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Text (pack)
import qualified Data.Text
import Data.IORef 
import Data.Time.Clock
import System.IO.Unsafe

parse' :: (Show t, Parseable t, IsSymbExpr s) => ParseOptions -> 
            PCOptions -> s t a -> [t] -> (Grammar t, ParseResult t, Either String [a])
parse' :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions
-> PCOptions
-> s t a
-> [t]
-> (Grammar t, ParseResult t, Either String [a])
parse' ParseOptions
popts PCOptions
opts s t a
p' [t]
input =  
    let SymbExpr (Nt Nt
start,Grammar_Expr t
vpa2,Sem_Symb t a
vpa3) = SymbExpr t a -> SymbExpr t a
forall t b. (Show t, Ord t) => SymbExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (String
"__Start" String -> OO [] AltExpr t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<:=> [AltExpr t a] -> OO [] AltExpr t a
forall (f :: * -> *) (j :: * -> * -> *) a b.
f (j a b) -> OO f j a b
OO [a -> a
forall a. a -> a
id (a -> a) -> s t a -> AltExpr t a
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p'])
        rules :: Map Nt [Prod t]
rules       = Grammar_Expr t
vpa2 Map Nt [Prod t]
forall k a. Map k a
M.empty
        as :: IO [a]
as          = Sem_Symb t a
vpa3 PCOptions
opts Ancestors Any
forall t. Ancestors Any
emptyAncestors SPPF t
sppf Input t
arr Int
0 Int
m
        grammar :: (Nt, [Prod t])
grammar     = (Nt
start, [ Prod t
p | (Nt
_, [Prod t]
alts) <- Map Nt [Prod t] -> [(Nt, [Prod t])]
forall k a. Map k a -> [(k, a)]
M.assocs Map Nt [Prod t]
rules, Prod t
p <- [Prod t]
alts ])
        max_err :: Int
max_err     = PCOptions -> Int
max_errors PCOptions
opts
        parse_res :: ParseResult t
parse_res   = ParseOptions -> (Nt, [Prod t]) -> Input t -> ParseResult t
forall t.
Parseable t =>
ParseOptions -> Grammar t -> Input t -> ParseResult t
GLL.parseWithOptionsArray (ParseOptions
poptsParseOptions -> ParseOptions -> ParseOptions
forall a. [a] -> [a] -> [a]
++[Int -> ParseOption
GLL.maximumErrors Int
max_err]) (Nt, [Prod t])
grammar Input t
arr
        sppf :: SPPF t
sppf        = ParseResult t -> SPPF t
forall t. ParseResult t -> SPPF t
sppf_result ParseResult t
parse_res
        arr :: Input t
arr         = [t] -> Input t
forall t. Parseable t => [t] -> Input t
mkInput [t]
input 
        m :: Int
m           = [t] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
input 
        res_list :: [a]
res_list    = IO [a] -> [a]
forall a. IO a -> a
unsafePerformIO IO [a]
as
    in ((Nt, [Prod t])
grammar, ParseResult t
parse_res, if ParseResult t -> Bool
forall t. ParseResult t -> Bool
res_success ParseResult t
parse_res Bool -> Bool -> Bool
&& Bool -> Bool
not ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
res_list)
                            then [a] -> Either String [a]
forall a b. b -> Either a b
Right ([a] -> Either String [a]) -> [a] -> Either String [a]
forall a b. (a -> b) -> a -> b
$ [a]
res_list 
                            else String -> Either String [a]
forall a b. a -> Either a b
Left (ParseResult t -> String
forall t. ParseResult t -> String
error_message ParseResult t
parse_res) )

-- | Print some information about the parse.
-- Helpful for debugging.
printParseData :: (Parseable t, IsSymbExpr s, Show a) => s t a -> [t] -> IO ()
printParseData :: forall t (s :: * -> * -> *) a.
(Parseable t, IsSymbExpr s, Show a) =>
s t a -> [t] -> IO ()
printParseData = ParseOptions -> CombinatorOptions -> s t a -> [t] -> IO ()
forall t (s :: * -> * -> *) a.
(Parseable t, IsSymbExpr s, Show a) =>
ParseOptions -> CombinatorOptions -> s t a -> [t] -> IO ()
printParseDataWithOptions [] [] 

-- | Variant of 'printParseData' which can be controlled by 'ParseOption's
printParseDataWithOptions :: (Parseable t, IsSymbExpr s, Show a) => ParseOptions -> CombinatorOptions -> s t a -> [t] -> IO ()
printParseDataWithOptions :: forall t (s :: * -> * -> *) a.
(Parseable t, IsSymbExpr s, Show a) =>
ParseOptions -> CombinatorOptions -> s t a -> [t] -> IO ()
printParseDataWithOptions ParseOptions
popts CombinatorOptions
opts s t a
p' [t]
input = 
    let SymbExpr (Nt Nt
start,Grammar_Expr t
vpa2,Sem_Symb t a
vpa3) = SymbExpr t a -> SymbExpr t a
forall t b. (Show t, Ord t) => SymbExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (String
"__Start" String -> OO [] AltExpr t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<:=> [AltExpr t a] -> OO [] AltExpr t a
forall (f :: * -> *) (j :: * -> * -> *) a b.
f (j a b) -> OO f j a b
OO [a -> a
forall a. a -> a
id (a -> a) -> s t a -> AltExpr t a
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p'])
        rules :: Map Nt [Prod t]
rules       = Grammar_Expr t
vpa2 Map Nt [Prod t]
forall k a. Map k a
M.empty
        grammar :: (Nt, [Prod t])
grammar     = (Nt
start, [ Prod t
p | (Nt
_, [Prod t]
alts) <- Map Nt [Prod t] -> [(Nt, [Prod t])]
forall k a. Map k a -> [(k, a)]
M.assocs Map Nt [Prod t]
rules, Prod t
p <- [Prod t]
alts ])
        parse_res :: ParseResult t
parse_res   = ParseOptions -> (Nt, [Prod t]) -> [t] -> ParseResult t
forall t.
Parseable t =>
ParseOptions -> Grammar t -> [t] -> ParseResult t
GLL.parseWithOptions (ParseOptions
popts ParseOptions -> ParseOptions -> ParseOptions
forall a. [a] -> [a] -> [a]
++ [ParseOption
packedNodesOnly,ParseOption
strictBinarisation]) (Nt, [Prod t])
grammar [t]
input
        arr :: Input t
arr         = [t] -> Input t
forall t. Parseable t => [t] -> Input t
mkInput [t]
input 
        (Int
_,Int
m)       = Input t -> (Int, Int)
forall i e. Array i e -> (i, i)
A.bounds Input t
arr
    in do let (Nt
_,[Prod t]
prods) = (Nt, [Prod t])
grammar
              nt_set :: Ancestors Any
nt_set = [Nt] -> Ancestors Any
forall a. Ord a => [a] -> Set a
S.fromList [ Nt
x | Prod Nt
x Symbols t
_ <- [Prod t]
prods ]
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#production:          " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Prod t] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Prod t]
prods)
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#nonterminals:        " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Ancestors Any -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Ancestors Any
nt_set)
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"largest nonterminal:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ( 
            (Nt -> Int -> Int) -> Int -> Ancestors Any -> Int
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Nt
x -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Nt -> Int
Data.Text.length Nt
x)) Int
0 Ancestors Any
nt_set)

          UTCTime
startTime <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#tokens:              " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
m)
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#successes:           " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ParseResult t -> Int
forall t. ParseResult t -> Int
res_successes ParseResult t
parse_res)
          UTCTime
endTime <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"recognition time:     " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime)
          UTCTime
startTime' <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#descriptors          " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ParseResult t -> Int
forall t. ParseResult t -> Int
nr_descriptors ParseResult t
parse_res)
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#EPNs                 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ParseResult t -> Int
forall t. ParseResult t -> Int
nr_packed_node_attempts ParseResult t
parse_res) 
          UTCTime
endTime <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"parse-data time:      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime')
{-          startTime' <- getCurrentTime
          as <- vpa3 (runOptions opts) emptyAncestors (sppf_result parse_res) arr 0 m
          putStrLn $ "ambiguous?:           " ++ show (length as > 1)
          when (not (null as)) (writeFile "/tmp/derivation" (show (head as)))
          endTime <- getCurrentTime
          putStrLn $ "semantic phase:       " ++ show (diffUTCTime endTime startTime')-}
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"total time:           " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime)

-- | Print some information 
evaluatorWithParseData :: (Parseable t, IsSymbExpr s, Show a) => s t a -> [t] -> [a]
evaluatorWithParseData :: forall t (s :: * -> * -> *) a.
(Parseable t, IsSymbExpr s, Show a) =>
s t a -> [t] -> [a]
evaluatorWithParseData = ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]
forall t (s :: * -> * -> *) a.
(Parseable t, IsSymbExpr s, Show a) =>
ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]
evaluatorWithParseDataAndOptions [] [] 

evaluatorWithParseDataAndOptions :: (Parseable t, IsSymbExpr s, Show a) => ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]
evaluatorWithParseDataAndOptions :: forall t (s :: * -> * -> *) a.
(Parseable t, IsSymbExpr s, Show a) =>
ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]
evaluatorWithParseDataAndOptions ParseOptions
popts CombinatorOptions
opts s t a
p' [t]
input = 
    let SymbExpr (Nt Nt
start,Grammar_Expr t
vpa2,Sem_Symb t a
vpa3) = SymbExpr t a -> SymbExpr t a
forall t b. (Show t, Ord t) => SymbExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (String
"__Start" String -> OO [] AltExpr t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<:=> [AltExpr t a] -> OO [] AltExpr t a
forall (f :: * -> *) (j :: * -> * -> *) a b.
f (j a b) -> OO f j a b
OO [a -> a
forall a. a -> a
id (a -> a) -> s t a -> AltExpr t a
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p'])
        rules :: Map Nt [Prod t]
rules       = Grammar_Expr t
vpa2 Map Nt [Prod t]
forall k a. Map k a
M.empty
        grammar :: (Nt, [Prod t])
grammar     = (Nt
start, [ Prod t
p | (Nt
_, [Prod t]
alts) <- Map Nt [Prod t] -> [(Nt, [Prod t])]
forall k a. Map k a -> [(k, a)]
M.assocs Map Nt [Prod t]
rules, Prod t
p <- [Prod t]
alts ])
        parse_res :: ParseResult t
parse_res   = ParseOptions -> (Nt, [Prod t]) -> [t] -> ParseResult t
forall t.
Parseable t =>
ParseOptions -> Grammar t -> [t] -> ParseResult t
GLL.parseWithOptions (ParseOptions
poptsParseOptions -> ParseOptions -> ParseOptions
forall a. [a] -> [a] -> [a]
++[ParseOption
packedNodesOnly,ParseOption
strictBinarisation]) (Nt, [Prod t])
grammar [t]
input
        arr :: Input t
arr         = [t] -> Input t
forall t. Parseable t => [t] -> Input t
mkInput [t]
input 
        (Int
_,Int
m)       = Input t -> (Int, Int)
forall i e. Array i e -> (i, i)
A.bounds Input t
arr
    in IO [a] -> [a]
forall a. IO a -> a
unsafePerformIO (IO [a] -> [a]) -> IO [a] -> [a]
forall a b. (a -> b) -> a -> b
$ do 
          let (Nt
_,[Prod t]
prods) = (Nt, [Prod t])
grammar
              nt_set :: Ancestors Any
nt_set = [Nt] -> Ancestors Any
forall a. Ord a => [a] -> Set a
S.fromList [ Nt
x | Prod Nt
x Symbols t
_ <- [Prod t]
prods ]
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#production:          " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Prod t] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Prod t]
prods)
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#nonterminals:        " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Ancestors Any -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Ancestors Any
nt_set)
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"largest nonterminal:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ( 
            (Nt -> Int -> Int) -> Int -> Ancestors Any -> Int
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Nt
x -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Nt -> Int
Data.Text.length Nt
x)) Int
0 Ancestors Any
nt_set)

          UTCTime
startTime <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#tokens:              " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
m)
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#successes:           " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ParseResult t -> Int
forall t. ParseResult t -> Int
res_successes ParseResult t
parse_res)
          UTCTime
endTime <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"recognition time:     " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime)
          UTCTime
startTime' <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#descriptors          " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ParseResult t -> Int
forall t. ParseResult t -> Int
nr_descriptors ParseResult t
parse_res)
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"#EPNs                 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ParseResult t -> Int
forall t. ParseResult t -> Int
nr_packed_node_attempts ParseResult t
parse_res) 
          UTCTime
endTime <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"parse-data time:      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime')
          UTCTime
startTime' <- IO UTCTime
getCurrentTime
          [a]
as <- Sem_Symb t a
vpa3 (CombinatorOptions -> PCOptions
runOptions CombinatorOptions
opts) Ancestors Any
forall t. Ancestors Any
emptyAncestors (ParseResult t -> SPPF t
forall t. ParseResult t -> SPPF t
sppf_result ParseResult t
parse_res) Input t
arr Int
0 Int
m
--          putStrLn $ "#derivations:         " ++ show (length as)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
as)) (String -> String -> IO ()
writeFile String
"/tmp/derivation" (a -> String
forall a. Show a => a -> String
show ([a] -> a
forall a. HasCallStack => [a] -> a
head [a]
as)))
          UTCTime
endTime <- IO UTCTime
getCurrentTime
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"semantic phase:       " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime')
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"total time:           " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
startTime)
          [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
as

-- | The grammar of a given symbol expression.
grammarOf :: (Show t, Parseable t, IsSymbExpr s) => s t a -> Grammar t
grammarOf :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
s t a -> Grammar t
grammarOf s t a
p = (\(Grammar t
f,ParseResult t
_,Either String [a]
_) -> Grammar t
f) (ParseOptions
-> PCOptions
-> s t a
-> [t]
-> (Grammar t, ParseResult t, Either String [a])
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions
-> PCOptions
-> s t a
-> [t]
-> (Grammar t, ParseResult t, Either String [a])
parse' ParseOptions
defaultPOpts PCOptions
defaultOptions s t a
p [])

-- | Print some information about the grammar constructed by a 'IsSymbExpr'.
-- useful for debugging purposes
printGrammarData :: (Show t, Parseable t, IsSymbExpr s) => s t a -> IO ()
printGrammarData :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
s t a -> IO ()
printGrammarData s t a
p = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"production:           " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Prod t] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Prod t]
prods)
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"nonterminals:         " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Ancestors Any -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Ancestors Any
nt_set)
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"largest nonterminal:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ( 
    (Nt -> Int -> Int) -> Int -> Ancestors Any -> Int
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Nt
x -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Nt -> Int
Data.Text.length Nt
x)) Int
0 Ancestors Any
nt_set)
  where (Nt
_,[Prod t]
prods) = s t a -> (Nt, [Prod t])
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
s t a -> Grammar t
grammarOf s t a
p
        nt_set :: Ancestors Any
nt_set    = [Nt] -> Ancestors Any
forall a. Ord a => [a] -> Set a
S.fromList [ Nt
x | Prod Nt
x Symbols t
_ <- [Prod t]
prods ]

-- | 
-- Runs a parser given a string of 'Parseable's and returns a list of 
-- semantic results, corresponding to all finitely many derivations.
parse :: (Show t, Parseable t, IsSymbExpr s) => s t a -> [t] -> [a]
parse :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
s t a -> [t] -> [a]
parse = CombinatorOptions -> s t a -> [t] -> [a]
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
CombinatorOptions -> s t a -> [t] -> [a]
parseWithOptions [CombinatorOption
throwErrors] 

-- | 
-- Run the parser with some 'CombinatorOptions'.
parseWithOptions :: (Show t, Parseable t, IsSymbExpr s) => 
                        CombinatorOptions -> s t a -> [t] -> [a]
parseWithOptions :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
CombinatorOptions -> s t a -> [t] -> [a]
parseWithOptions CombinatorOptions
opts s t a
p [t]
ts = ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]
parseWithParseOptions ParseOptions
defaultPOpts CombinatorOptions
opts s t a
p [t]
ts

-- | 
-- Run the parser with some 'ParseOptions' and 'CombinatorOptions'.
parseWithParseOptions :: (Show t, Parseable t, IsSymbExpr s) => 
                     ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]
parseWithParseOptions :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]
parseWithParseOptions ParseOptions
pcopts CombinatorOptions
opts s t a
p [t]
ts = 
    case ParseOptions
-> CombinatorOptions -> s t a -> [t] -> Either String [a]
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions
-> CombinatorOptions -> s t a -> [t] -> Either String [a]
parseWithParseOptionsAndError ParseOptions
pcopts CombinatorOptions
opts s t a
p [t]
ts of
        Left String
str | PCOptions -> Bool
throw_errors PCOptions
opts'   -> String -> [a]
forall a. HasCallStack => String -> a
error String
str
                 | Bool
otherwise            -> []
        Right [a]
as                        -> [a]
as
    where opts' :: PCOptions
opts' = CombinatorOptions -> PCOptions
runOptions CombinatorOptions
opts


-- | 
-- Run the parser with some 'CombinatorOptions' and return either an error or the results.
-- Any returned results will be a list of length greater than 0.
parseWithOptionsAndError :: (Show t, Parseable t, IsSymbExpr s) => 
                        CombinatorOptions -> s t a -> [t] -> Either String [a]
parseWithOptionsAndError :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
CombinatorOptions -> s t a -> [t] -> Either String [a]
parseWithOptionsAndError CombinatorOptions
opts s t a
p = ParseOptions
-> CombinatorOptions -> s t a -> [t] -> Either String [a]
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions
-> CombinatorOptions -> s t a -> [t] -> Either String [a]
parseWithParseOptionsAndError ParseOptions
defaultPOpts CombinatorOptions
opts s t a
p 

-- | 
-- Run the parser with some 'ParseOptions' and 'CombinatorOptions'.
-- Returns either an error or the results.
-- Any returned results will be a list of length greater than 0.
parseWithParseOptionsAndError :: (Show t, Parseable t, IsSymbExpr s) => 
       ParseOptions -> CombinatorOptions -> s t a -> [t] -> Either String [a]
parseWithParseOptionsAndError :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions
-> CombinatorOptions -> s t a -> [t] -> Either String [a]
parseWithParseOptionsAndError ParseOptions
popts CombinatorOptions
opts s t a
p = (\(Grammar t
_,ParseResult t
_,Either String [a]
t) -> Either String [a]
t) ((Grammar t, ParseResult t, Either String [a])
 -> Either String [a])
-> ([t] -> (Grammar t, ParseResult t, Either String [a]))
-> [t]
-> Either String [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseOptions
-> PCOptions
-> s t a
-> [t]
-> (Grammar t, ParseResult t, Either String [a])
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions
-> PCOptions
-> s t a
-> [t]
-> (Grammar t, ParseResult t, Either String [a])
parse' ParseOptions
defaultPOpts (CombinatorOptions -> PCOptions
runOptions CombinatorOptions
opts) s t a
p


-- | Get the 'ParseResult', containing an 'SPPF', 
--  produced by parsing the given input with the given parser.
parseResult :: (Show t, Parseable t, IsSymbExpr s) => s t a -> [t] -> ParseResult t
parseResult :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
s t a -> [t] -> ParseResult t
parseResult = ParseOptions -> CombinatorOptions -> s t a -> [t] -> ParseResult t
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions -> CombinatorOptions -> s t a -> [t] -> ParseResult t
parseResultWithOptions [] [] 

-- | Get the 'ParseResult' given some 'ParseOptions' and 'CombinatorOptions'. 
parseResultWithOptions :: (Show t, Parseable t, IsSymbExpr s) => 
         ParseOptions -> CombinatorOptions -> s t a -> [t] -> ParseResult t
parseResultWithOptions :: forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions -> CombinatorOptions -> s t a -> [t] -> ParseResult t
parseResultWithOptions ParseOptions
popts CombinatorOptions
opts s t a
p [t]
str = 
    (\(Grammar t
_,ParseResult t
s,Either String [a]
_) -> ParseResult t
s) ((Grammar t, ParseResult t, Either String [a]) -> ParseResult t)
-> (Grammar t, ParseResult t, Either String [a]) -> ParseResult t
forall a b. (a -> b) -> a -> b
$ ParseOptions
-> PCOptions
-> s t a
-> [t]
-> (Grammar t, ParseResult t, Either String [a])
forall t (s :: * -> * -> *) a.
(Show t, Parseable t, IsSymbExpr s) =>
ParseOptions
-> PCOptions
-> s t a
-> [t]
-> (Grammar t, ParseResult t, Either String [a])
parse' ParseOptions
popts (CombinatorOptions -> PCOptions
runOptions CombinatorOptions
opts) s t a
p [t]
str

defaultPOpts :: ParseOptions
defaultPOpts = [ParseOption
strictBinarisation, ParseOption
packedNodesOnly]

infixl 2 <:=>
-- | 
-- Form a rule by giving the name of the left-hand side of the new rule.
-- Use this combinator on recursive non-terminals.
(<:=>) :: (Show t, Ord t, HasAlts b) => String -> b t a -> SymbExpr t a 
String
x <:=> :: forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<:=> b t a
altPs = Bool -> Bool -> String -> b t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
Bool -> Bool -> String -> b t a -> SymbExpr t a
mkNtRule Bool
False Bool
False String
x b t a
altPs
infixl 2 <::=>

-- | 
--  Variant of '<:=>' for recursive non-terminals that have a potentially infinite
--  number of derivations for some input string.
--
--  A non-terminal yields infinitely many derivations  
--  if and only if it is left-recursive and would be
--  left-recursive if all the right-hand sides of the productions of the
--  grammar are reversed.
(<::=>) :: (Show t, Ord t, HasAlts b) => String -> b t a -> SymbExpr t a 
String
x <::=> :: forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<::=> b t a
altPs = Bool -> Bool -> String -> b t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
Bool -> Bool -> String -> b t a -> SymbExpr t a
mkNtRule Bool
True Bool
False String
x b t a
altPs

-- | Variant of '<::=>' that can be supplied with a list of alternates
chooses :: (Show t, Ord t, IsAltExpr alt) => String -> [alt t a] -> SymbExpr t a
chooses :: forall t (alt :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr alt) =>
String -> [alt t a] -> SymbExpr t a
chooses String
p [alt t a]
alts | [alt t a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [alt t a]
alts = String -> SymbExpr t a
forall a. HasCallStack => String -> a
error String
"chooses cannot be given an empty list of alternatives"
               | Bool
otherwise = String -> OO [] AltExpr t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
(<::=>) String
p ([AltExpr t a] -> OO [] AltExpr t a
forall (f :: * -> *) (j :: * -> * -> *) a b.
f (j a b) -> OO f j a b
OO ((alt t a -> AltExpr t a) -> [alt t a] -> [AltExpr t a]
forall a b. (a -> b) -> [a] -> [b]
map alt t a -> AltExpr t a
forall t b. (Show t, Ord t) => alt t b -> AltExpr t b
forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt [alt t a]
alts))

-- | Variant of '<::=' that can be supplied with a list of alternates
chooses_prec :: (Show t, Ord t, IsAltExpr alt) => String -> [alt t a] -> SymbExpr t a
chooses_prec :: forall t (alt :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr alt) =>
String -> [alt t a] -> SymbExpr t a
chooses_prec String
p [alt t a]
alts | [alt t a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [alt t a]
alts = String -> SymbExpr t a
forall a. HasCallStack => String -> a
error String
"chooses cannot be given an empty list of alternatives"
                    | Bool
otherwise = String -> OO [] AltExpr t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
(<::=) String
p ([AltExpr t a] -> OO [] AltExpr t a
forall (f :: * -> *) (j :: * -> * -> *) a b.
f (j a b) -> OO f j a b
OO ((alt t a -> AltExpr t a) -> [alt t a] -> [AltExpr t a]
forall a b. (a -> b) -> [a] -> [b]
map alt t a -> AltExpr t a
forall t b. (Show t, Ord t) => alt t b -> AltExpr t b
forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt [alt t a]
alts))

infixl 4 <$$>
-- |
-- Form an 'AltExpr' by mapping some semantic action overy the result
-- of the second argument.
(<$$>) :: (Show t, Ord t, IsSymbExpr s) => (a -> b) -> s t a -> AltExpr t b
a -> b
f <$$> :: forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p' = (a -> b) -> s t a -> AltExpr t b
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
join_apply a -> b
f s t a
p'

infixl 4 <**>,<<<**>,<**>>>
-- | 
-- Add a 'SymbExpr' to the right-hand side represented by an 'AltExpr'
-- creating a new 'AltExpr'. 
-- The semantic result of the first argument is applied to the second 
-- as a cross-product. 
(<**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => 
            i t (a -> b) -> s t a -> AltExpr t b
i t (a -> b)
pl' <**> :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> s t a
pr' = CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b
join_seq [] i t (a -> b)
pl' s t a
pr'

-- | Variant of '<**>' that applies longest match on the left operand.
(<**>>>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => 
            i t (a -> b) -> s t a -> AltExpr t b
i t (a -> b)
pl' <**>>> :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**>>> s t a
pr' = CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b
join_seq [CombinatorOption
maximumPivot] i t (a -> b)
pl' s t a
pr'

-- | Variant of '<**>' that applies shortest match on the left operand.
(<<<**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => 
            i t (a -> b) -> s t a -> AltExpr t b
i t (a -> b)
pl' <<<**> :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<<<**> s t a
pr' = CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b
join_seq [CombinatorOption
minimumPivot] i t (a -> b)
pl' s t a
pr'


infixr 3 <||>
-- |
-- Add an 'AltExpr' to a list of 'AltExpr'
-- The resuling  '[] :. AltExpr' forms the right-hand side of a rule.
(<||>) :: (Show t, Ord t, IsAltExpr i, HasAlts b) => i t a -> b t a -> AltExprs t a
i t a
l' <||> :: forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||> b t a
r' = let l :: AltExpr t a
l = i t a -> AltExpr t a
forall t b. (Show t, Ord t) => i t b -> AltExpr t b
forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt i t a
l'
                 r :: [AltExpr t a]
r = b t a -> [AltExpr t a]
forall t b. (Show t, Ord t) => b t b -> [AltExpr t b]
forall (a :: * -> * -> *) t b.
(HasAlts a, Show t, Ord t) =>
a t b -> [AltExpr t b]
altsOf b t a
r'
             in [AltExpr t a] -> OO [] AltExpr t a
forall (f :: * -> *) (j :: * -> * -> *) a b.
f (j a b) -> OO f j a b
OO (AltExpr t a
l AltExpr t a -> [AltExpr t a] -> [AltExpr t a]
forall a. a -> [a] -> [a]
: [AltExpr t a]
r)

-- |
-- Apply this combinator to an alternative to turn all underlying occurrences
-- of '<**>' (or variants) apply 'longest match'.
longest_match :: (Show t, Ord t, IsAltExpr alt) => alt t a -> AltExpr t a
longest_match :: forall t (alt :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr alt) =>
alt t a -> AltExpr t a
longest_match alt t a
isalt = ([Symbol t], Grammar_Expr t, Sem_Alt t a) -> AltExpr t a
forall t a.
([Symbol t], Grammar_Expr t, Sem_Alt t a) -> AltExpr t a
AltExpr ([Symbol t]
v1,Grammar_Expr t
v2,\PCOptions
opts -> Sem_Alt t a
v3 (CombinatorOption
maximumPivot PCOptions
opts))
  where AltExpr ([Symbol t]
v1,Grammar_Expr t
v2,Sem_Alt t a
v3) = alt t a -> AltExpr t a
forall t b. (Show t, Ord t) => alt t b -> AltExpr t b
forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt alt t a
isalt 

-- Apply this combinator to an alternative to turn all underlying occurrences
-- of '<**>' (or variants) apply 'shortest match'.
shortest_match :: (Show t, Ord t, IsAltExpr alt) => alt t a -> AltExpr t a
shortest_match :: forall t (alt :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr alt) =>
alt t a -> AltExpr t a
shortest_match alt t a
isalt = ([Symbol t], Grammar_Expr t, Sem_Alt t a) -> AltExpr t a
forall t a.
([Symbol t], Grammar_Expr t, Sem_Alt t a) -> AltExpr t a
AltExpr ([Symbol t]
v1,Grammar_Expr t
v2,\PCOptions
opts -> Sem_Alt t a
v3 (CombinatorOption
minimumPivot PCOptions
opts))
  where AltExpr ([Symbol t]
v1,Grammar_Expr t
v2,Sem_Alt t a
v3) = alt t a -> AltExpr t a
forall t b. (Show t, Ord t) => alt t b -> AltExpr t b
forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt alt t a
isalt 

-- | Create a symbol-parse for a terminal given:
--
--  * The 'Parseable' token represented by the terminal.
--  * A function from that 'Parseable' to a semantic result.
term_parser :: t -> (t -> a) -> SymbExpr t a 
term_parser :: forall t a. t -> (t -> a) -> SymbExpr t a
term_parser t
t t -> a
f = (Symbol t, Grammar_Expr t, Sem_Symb t a) -> SymbExpr t a
forall t a.
(Symbol t, Grammar_Expr t, Sem_Symb t a) -> SymbExpr t a
SymbExpr (t -> Symbol t
forall t. t -> Symbol t
Term t
t, Grammar_Expr t
forall a. a -> a
id,\PCOptions
_ Ancestors Any
_ SPPF t
_ Array Int t
arr Int
l Int
_ -> [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [t -> a
f (Array Int t
arr Array Int t -> Int -> t
forall i e. Ix i => Array i e -> i -> e
A.! Int
l)])

-- | Parse a single character.
--
-- @
-- char c = term_parser c id
-- @
--
-- Currently, this is the only character-level combinator exported
-- by this module. Please use token-level combinators for practical parsing.
-- Might change in the future.
char :: Char -> SymbExpr Char Char
char :: Char -> SymbExpr Char Char
char Char
c = Char -> (Char -> Char) -> SymbExpr Char Char
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser Char
c Char -> Char
forall a. a -> a
id
{-
-- | Parse a list of characters.
string :: [Char] -> SymbExpr Char [Char]
string [] = mkRule $ satisfy []
string (c:cs) = mkRule $ (:) <$$> char c <**> string cs

-- | 
-- Apply a parser within two other parsers.
within :: IsSymbExpr s => BNF Char a -> s Char b -> BNF Char c -> BNF Char b
within l p r = mkRule $ l *> (toSymb p) <* r

-- | 
-- Apply a parser within parentheses.
-- parens p = within (char '(') p (char ')')
parens :: BNF Char a -> BNF Char a 
parens p = within (char '(') p (char ')')
-}

-- | Parse a single character, using a 'SubsumesToken' type.
keychar :: SubsumesToken t => Char -> SymbExpr t Char
keychar :: forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
c = t -> (t -> Char) -> SymbExpr t Char
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (Char -> Token
Char Char
c)) (Char -> t -> Char
forall a b. a -> b -> a
const Char
c)        -- helper for Char tokens

-- | Parse a single character, using a 'SubsumesToken' type.
keyword :: SubsumesToken t => String -> SymbExpr t String
keyword :: forall t. SubsumesToken t => String -> SymbExpr t String
keyword String
k = t -> (t -> String) -> SymbExpr t String
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (String -> Token
Keyword String
k)) (String -> t -> String
forall a b. a -> b -> a
const String
k)        -- helper for Char tokens

-- | Parse a single integer, using a 'SubsumesToken' type.
-- Returns the lexeme interpreted as an 'Int'.
int_lit :: SubsumesToken t => SymbExpr t Int
int_lit :: forall t. SubsumesToken t => SymbExpr t Int
int_lit  = t -> (t -> Int) -> SymbExpr t Int
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (Maybe Int -> Token
IntLit Maybe Int
forall a. Maybe a
Nothing)) (Maybe Token -> Int
unwrap (Maybe Token -> Int) -> (t -> Maybe Token) -> t -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe Token
forall a. SubsumesToken a => a -> Maybe Token
downcast)
 where  unwrap :: Maybe Token -> Int
unwrap (Just (IntLit (Just Int
i)))  = Int
i
        unwrap Maybe Token
_ = String -> Int
forall a. HasCallStack => String -> a
error String
"int_lit: downcast, or token without lexeme"

-- | Parse a single floating point literal, using a 'SubsumesToken' type.
-- Returns the lexeme interpreted as a 'Double'.
float_lit :: SubsumesToken t => SymbExpr t Double
float_lit :: forall t. SubsumesToken t => SymbExpr t Double
float_lit  = t -> (t -> Double) -> SymbExpr t Double
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (Maybe Double -> Token
FloatLit Maybe Double
forall a. Maybe a
Nothing)) (Maybe Token -> Double
unwrap (Maybe Token -> Double) -> (t -> Maybe Token) -> t -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe Token
forall a. SubsumesToken a => a -> Maybe Token
downcast)
 where  unwrap :: Maybe Token -> Double
unwrap (Just (FloatLit (Just Double
i)))  = Double
i
        unwrap Maybe Token
_ = String -> Double
forall a. HasCallStack => String -> a
error String
"float_lit: downcast, or token without lexeme"

-- | Parse a single Boolean, using a 'SubsumesToken' type.
-- Returns the lexeme interpreter as a Boolean.
bool_lit :: SubsumesToken t => SymbExpr t Bool
bool_lit :: forall t. SubsumesToken t => SymbExpr t Bool
bool_lit  = t -> (t -> Bool) -> SymbExpr t Bool
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (Maybe Bool -> Token
BoolLit Maybe Bool
forall a. Maybe a
Nothing)) (Maybe Token -> Bool
unwrap (Maybe Token -> Bool) -> (t -> Maybe Token) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe Token
forall a. SubsumesToken a => a -> Maybe Token
downcast)
 where  unwrap :: Maybe Token -> Bool
unwrap (Just (BoolLit (Just Bool
b)))  = Bool
b
        unwrap Maybe Token
_ = String -> Bool
forall a. HasCallStack => String -> a
error String
"bool_lit: downcast, or token without lexeme"

-- | Parse a single Character literal, using a 'SubsumesToken' type.
-- Returns the lexeme interpreted as a Character literal.
char_lit :: SubsumesToken t => SymbExpr t Char
char_lit :: forall t. SubsumesToken t => SymbExpr t Char
char_lit  = t -> (t -> Char) -> SymbExpr t Char
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (Maybe Char -> Token
CharLit Maybe Char
forall a. Maybe a
Nothing)) (Maybe Token -> Char
unwrap (Maybe Token -> Char) -> (t -> Maybe Token) -> t -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe Token
forall a. SubsumesToken a => a -> Maybe Token
downcast)
 where  unwrap :: Maybe Token -> Char
unwrap (Just (CharLit (Just Char
s))) = Char
s
        unwrap Maybe Token
_ = String -> Char
forall a. HasCallStack => String -> a
error String
"char_lit: downcast, or token without lexeme"

-- | Parse a single String literal, using a 'SubsumesToken' type.
-- Returns the lexeme interpreted as a String literal.
string_lit :: SubsumesToken t => SymbExpr t String
string_lit :: forall t. SubsumesToken t => SymbExpr t String
string_lit  = t -> (t -> String) -> SymbExpr t String
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (Maybe String -> Token
StringLit Maybe String
forall a. Maybe a
Nothing)) (Maybe Token -> String
unwrap (Maybe Token -> String) -> (t -> Maybe Token) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe Token
forall a. SubsumesToken a => a -> Maybe Token
downcast)
 where  unwrap :: Maybe Token -> String
unwrap (Just (StringLit (Just String
i))) = String
i
        unwrap Maybe Token
_ = String -> String
forall a. HasCallStack => String -> a
error String
"string_lit: downcast, or token without lexeme"

-- | Parse a single identifier, using a 'SubsumesToken' type.
-- Returns the lexeme as a String.
id_lit :: SubsumesToken t => SymbExpr t String
id_lit :: forall t. SubsumesToken t => SymbExpr t String
id_lit = t -> (t -> String) -> SymbExpr t String
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (Maybe String -> Token
IDLit Maybe String
forall a. Maybe a
Nothing)) (Maybe Token -> String
unwrap (Maybe Token -> String) -> (t -> Maybe Token) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe Token
forall a. SubsumesToken a => a -> Maybe Token
downcast)
 where  unwrap :: Maybe Token -> String
unwrap (Just (IDLit (Just String
i))) = String
i
        unwrap Maybe Token
_ = String -> String
forall a. HasCallStack => String -> a
error String
"id_lit: downcast, or token without lexeme"

-- | Parse a single alternative identifier, using a 'SubsumesToken' type.
-- Returns the lexeme as a String.
alt_id_lit :: SubsumesToken t => SymbExpr t String
alt_id_lit :: forall t. SubsumesToken t => SymbExpr t String
alt_id_lit = t -> (t -> String) -> SymbExpr t String
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (Maybe String -> Token
AltIDLit Maybe String
forall a. Maybe a
Nothing)) (Maybe Token -> String
unwrap (Maybe Token -> String) -> (t -> Maybe Token) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe Token
forall a. SubsumesToken a => a -> Maybe Token
downcast)
 where  unwrap :: Maybe Token -> String
unwrap (Just (AltIDLit (Just String
i))) = String
i
        unwrap Maybe Token
_ = String -> String
forall a. HasCallStack => String -> a
error String
"alt_id_lit: downcast, or token without lexeme"


-- | Parse a single arbitrary token, using a 'SubsumesToken' type.
-- Returns the lexeme.
token :: SubsumesToken t => String -> SymbExpr t String
token :: forall t. SubsumesToken t => String -> SymbExpr t String
token String
name = t -> (t -> String) -> SymbExpr t String
forall t a. t -> (t -> a) -> SymbExpr t a
term_parser (Token -> t
forall a. SubsumesToken a => Token -> a
upcast (String -> Maybe String -> Token
Token String
name Maybe String
forall a. Maybe a
Nothing)) (Maybe Token -> String
unwrap (Maybe Token -> String) -> (t -> Maybe Token) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe Token
forall a. SubsumesToken a => a -> Maybe Token
downcast)
 where  unwrap :: Maybe Token -> String
unwrap (Just (Token String
name' (Just String
i))) | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name' = String
i
        unwrap Maybe Token
_  = String -> String
forall a. HasCallStack => String -> a
error String
"tokenT: downcast, or token without lexeme"

epsilon :: (Show t, Ord t) => AltExpr t ()
epsilon :: forall t. (Show t, Ord t) => AltExpr t ()
epsilon = ([Symbol t], Grammar_Expr t, Sem_Alt t ()) -> AltExpr t ()
forall t a.
([Symbol t], Grammar_Expr t, Sem_Alt t a) -> AltExpr t a
AltExpr ([], Nt -> [Prod t] -> Grammar_Expr t
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (String -> Nt
pack String
x) [Nt -> [Symbol t] -> Prod t
forall t. Nt -> Symbols t -> Prod t
Prod (String -> Nt
pack String
x) []],\PCOptions
_ (Prod t, Int)
_ Ancestors Any
_ SPPF t
_ Array Int t
_ Int
l Int
r -> 
                        if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r then [(Int, ())] -> IO [(Int, ())]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
l,())] else [(Int, ())] -> IO [(Int, ())]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [] )
    where x :: String
x = String
"__eps"

-- | The empty right-hand side that yields its 
--  first argument as a semantic result.
satisfy :: (Show t, Ord t ) => a -> AltExpr t a
satisfy :: forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy a
a = a
a a -> AltExpr t () -> AltExpr t a
forall t (s :: * -> * -> *) b a.
(Show t, Ord t, IsSymbExpr s) =>
b -> s t a -> AltExpr t b
<$$ AltExpr t ()
forall t. (Show t, Ord t) => AltExpr t ()
epsilon

-- | 
-- This function memoises a parser, given:
--
-- * A 'MemoRef' pointing to a fresh 'MemoTable', created using 'newMemoTable'.
-- * The 'SymbExpr' to memoise.
--
-- Use 'memo' on those parsers that are expected to derive the same 
-- substring multiple times. If the same combinator expression is used
-- to parse multiple times the 'MemoRef' needs to be cleared using 'memClear'.
--
-- 'memo' relies on 'unsafePerformIO' and is therefore potentially unsafe.
-- The option 'useMemoisation' enables memoisation.
-- It is off by default, even if 'memo' is used in a combinator expression.
memo :: (Ord t, Show t, IsSymbExpr s) => MemoRef [a] -> s t a -> SymbExpr t a
memo :: forall t (s :: * -> * -> *) a.
(Ord t, Show t, IsSymbExpr s) =>
MemoRef [a] -> s t a -> SymbExpr t a
memo MemoRef [a]
ref s t a
p' = let   SymbExpr (Symbol t
sym,Grammar_Expr t
rules,Sem_Symb t a
sem) = s t a -> SymbExpr t a
forall t b. (Show t, Ord t) => s t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
toSymb s t a
p'
                    lhs_sem :: Sem_Symb t a
lhs_sem PCOptions
opts Ancestors Any
ctx SPPF t
sppf Array Int t
arr Int
l Int
r 
                        | Bool -> Bool
not (PCOptions -> Bool
do_memo PCOptions
opts) = Sem_Symb t a
sem PCOptions
opts Ancestors Any
ctx SPPF t
sppf Array Int t
arr Int
l Int
r
                        | Bool
otherwise = do
                            MemoTable [a]
tab <- MemoRef [a] -> IO (MemoTable [a])
forall a. IORef a -> IO a
readIORef MemoRef [a]
ref
                            case (Int, Int) -> MemoTable [a] -> Maybe [a]
forall a. (Int, Int) -> MemoTable a -> Maybe a
memLookup (Int
l,Int
r) MemoTable [a]
tab of
                                Just [a]
as -> [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
as
                                Maybe [a]
Nothing -> do   [a]
as <- Sem_Symb t a
sem PCOptions
opts Ancestors Any
ctx SPPF t
sppf Array Int t
arr Int
l Int
r
                                                MemoRef [a] -> (MemoTable [a] -> MemoTable [a]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef MemoRef [a]
ref ((Int, Int) -> [a] -> MemoTable [a] -> MemoTable [a]
forall a. (Int, Int) -> a -> MemoTable a -> MemoTable a
memInsert (Int
l,Int
r) [a]
as)
                                                [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
as
               in (Symbol t, Grammar_Expr t, Sem_Symb t a) -> SymbExpr t a
forall t a.
(Symbol t, Grammar_Expr t, Sem_Symb t a) -> SymbExpr t a
SymbExpr (Symbol t
sym, Grammar_Expr t
rules, Sem_Symb t a
lhs_sem)

-- | 
-- Helper function for defining new combinators.
-- Use 'mkNt' to form a new unique non-terminal name based on
-- the symbol of a given 'SymbExpr' and a 'String' that is unique to
-- the newly defined combinator.
mkNt :: (Show t, Ord t, IsSymbExpr s) => s t a -> String -> String 
mkNt :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t a
p String
str = let SymbExpr (Symbol t
myx,Grammar_Expr t
_,Sem_Symb t a
_) = s t a -> SymbExpr t a
forall t b. (Show t, Ord t) => s t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule s t a
p
                in String
"_(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Symbol t -> String
forall a. Show a => a -> String
show Symbol t
myx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str

-- | Specialised fmap for altparsers
(.$.) :: (Show t, Ord t, IsAltExpr i) => (a -> b) -> i t a -> AltExpr t b
a -> b
f .$. :: forall t (i :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i) =>
(a -> b) -> i t a -> AltExpr t b
.$. i t a
i = let AltExpr ([Symbol t]
s,Grammar_Expr t
r,Sem_Alt t a
sem) = i t a -> AltExpr t a
forall t b. (Show t, Ord t) => i t b -> AltExpr t b
forall (a :: * -> * -> *) t b.
(IsAltExpr a, Show t, Ord t) =>
a t b -> AltExpr t b
toAlt i t a
i
            in ([Symbol t], Grammar_Expr t, Sem_Alt t b) -> AltExpr t b
forall t a.
([Symbol t], Grammar_Expr t, Sem_Alt t a) -> AltExpr t a
AltExpr ([Symbol t]
s,Grammar_Expr t
r,\PCOptions
opts (Prod t, Int)
slot Ancestors Any
ctx SPPF t
sppf Array Int t
arr Int
l Int
r -> 
                                do  [(Int, a)]
as <- Sem_Alt t a
sem PCOptions
opts (Prod t, Int)
slot Ancestors Any
ctx SPPF t
sppf Array Int t
arr Int
l Int
r
                                    [(Int, b)] -> IO [(Int, b)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, b)] -> IO [(Int, b)]) -> [(Int, b)] -> IO [(Int, b)]
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> (Int, b)) -> [(Int, a)] -> [(Int, b)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
forall a. a -> a
id (Int -> Int) -> (a -> b) -> (Int, a) -> (Int, b)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a -> b
f) [(Int, a)]
as )

-- | 
-- Variant of '<$$>' that ignores the semantic result of its second argument. 
(<$$) :: (Show t, Ord t, IsSymbExpr s) => b -> s t a -> AltExpr t b
b
f <$$ :: forall t (s :: * -> * -> *) b a.
(Show t, Ord t, IsSymbExpr s) =>
b -> s t a -> AltExpr t b
<$$ s t a
p = b -> a -> b
forall a b. a -> b -> a
const b
f (a -> b) -> s t a -> AltExpr t b
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p
infixl 4 <$$

-- | 
infixl 4 **>, <<**>, **>>>

-- | 
-- Variant of '<**>' that ignores the semantic result of the first argument.
(**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t b
i t a
l **> :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t b
**> s t b
r = (b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> b
forall a b. a -> b -> a
const (a -> b -> b) -> i t a -> AltExpr t (b -> b)
forall t (i :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i) =>
(a -> b) -> i t a -> AltExpr t b
.$. i t a
l AltExpr t (b -> b) -> s t b -> AltExpr t b
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> s t b
r

-- Variant of '<**>' that applies longest match on its left operand. 
(**>>>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t b
i t a
l **>>> :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t b
**>>> s t b
r = (b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> b
forall a b. a -> b -> a
const (a -> b -> b) -> i t a -> AltExpr t (b -> b)
forall t (i :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i) =>
(a -> b) -> i t a -> AltExpr t b
.$. i t a
l AltExpr t (b -> b) -> s t b -> AltExpr t b
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**>>> s t b
r

-- Variant of '<**>' that ignores shortest match on its left operand.
(<<**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t b
i t a
l <<**> :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t b
<<**>s t b
r = (b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> b
forall a b. a -> b -> a
const (a -> b -> b) -> i t a -> AltExpr t (b -> b)
forall t (i :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i) =>
(a -> b) -> i t a -> AltExpr t b
.$. i t a
l AltExpr t (b -> b) -> s t b -> AltExpr t b
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<<<**> s t b
r


infixl 4 <**, <<<**, <**>>
-- | 
-- Variant of '<**>' that ignores the semantic result of the second argument.
(<**) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t a
i t a
l <** :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t a
<** s t b
r = a -> b -> a
forall a b. a -> b -> a
const (a -> b -> a) -> i t a -> AltExpr t (b -> a)
forall t (i :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i) =>
(a -> b) -> i t a -> AltExpr t b
.$. i t a
l AltExpr t (b -> a) -> s t b -> AltExpr t a
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> s t b
r 

-- | Variant of '<**' that applies longest match on its left operand.
(<**>>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t a
i t a
l <**>> :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t a
<**>> s t b
r = a -> b -> a
forall a b. a -> b -> a
const (a -> b -> a) -> i t a -> AltExpr t (b -> a)
forall t (i :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i) =>
(a -> b) -> i t a -> AltExpr t b
.$. i t a
l AltExpr t (b -> a) -> s t b -> AltExpr t a
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**>>> s t b
r 

-- | Variant '<**' that applies shortest match on its left operand
(<<<**) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t a
i t a
l <<<** :: forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t a
<<<** s t b
r = a -> b -> a
forall a b. a -> b -> a
const (a -> b -> a) -> i t a -> AltExpr t (b -> a)
forall t (i :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i) =>
(a -> b) -> i t a -> AltExpr t b
.$. i t a
l AltExpr t (b -> a) -> s t b -> AltExpr t a
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<<<**> s t b
r 

-- | 
-- Variant of '<::=>' that prioritises productions from left-to-right (or top-to-bottom).
String
x <::= :: String -> b t a -> SymbExpr t a
<::= b t a
altPs = Bool -> Bool -> String -> b t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
Bool -> Bool -> String -> b t a -> SymbExpr t a
mkNtRule Bool
True Bool
True String
x b t a
altPs 
infixl 2 <::=

-- | 
-- Variant of '<:=>' that prioritises productions from left-to-right (or top-to-bottom).
String
x <:= :: String -> b t a -> SymbExpr t a
<:= b t a
altPs = Bool -> Bool -> String -> b t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
Bool -> Bool -> String -> b t a -> SymbExpr t a
mkNtRule Bool
False Bool
True String
x b t a
altPs 
infixl 2 <:=

-- | Try to apply a parser multiple times (0 or more) with shortest match
-- applied to each occurrence of the parser.
many :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]
many :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
many = (AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a])
-> s t a -> SymbExpr t [a]
forall {i :: * -> * -> *} {t} {t} {s :: * -> * -> *} {a} {a}.
(IsAltExpr i, Show t, Show t, Ord t, Ord t, IsSymbExpr s) =>
(AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
(<<<**>)

-- | Try to apply a parser multiple times (1 or more) with shortest match
-- applied to each occurrence of the parser.
many1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]
many1 :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
many1 = (AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a])
-> s t a -> SymbExpr t [a]
forall {i :: * -> * -> *} {t} {t} {s :: * -> * -> *} {a} {a}.
(HasAlts i, IsAltExpr i, Show t, Show t, Ord t, Ord t,
 IsSymbExpr s) =>
(AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple1_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
(<<<**>) 

-- | Try to apply a parser multiple times (0 or more) with longest match
-- applied to each occurrence of the parser.
some :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]
some :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
some = (AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a])
-> s t a -> SymbExpr t [a]
forall {i :: * -> * -> *} {t} {t} {s :: * -> * -> *} {a} {a}.
(IsAltExpr i, Show t, Show t, Ord t, Ord t, IsSymbExpr s) =>
(AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
(<**>>>)

-- | Try to apply a parser multiple times (1 or more) with longest match
-- applied to each occurrence of the parser.
some1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]
some1 :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
some1 = (AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a])
-> s t a -> SymbExpr t [a]
forall {i :: * -> * -> *} {t} {t} {s :: * -> * -> *} {a} {a}.
(HasAlts i, IsAltExpr i, Show t, Show t, Ord t, Ord t,
 IsSymbExpr s) =>
(AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple1_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
(<**>>>) 

-- | Try to apply a parser multiple times (0 or more). The results are returned in a list.
-- In the case of ambiguity the largest list is returned.
multiple :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]
multiple :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
multiple = (AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a])
-> s t a -> SymbExpr t [a]
forall {i :: * -> * -> *} {t} {t} {s :: * -> * -> *} {a} {a}.
(IsAltExpr i, Show t, Show t, Ord t, Ord t, IsSymbExpr s) =>
(AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
(<**>)

-- | Try to apply a parser multiple times (1 or more). The results are returned in a list.
-- In the case of ambiguity the largest list is returned.
multiple1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]
multiple1 :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
multiple1 = (AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a])
-> s t a -> SymbExpr t [a]
forall {i :: * -> * -> *} {t} {t} {s :: * -> * -> *} {a} {a}.
(HasAlts i, IsAltExpr i, Show t, Show t, Ord t, Ord t,
 IsSymbExpr s) =>
(AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple1_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
(<**>)

-- | Internal
multiple_ :: (AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a]
disa s t a
p = let fresh :: String
fresh = s t a -> String -> String
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t a
p String
"*" 
                    in String
fresh String -> OO [] AltExpr t [a] -> SymbExpr t [a]
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<::=> ((:) (a -> [a] -> [a]) -> s t a -> AltExpr t ([a] -> [a])
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p) AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a]
`disa` ((AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a]
disa s t a
p) i t [a] -> AltExpr t [a] -> OO [] AltExpr t [a]
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||> [a] -> AltExpr t [a]
forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy []

-- | Internal
multiple1_ :: (AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple1_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a]
disa s t a
p = let fresh :: String
fresh = s t a -> String -> String
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t a
p String
"+"
                     in String
fresh String -> i t [a] -> SymbExpr t [a]
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<::=> ((:) (a -> [a] -> [a]) -> s t a -> AltExpr t ([a] -> [a])
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p) AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a]
`disa` ((AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
forall {i :: * -> * -> *} {t} {t} {s :: * -> * -> *} {a} {a}.
(IsAltExpr i, Show t, Show t, Ord t, Ord t, IsSymbExpr s) =>
(AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a])
-> s t a -> SymbExpr t [a]
multiple_ AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> i t [a]
disa s t a
p)

-- | Same as 'many' but with an additional separator.
manySepBy :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => 
                s t a -> s2 t b -> SymbExpr t [a]
manySepBy :: forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
manySepBy = (AltExpr t a -> SymbExpr t [a])
-> s t a -> s2 t b -> SymbExpr t [a]
forall t (s1 :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) =>
(AltExpr t a -> SymbExpr t [a])
-> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy AltExpr t a -> SymbExpr t [a]
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
many
-- | Same as 'many1' but with an additional separator.
manySepBy1 :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => 
                s t a -> s2 t b -> SymbExpr t [a]
manySepBy1 :: forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
manySepBy1 = (AltExpr t a -> SymbExpr t [a])
-> s t a -> s2 t b -> SymbExpr t [a]
forall t (s1 :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) =>
(AltExpr t a -> SymbExpr t [a])
-> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy1 AltExpr t a -> SymbExpr t [a]
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
many
-- | Same as 'some1' but with an additional separator.
someSepBy :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => 
                s t a -> s2 t b -> SymbExpr t [a]
someSepBy :: forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
someSepBy = (AltExpr t a -> SymbExpr t [a])
-> s t a -> s2 t b -> SymbExpr t [a]
forall t (s1 :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) =>
(AltExpr t a -> SymbExpr t [a])
-> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy AltExpr t a -> SymbExpr t [a]
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
some
-- | Same as 'some1' but with an additional separator.
someSepBy1 :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => 
                s t a -> s2 t b -> SymbExpr t [a]
someSepBy1 :: forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
someSepBy1 = (AltExpr t a -> SymbExpr t [a])
-> s t a -> s2 t b -> SymbExpr t [a]
forall t (s1 :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) =>
(AltExpr t a -> SymbExpr t [a])
-> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy1 AltExpr t a -> SymbExpr t [a]
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
some
-- | Same as 'multiple' but with an additional separator.
multipleSepBy :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => 
                    s t a -> s2 t b -> SymbExpr t [a]
multipleSepBy :: forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
multipleSepBy = (AltExpr t a -> SymbExpr t [a])
-> s t a -> s2 t b -> SymbExpr t [a]
forall t (s1 :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) =>
(AltExpr t a -> SymbExpr t [a])
-> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy AltExpr t a -> SymbExpr t [a]
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
multiple 
-- | Same as 'multiple1' but with an additional separator.
multipleSepBy1 :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => 
                    s t a -> s2 t b -> SymbExpr t [a]
multipleSepBy1 :: forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
multipleSepBy1 = (AltExpr t a -> SymbExpr t [a])
-> s t a -> s2 t b -> SymbExpr t [a]
forall t (s1 :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) =>
(AltExpr t a -> SymbExpr t [a])
-> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy1 AltExpr t a -> SymbExpr t [a]
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t [a]
multiple 

sepBy :: (Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) => 
           (AltExpr t a -> SymbExpr t [a]) -> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy :: forall t (s1 :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) =>
(AltExpr t a -> SymbExpr t [a])
-> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy AltExpr t a -> SymbExpr t [a]
mult s1 t a
p s2 t b
c = OO [] AltExpr t [a] -> SymbExpr t [a]
forall t b. (Show t, Ord t) => OO [] AltExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (OO [] AltExpr t [a] -> SymbExpr t [a])
-> OO [] AltExpr t [a] -> SymbExpr t [a]
forall a b. (a -> b) -> a -> b
$ [a] -> AltExpr t [a]
forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy [] AltExpr t [a] -> AltExpr t [a] -> OO [] AltExpr t [a]
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||> (:) (a -> [a] -> [a]) -> s1 t a -> AltExpr t ([a] -> [a])
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s1 t a
p AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> AltExpr t a -> SymbExpr t [a]
mult (s2 t b
c s2 t b -> s1 t a -> AltExpr t a
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t b
**> s1 t a
p)

sepBy1 :: (Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) => 
           (AltExpr t a -> SymbExpr t [a]) -> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy1 :: forall t (s1 :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) =>
(AltExpr t a -> SymbExpr t [a])
-> s1 t a -> s2 t b -> SymbExpr t [a]
sepBy1 AltExpr t a -> SymbExpr t [a]
mult s1 t a
p s2 t b
c = AltExpr t [a] -> SymbExpr t [a]
forall t b. (Show t, Ord t) => AltExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (AltExpr t [a] -> SymbExpr t [a])
-> AltExpr t [a] -> SymbExpr t [a]
forall a b. (a -> b) -> a -> b
$ (:) (a -> [a] -> [a]) -> s1 t a -> AltExpr t ([a] -> [a])
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s1 t a
p AltExpr t ([a] -> [a]) -> SymbExpr t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> AltExpr t a -> SymbExpr t [a]
mult (s2 t b
c s2 t b -> s1 t a -> AltExpr t a
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t b
**> s1 t a
p)

-- | Like 'multipleSepBy1' but matching at least two occurrences of the 
-- first argument. The returned list is therefore always of at least
-- length 2. At least one separator will be consumed.
multipleSepBy2 :: s t a -> s2 t b -> BNF t [a]
multipleSepBy2 s t a
p s2 t b
s = AltExpr t [a] -> BNF t [a]
forall t b. (Show t, Ord t) => AltExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (AltExpr t [a] -> BNF t [a]) -> AltExpr t [a] -> BNF t [a]
forall a b. (a -> b) -> a -> b
$
  (:) (a -> [a] -> [a]) -> s t a -> AltExpr t ([a] -> [a])
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p AltExpr t ([a] -> [a]) -> s2 t b -> AltExpr t ([a] -> [a])
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t a
<** s2 t b
s AltExpr t ([a] -> [a]) -> BNF t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> s t a -> s2 t b -> BNF t [a]
forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
multipleSepBy1 s t a
p s2 t b
s

-- | Like 'multipleSepBy2' but matching the minimum number of 
-- occurrences of the first argument as possible (at least 2).
someSepBy2 :: s t a -> s2 t b -> BNF t [a]
someSepBy2 s t a
p s2 t b
s = AltExpr t [a] -> BNF t [a]
forall t b. (Show t, Ord t) => AltExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (AltExpr t [a] -> BNF t [a]) -> AltExpr t [a] -> BNF t [a]
forall a b. (a -> b) -> a -> b
$
  (:) (a -> [a] -> [a]) -> s t a -> AltExpr t ([a] -> [a])
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p AltExpr t ([a] -> [a]) -> s2 t b -> AltExpr t ([a] -> [a])
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t a
<** s2 t b
s AltExpr t ([a] -> [a]) -> BNF t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> s t a -> s2 t b -> BNF t [a]
forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
someSepBy1 s t a
p s2 t b
s

-- | Like 'multipleSepBy2' but matching the maximum number of
-- occurrences of the first argument as possible (at least 2).
manySepBy2 :: s t a -> s2 t b -> BNF t [a]
manySepBy2 s t a
p s2 t b
s = AltExpr t [a] -> BNF t [a]
forall t b. (Show t, Ord t) => AltExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (AltExpr t [a] -> BNF t [a]) -> AltExpr t [a] -> BNF t [a]
forall a b. (a -> b) -> a -> b
$ 
  (:) (a -> [a] -> [a]) -> s t a -> AltExpr t ([a] -> [a])
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p AltExpr t ([a] -> [a]) -> s2 t b -> AltExpr t ([a] -> [a])
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t a
<** s2 t b
s AltExpr t ([a] -> [a]) -> BNF t [a] -> AltExpr t [a]
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> s t a -> s2 t b -> BNF t [a]
forall t (s :: * -> * -> *) (s2 :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) =>
s t a -> s2 t b -> SymbExpr t [a]
manySepBy1 s t a
p s2 t b
s

-- | Derive either from the given symbol or the empty string.
optional :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a)
optional :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t (Maybe a)
optional s t a
p = String
fresh 
  String -> OO [] AltExpr t (Maybe a) -> SymbExpr t (Maybe a)
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<:=>  a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> s t a -> AltExpr t (Maybe a)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p 
  AltExpr t (Maybe a)
-> AltExpr t (Maybe a) -> OO [] AltExpr t (Maybe a)
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||>  Maybe a -> AltExpr t (Maybe a)
forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy Maybe a
forall a. Maybe a
Nothing 
  where fresh :: String
fresh = s t a -> String -> String
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t a
p String
"?"

-- | Version of 'optional' that prefers to derive from the given symbol,
-- affects only nullable nonterminal symbols
preferably :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a)
preferably :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t (Maybe a)
preferably s t a
p = String
fresh 
  String -> OO [] AltExpr t (Maybe a) -> SymbExpr t (Maybe a)
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<:=   a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> s t a -> AltExpr t (Maybe a)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p 
  AltExpr t (Maybe a)
-> AltExpr t (Maybe a) -> OO [] AltExpr t (Maybe a)
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||>  Maybe a -> AltExpr t (Maybe a)
forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy Maybe a
forall a. Maybe a
Nothing 
  where fresh :: String
fresh = s t a -> String -> String
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t a
p String
"?"

-- | Version of 'optional' that prefers to derive the empty string from 
-- the given symbol, affects only nullable nonterminal symbols
reluctantly :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a)
reluctantly :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> SymbExpr t (Maybe a)
reluctantly s t a
p = String
fresh 
  String -> OO [] AltExpr t (Maybe a) -> SymbExpr t (Maybe a)
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<:=   Maybe a -> AltExpr t (Maybe a)
forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy Maybe a
forall a. Maybe a
Nothing  
  AltExpr t (Maybe a)
-> AltExpr t (Maybe a) -> OO [] AltExpr t (Maybe a)
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||>  a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> s t a -> AltExpr t (Maybe a)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p
  where fresh :: String
fresh = s t a -> String -> String
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t a
p String
"?"

optionalWithDef :: (Show t, Ord t, IsSymbExpr s) => s t a -> a -> SymbExpr t a 
optionalWithDef :: forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> a -> SymbExpr t a
optionalWithDef s t a
p a
def = s t a -> String -> String
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t a
p String
"?" String -> OO [] AltExpr t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<:=> a -> a
forall a. a -> a
id (a -> a) -> s t a -> AltExpr t a
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t a
p AltExpr t a -> AltExpr t a -> OO [] AltExpr t a
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||> a -> AltExpr t a
forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy a
def

-- | Place a piece of BNF /within/ two other BNF fragments, ignoring their semantics.
within :: (Show t, Ord t, IsSymbExpr s) => BNF t a -> s t b -> BNF t c -> BNF t b
within :: forall t (s :: * -> * -> *) a b c.
(Show t, Ord t, IsSymbExpr s) =>
BNF t a -> s t b -> BNF t c -> BNF t b
within BNF t a
l s t b
p BNF t c
r = AltExpr t b -> BNF t b
forall t b. (Show t, Ord t) => AltExpr t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
mkRule (AltExpr t b -> BNF t b) -> AltExpr t b -> BNF t b
forall a b. (a -> b) -> a -> b
$ BNF t a
l BNF t a -> BNF t b -> AltExpr t b
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t b
**> s t b -> BNF t b
forall t b. (Show t, Ord t) => s t b -> SymbExpr t b
forall (a :: * -> * -> *) t b.
(IsSymbExpr a, Show t, Ord t) =>
a t b -> SymbExpr t b
toSymb s t b
p AltExpr t b -> BNF t c -> AltExpr t b
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t a
<** BNF t c
r

-- | Place a piece of BNF between the characters '(' and ')'.
parens :: s t b -> BNF t b
parens s t b
p = BNF t Char -> s t b -> BNF t Char -> BNF t b
forall t (s :: * -> * -> *) a b c.
(Show t, Ord t, IsSymbExpr s) =>
BNF t a -> s t b -> BNF t c -> BNF t b
within (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'(') s t b
p (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
')')
-- | Place a piece of BNF between the characters '{' and '}'.
braces :: s t b -> BNF t b
braces s t b
p = BNF t Char -> s t b -> BNF t Char -> BNF t b
forall t (s :: * -> * -> *) a b c.
(Show t, Ord t, IsSymbExpr s) =>
BNF t a -> s t b -> BNF t c -> BNF t b
within (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'{') s t b
p (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'}')
-- | Place a piece of BNF between the characters '[' and ']'.
brackets :: s t b -> BNF t b
brackets s t b
p = BNF t Char -> s t b -> BNF t Char -> BNF t b
forall t (s :: * -> * -> *) a b c.
(Show t, Ord t, IsSymbExpr s) =>
BNF t a -> s t b -> BNF t c -> BNF t b
within (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'[') s t b
p (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
']')
-- | Place a piece of BNF between the characters '<' and '>'.
angles :: s t b -> BNF t b
angles s t b
p = BNF t Char -> s t b -> BNF t Char -> BNF t b
forall t (s :: * -> * -> *) a b c.
(Show t, Ord t, IsSymbExpr s) =>
BNF t a -> s t b -> BNF t c -> BNF t b
within (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'<') s t b
p (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'>')
-- | Place a piece of BNF between two single quotes.
quotes :: s t b -> BNF t b
quotes s t b
p = BNF t Char -> s t b -> BNF t Char -> BNF t b
forall t (s :: * -> * -> *) a b c.
(Show t, Ord t, IsSymbExpr s) =>
BNF t a -> s t b -> BNF t c -> BNF t b
within (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'\'') s t b
p (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'\'')
-- | Place a piece of BNF between two double quotes.
dquotes :: s t b -> BNF t b
dquotes s t b
p = BNF t Char -> s t b -> BNF t Char -> BNF t b
forall t (s :: * -> * -> *) a b c.
(Show t, Ord t, IsSymbExpr s) =>
BNF t a -> s t b -> BNF t c -> BNF t b
within (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'"') s t b
p (Char -> BNF t Char
forall t. SubsumesToken t => Char -> SymbExpr t Char
keychar Char
'"')

foldr_multiple :: (IsSymbExpr s, Parseable t) => s t (a -> a) -> a -> BNF t a 
foldr_multiple :: forall (s :: * -> * -> *) t a.
(IsSymbExpr s, Parseable t) =>
s t (a -> a) -> a -> BNF t a
foldr_multiple s t (a -> a)
comb a
def = s t (a -> a) -> String -> String
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t (a -> a)
comb String
"-foldr" 
  String -> OO [] AltExpr t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<::=> a -> AltExpr t a
forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy a
def 
  AltExpr t a -> AltExpr t a -> OO [] AltExpr t a
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||> (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
($)      ((a -> a) -> a -> a) -> s t (a -> a) -> AltExpr t (a -> a)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t (a -> a)
comb AltExpr t (a -> a) -> SymbExpr t a -> AltExpr t a
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<<<**> s t (a -> a) -> a -> SymbExpr t a
forall (s :: * -> * -> *) t a.
(IsSymbExpr s, Parseable t) =>
s t (a -> a) -> a -> BNF t a
foldr_multiple s t (a -> a)
comb a
def

foldr_multipleSepBy :: (IsSymbExpr s, Parseable t) => s t (a -> a) -> s t b -> a -> BNF t a 
foldr_multipleSepBy :: forall (s :: * -> * -> *) t a b.
(IsSymbExpr s, Parseable t) =>
s t (a -> a) -> s t b -> a -> BNF t a
foldr_multipleSepBy s t (a -> a)
comb s t b
sep a
def = s t (a -> a) -> String -> String
forall t (s :: * -> * -> *) a.
(Show t, Ord t, IsSymbExpr s) =>
s t a -> String -> String
mkNt s t (a -> a)
comb String
"-foldr" 
  String -> OO [] AltExpr t a -> SymbExpr t a
forall t (b :: * -> * -> *) a.
(Show t, Ord t, HasAlts b) =>
String -> b t a -> SymbExpr t a
<::=> a -> AltExpr t a
forall t a. (Show t, Ord t) => a -> AltExpr t a
satisfy a
def 
  AltExpr t a -> OO [] AltExpr t a -> OO [] AltExpr t a
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||>  ((a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
def) ((a -> a) -> a) -> s t (a -> a) -> AltExpr t a
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t (a -> a)
comb
  AltExpr t a -> AltExpr t a -> OO [] AltExpr t a
forall t (i :: * -> * -> *) (b :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr i, HasAlts b) =>
i t a -> b t a -> AltExprs t a
<||> (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
($)      ((a -> a) -> a -> a) -> s t (a -> a) -> AltExpr t (a -> a)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t (a -> a)
comb AltExpr t (a -> a) -> s t b -> AltExpr t (a -> a)
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t a -> s t b -> AltExpr t a
<** s t b
sep AltExpr t (a -> a) -> SymbExpr t a -> AltExpr t a
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<<<**> s t (a -> a) -> s t b -> a -> SymbExpr t a
forall (s :: * -> * -> *) t a b.
(IsSymbExpr s, Parseable t) =>
s t (a -> a) -> s t b -> a -> BNF t a
foldr_multipleSepBy s t (a -> a)
comb s t b
sep a
def

-- | A table mapping operator keywords to a 'Fixity' and 'Assoc'
-- It provides a convenient way to build an expression grammar (see 'fromOpTable'). 
type OpTable e  = M.Map Double [(String, Fixity e)] 
data Fixity e   = Prefix (String -> e -> e) | Infix (e -> String -> e -> e) Assoc
data Assoc      = LAssoc | RAssoc | NA

opTableFromList :: [(Double, [(String, Fixity e)])] -> OpTable e 
opTableFromList :: forall e. [(Double, [(String, Fixity e)])] -> OpTable e
opTableFromList = [(Double, [(String, Fixity e)])] -> Map Double [(String, Fixity e)]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList

fromOpTable :: (SubsumesToken t, Parseable t, IsSymbExpr s) => String -> OpTable e -> s t e -> BNF t e 
fromOpTable :: forall t (s :: * -> * -> *) e.
(SubsumesToken t, Parseable t, IsSymbExpr s) =>
String -> OpTable e -> s t e -> BNF t e
fromOpTable String
nt OpTable e
ops s t e
rec = String -> [SymbExpr t e] -> SymbExpr t e
forall t (alt :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr alt) =>
String -> [alt t a] -> SymbExpr t a
chooses_prec (String
nt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-infix-prefix-exprs") ([SymbExpr t e] -> SymbExpr t e) -> [SymbExpr t e] -> SymbExpr t e
forall a b. (a -> b) -> a -> b
$
  [ Integer -> [(String, Fixity e)] -> SymbExpr t e
forall {a}. Show a => a -> [(String, Fixity e)] -> SymbExpr t e
mkNterm Integer
ix [(String, Fixity e)]
row
  | (Integer
ix, [(String, Fixity e)]
row) <- [Integer]
-> [[(String, Fixity e)]] -> [(Integer, [(String, Fixity e)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] (OpTable e -> [[(String, Fixity e)]]
forall k a. Map k a -> [a]
M.elems OpTable e
ops)
  ]
  where mkNterm :: a -> [(String, Fixity e)] -> SymbExpr t e
mkNterm a
ix [(String, Fixity e)]
ops = String -> [AltExpr t e] -> SymbExpr t e
forall t (alt :: * -> * -> *) a.
(Show t, Ord t, IsAltExpr alt) =>
String -> [alt t a] -> SymbExpr t a
chooses (a -> String
forall a. Show a => a -> String
ntName a
ix) ([AltExpr t e] -> SymbExpr t e) -> [AltExpr t e] -> SymbExpr t e
forall a b. (a -> b) -> a -> b
$ 
          [ String -> Fixity e -> AltExpr t e
mkAlt String
op Fixity e
fix | (String
op, Fixity e
fix) <- [(String, Fixity e)]
ops ]
          where mkAlt :: String -> Fixity e -> AltExpr t e
mkAlt String
op Fixity e
fix = case Fixity e
fix of
                  Prefix String -> e -> e
f -> String -> e -> e
f (String -> e -> e) -> SymbExpr t String -> AltExpr t (e -> e)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> String -> SymbExpr t String
forall t. SubsumesToken t => String -> SymbExpr t String
keyword String
op AltExpr t (e -> e) -> s t e -> AltExpr t e
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> s t e
rec 
                  Infix e -> String -> e -> e
f Assoc
assoc -> case Assoc
assoc of 
                    Assoc
LAssoc -> e -> String -> e -> e
f (e -> String -> e -> e) -> s t e -> AltExpr t (String -> e -> e)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t e
rec AltExpr t (String -> e -> e)
-> SymbExpr t String -> AltExpr t (e -> e)
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> String -> SymbExpr t String
forall t. SubsumesToken t => String -> SymbExpr t String
keyword String
op AltExpr t (e -> e) -> s t e -> AltExpr t e
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**>>> s t e
rec
                    Assoc
RAssoc -> e -> String -> e -> e
f (e -> String -> e -> e) -> s t e -> AltExpr t (String -> e -> e)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t e
rec AltExpr t (String -> e -> e)
-> SymbExpr t String -> AltExpr t (e -> e)
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> String -> SymbExpr t String
forall t. SubsumesToken t => String -> SymbExpr t String
keyword String
op AltExpr t (e -> e) -> s t e -> AltExpr t e
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<<<**> s t e
rec
                    Assoc
_      -> e -> String -> e -> e
f (e -> String -> e -> e) -> s t e -> AltExpr t (String -> e -> e)
forall t (s :: * -> * -> *) a b.
(Show t, Ord t, IsSymbExpr s) =>
(a -> b) -> s t a -> AltExpr t b
<$$> s t e
rec AltExpr t (String -> e -> e)
-> SymbExpr t String -> AltExpr t (e -> e)
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> String -> SymbExpr t String
forall t. SubsumesToken t => String -> SymbExpr t String
keyword String
op AltExpr t (e -> e) -> s t e -> AltExpr t e
forall t (i :: * -> * -> *) (s :: * -> * -> *) a b.
(Show t, Ord t, IsAltExpr i, IsSymbExpr s) =>
i t (a -> b) -> s t a -> AltExpr t b
<**> s t e
rec
                
        ntName :: a -> String
ntName a
i = a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-op-row"