{-|
Implementation of the GLL parsing algorithm [Scott and Johnstone 2010,2013,2016]
with the grammar as an explicit parameter.

Function 'parse' receives a 'Grammar' as input together with a 
list of tokens (the input string).

The type of token is chosen arbitrarily, but the type should be 'Parseable' and 'Ord'erable.
To be 'Parseable' a type must have two distinct values, 'eos' (end-of-string)
and 'eps' (epsilon). The user must ensure that these two values will never occur
as part of the input string.

== GLL Parsing
=== Recursive Descent
GLL parsing is a generalisation of recursive descent parsing (RD parsing).
A RD parser (RDP), for some grammar 'G' , consists of a set of parse 
functions 'f_X', one for every nonterminal 'X', and a main function which 
calls 'f_S', where 'S' is the start symbol. 
The parse function 'f_X' take an integer 'l' as an argument and produces an 
integer 'r', indicating that nonterminal 'X' derives 's_l_r', 
where 's_i_j' is the substring of the input string 's' ranging from
'i' to 'j'. We call 'l' and 'r' the right- and left-extent, respectively.

The parse function 'f_X'
has a branch for every production X ::= s_1 ... s_k in 'G', guarded
by a look-ahead test, and every
branch has 'k' code fragments, one for every symbol 's_i', 
with 1 <= i <= k.
A RDP matches grammar positions, represented by /slots/ of the form
X ::= a . b,  with (input) string positions.
The dot in a slot tells us how much of the production's symbols have been 
matched (the symbols before the dot) and which symbols still need to 
be matched (the symbols after the dot). The symbol immediately after the dot
is the next symbol to be match and is either:

* A terminal token, matched directly with the token at the current
        string position.
* A nonterminal 'Y', for which 'f_Y' is called. In the case of
        LL(1) deterministic parsing, only one (or none) of the productions
        of 'Y' passes the lookahead-test, say "Y ::= c", and its branch 
        will be executed: the next grammar position is "Y ::= .c".
* No further symbol, represented by "X ::= d."  (all 
        symbols have been processed). In this case a return call is made
        to the caller of 'f_X' (relying on a function call stack).

=== Handling function/return calls
GLL handles its own function calls and return calls, instead of relying on an 
underlying mechanism. This form of low-level control allows
GLL to avoid much duplicate work, not only for function calls (as in classical
memoisation) but also for return calls. The underlying observation is that
both return calls and function calls continue matching grammar slots. 
In non-deterministic RDP, every function call leads to a slot of the
form "X ::= . a" being processed, while every return call 
leads to a slot of the form "X ::= aY.b" being processed,
where 'Y' is some nonterminal. GLL uses /descriptors/, containing
a slot of one of these forms, to uniquely identify the computation that
processes the slot. The descriptor therefore also needs to contain
the initial values of the local variables used in that computation. 

A generated GLL parser (Scott and Johnstone 2013) has a code fragment for 
every nonterminal 'X' (labelled 'L_X') and slot (labelled "L_{X ::= a.b}"). 
This Haskell implementation abstracts over the grammar and has a function for
executing 'L_X', for a given 'X', and a function for executing 
"L_{X ::= a.b}", for a given "X ::= a.b".

=== Generalisation
GLL parsing generalises RD parsing by allowing non-determinism:
when processing "X ::= a.Yb", all productions of 'Y', that pass 
the lookahead test, are considered. A slot is considered, by adding a 
descriptor for it to the /worklist/ 'R'. 
Duplicates in the worklist are avoided by maintaining a separate descriptor-set
'U' containing all descriptors added to the worklist before.

The result of a parse function 'f_X' is no longer a single right extent 'r'.
Instead, it is a list of right extents 'rs', indicating that 'X' derives
's_l_r' for all 'r' in 'rs' and integer input 'l' (left extent).
Every discovered right extent is stored in the /pop-set/ 'P'.

When a descriptors for a function call is a duplicate, it is not added to the
worklist, but we have to make sure that the corresponding
return call is still made. Note that a function call to 'f_Y', with 
the same parameters, can be made from multiple right-hand side occurrences
of 'Y'. It might be the case that:

* The original descriptors is still being processed. 
    Once finished, a descriptor must be added for all return calls 
    corresponding to function calls that lead to duplicates of 
    this descriptor. 
    GLL uses a Graph-Structured Stack (GSS) to efficiently maintain multiple 
    such continuations.
* The original descriptors has already been processed. In this
    case, one or more right extents 'rs' are stored in 'P' for the 
    corresponding function call. A descriptor for the return call must be 
    added for all 'r' in 'rs'. The descriptor for the return call must 
    be added to the GSS in this case as well, as other right extents might 
    be found in the future.
 

== Usage
This module provides generalised parsing to other applications that work with 
BNF grammars. 

The user should provide a 'Grammar' and an input string as arguments
to top-level functions 'parse' or 'parseWithOptions'.

=== Example
This example shows simple character level parsing.
First we must make 'Char' and instance of 'Parseable'.

@
instance Parseable Char where
    eos = \'$\'
    eps = '#'
@

This instance mandates that \'$\' and '#' are 'reserved tokens' 
and not part of the input string. This instance is available as an import: 
"GLL.Parseable.Char".

"GLL.Parser" exports smart constructors for constructing 'Grammar's.

@
grammar1 = (start \"X\" , [prod \"X\" [nterm \"A\", nterm \"A\"]
                      , prod \"A\" [term \'a\']
                      , prod \"A\" [term \'a\', term \'a\']
                 ] )

fail1       = "a"
success1    = "aa"
success2    = "aaa"
fail2       = "aaaaa"
@
Note that there are two possible derivations of 'success2'.

The parser can be accessed through 'parse' or 'parseWithOptions'.

@
run1 = parse grammar1 success1
run2 = parseWithOptions [fullSPPF, strictBinarisation] grammar1 success2
@   

The options 'fullSPPF', 'allNodes', 'packedNodesOnly', decide whether all SPPF nodes and 
edges are inserted into the resulting value of the 'SPPF' type.
Packed nodes are enough to fully represent an SPPF, as the parent and children
of a packed node can be computed from the packed nodes' information.
For efficiency the 'SPPF' is not strictly binarised by default: a packed
node might have a symbol node as a left child. In a strictly binarised 'SPPF'
a packed node has an intermediate node as a left child, or no left child at all.
To create a strictly binarised 'SPPF' (necessary for "GLL.Combinators") the option
'strictBinarisation' is available.

=== Combinator interface
Module "GLL.Combinators.Interface" provides a combinator interface to access
"GLL.Parser". Applicative-like combinators are used to specify a 'Grammar' and
call 'parse'. The 'SPPF' is then used to produce semantic results.

-}
module GLL.Parser (
        -- * Grammar
        Grammar(..), Prods(..), Prod(..), Symbols(..), Symbol(..), Slot(..), 
        -- ** Smart constructors for creating 'Grammar's
        start, prod, nterm, term,
        -- ** Parseable tokens 
        Parseable(..), Input, mkInput,
        -- * Run the GLL parser
        parse, parseArray,
        -- ** Run the GLL parser with options
        parseWithOptions, parseWithOptionsArray,
        -- *** ParseOptions
        ParseOptions, ParseOption, 
        strictBinarisation, fullSPPF, allNodes, packedNodesOnly, maximumErrors,
          noSelectTest,
        -- ** Result
        ParseResult(..), SPPF(..), SPPFNode(..), SymbMap, ImdMap, PackMap, EdgeMap, showSPPF,
    ) where

import Data.Foldable hiding (forM_, toList, sum)
import Prelude  hiding (lookup, foldr, fmap, foldl, elem, any, concatMap)
import Control.Applicative 
import Control.Monad
import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Array as A
import qualified Data.Set as S
import qualified Data.IntSet as IS
import Data.Text (pack)
import Text.PrettyPrint.HughesPJ as PP

import GLL.Types.Grammar
import GLL.Types.Derivations
import GLL.Flags

-- | Create an 'Nt' (nonterminal) from a String.
string2nt :: String -> Nt
string2nt :: String -> Nt
string2nt = String -> Nt
pack

-- | A smart constructor for creating a start 'Nt' (nonterminal).
start :: String -> Nt
start :: String -> Nt
start = String -> Nt
string2nt

-- | A smart constructor for creating a 'Prod' (production).
prod :: String -> Symbols t -> Prod t
prod :: forall t. String -> Symbols t -> Prod t
prod String
x = forall t. Nt -> Symbols t -> Prod t
Prod (String -> Nt
string2nt String
x)

-- | A smart constructor for creating a nonterminal 'Symbol'.
nterm :: String -> Symbol t
nterm :: forall t. String -> Symbol t
nterm = forall t. Nt -> Symbol t
Nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Nt
string2nt

-- | A smart constructor for creating a terminal 'Symbol'.
term :: t -> Symbol t
term :: forall t. t -> Symbol t
term = forall t. t -> Symbol t
Term

-- | Representation of the input string
type Input t        =   A.Array Int t 
mkInput :: (Parseable t) => [t] -> Input t
mkInput :: forall t. Parseable t => [t] -> Input t
mkInput [t]
input = forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0,Int
m) ([t]
inputforall a. [a] -> [a] -> [a]
++[forall a. Parseable a => a
eos])
  where m :: Int
m = forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
input

-- | Types for 
type LhsParams t    =   (Nt, Int)
type RhsParams t    =   (Slot t, Int, Int)

-- | The worklist and descriptor set
type Rcal t         =   [(RhsParams t, SPPFNode t)]
type Ucal t         =   IM.IntMap (IM.IntMap (S.Set (Slot t)))

-- | GSS representation
type GSS t          =   IM.IntMap (M.Map Nt [GSSEdge t])
type GSSEdge t      =   (Slot t, Int, SPPFNode t) -- return position, left extent
type GSSNode t      =   (Nt, Int)

type MisMatches t   =   IM.IntMap (S.Set t)

-- | Pop-set
type Pcal t         =   IM.IntMap (M.Map Nt [Int])

-- | Connecting it all
data Mutable t      =   Mutable { forall t. Mutable t -> SPPF t
mut_sppf          :: SPPF t
                                , forall t. Mutable t -> Rcal t
mut_worklist      :: Rcal t
                                , forall t. Mutable t -> Ucal t
mut_descriptors   :: Ucal t
                                , forall t. Mutable t -> GSS t
mut_gss           :: GSS t
                                , forall t. Mutable t -> Pcal t
mut_popset        :: Pcal t 
                                , forall t. Mutable t -> MisMatches t
mut_mismatches    :: MisMatches t 
                                , forall t. Mutable t -> Counters
mut_counters      :: Counters
                                }

data Counters = Counters  { Counters -> Int
count_successes :: Int
                          , Counters -> Int
count_pnodes    :: Int 
                          }

-- | Monad for implicitly passing around 'context'
data GLL t a        =   GLL (Flags -> Mutable t -> (a, Mutable t))

runGLL :: GLL t a -> Flags -> Mutable t -> Mutable t
runGLL :: forall t a. GLL t a -> Flags -> Mutable t -> Mutable t
runGLL (GLL Flags -> Mutable t -> (a, Mutable t)
f) Flags
o Mutable t
p = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Flags -> Mutable t -> (a, Mutable t)
f Flags
o Mutable t
p

addSPPFEdge :: SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
f SPPFNode t
t = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
flags Mutable t
mut -> 
    let sppf' :: SPPF t
sppf' = (if Flags -> Bool
symbol_nodes Flags
flags          then forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
sNodeInsert SPPFNode t
f SPPFNode t
t else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
                (if Flags -> Bool
intermediate_nodes Flags
flags    then forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
iNodeInsert SPPFNode t
f SPPFNode t
t else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
                (if Flags -> Bool
edges Flags
flags                 then forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
eMapInsert SPPFNode t
f SPPFNode t
t  else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ 
                    forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
pMapInsert SPPFNode t
f SPPFNode t
t (forall t. Mutable t -> SPPF t
mut_sppf Mutable t
mut)
    in ((),Mutable t
mut{mut_sppf :: SPPF t
mut_sppf = SPPF t
sppf'})

addDescr :: SPPFNode t -> (Slot t, Int, Int) -> GLL t ()
addDescr SPPFNode t
sppf alt :: (Slot t, Int, Int)
alt@(Slot t
slot,Int
i,Int
l) = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut -> 
    let new :: Bool
new     = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True IntMap (Set (Slot t)) -> Bool
inner forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i (forall t. Mutable t -> Ucal t
mut_descriptors Mutable t
mut)
          where inner :: IntMap (Set (Slot t)) -> Bool
inner IntMap (Set (Slot t))
m = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slot t
slot forall a. Ord a => a -> Set a -> Bool
`S.member`)) forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l IntMap (Set (Slot t))
m
        newU :: IntMap (IntMap (Set (Slot t)))
newU = forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap (Set (Slot t))) -> Maybe (IntMap (Set (Slot t)))
inner Int
i (forall t. Mutable t -> Ucal t
mut_descriptors Mutable t
mut)
         where inner :: Maybe (IntMap (Set (Slot t))) -> Maybe (IntMap (Set (Slot t)))
inner Maybe (IntMap (Set (Slot t)))
mm = case Maybe (IntMap (Set (Slot t)))
mm of 
                             Maybe (IntMap (Set (Slot t)))
Nothing -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> IntMap a
IM.singleton Int
l Set (Slot t)
single 
                             Just IntMap (Set (Slot t))
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith (forall a. Ord a => Set a -> Set a -> Set a
S.union) Int
l Set (Slot t)
single IntMap (Set (Slot t))
m
               single :: Set (Slot t)
single = forall a. a -> Set a
S.singleton Slot t
slot
     in if Bool
new then ((), Mutable t
mut{mut_worklist :: Rcal t
mut_worklist       = ((Slot t, Int, Int)
alt,SPPFNode t
sppf)forall a. a -> [a] -> [a]
:(forall t. Mutable t -> Rcal t
mut_worklist Mutable t
mut)
                            ,mut_descriptors :: IntMap (IntMap (Set (Slot t)))
mut_descriptors    = IntMap (IntMap (Set (Slot t)))
newU})
               else ((), Mutable t
mut)

getDescr :: GLL t (Maybe (RhsParams t, SPPFNode t))
getDescr = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut -> 
    case forall t. Mutable t -> Rcal t
mut_worklist Mutable t
mut of 
        []                      -> (forall a. Maybe a
Nothing, Mutable t
mut)
        (next :: (RhsParams t, SPPFNode t)
next@(RhsParams t
alt,SPPFNode t
sppf):[(RhsParams t, SPPFNode t)]
rest)  -> (forall a. a -> Maybe a
Just (RhsParams t, SPPFNode t)
next, Mutable t
mut{mut_worklist :: [(RhsParams t, SPPFNode t)]
mut_worklist = [(RhsParams t, SPPFNode t)]
rest})

addPop :: (Nt, Int) -> Int -> GLL t ()
addPop (Nt
gs,Int
l) Int
i = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut ->
    let newP :: Pcal t
newP = forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (Map Nt [Int]) -> Maybe (Map Nt [Int])
inner Int
l (forall t. Mutable t -> Pcal t
mut_popset Mutable t
mut)
         where inner :: Maybe (Map Nt [Int]) -> Maybe (Map Nt [Int])
inner Maybe (Map Nt [Int])
mm = case Maybe (Map Nt [Int])
mm of 
                            Maybe (Map Nt [Int])
Nothing -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton Nt
gs [Int
i]
                            Just Map Nt [Int]
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. [a] -> [a] -> [a]
(++) Nt
gs [Int
i] Map Nt [Int]
m
    in ((), Mutable t
mut{mut_popset :: Pcal t
mut_popset = Pcal t
newP})

getChildren :: (Nt, Int) -> GLL t [GSSEdge t]
getChildren (Nt
gs,Int
l) = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut ->
    let res :: [GSSEdge t]
res = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall {a}. Map Nt [a] -> [a]
inner forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l (forall t. Mutable t -> GSS t
mut_gss Mutable t
mut)
         where inner :: Map Nt [a] -> [a]
inner Map Nt [a]
m = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Nt
gs Map Nt [a]
m
     in ([GSSEdge t]
res, Mutable t
mut)

addGSSEdge :: (Nt, Int) -> GSSEdge t -> GLL t ()
addGSSEdge f :: (Nt, Int)
f@(Nt
gs,Int
i) GSSEdge t
t = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut -> 
    let newGSS :: IntMap (Map Nt [GSSEdge t])
newGSS = forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (Map Nt [GSSEdge t]) -> Maybe (Map Nt [GSSEdge t])
inner Int
i (forall t. Mutable t -> GSS t
mut_gss Mutable t
mut)
         where inner :: Maybe (Map Nt [GSSEdge t]) -> Maybe (Map Nt [GSSEdge t])
inner Maybe (Map Nt [GSSEdge t])
mm = case Maybe (Map Nt [GSSEdge t])
mm of 
                            Maybe (Map Nt [GSSEdge t])
Nothing -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
M.singleton Nt
gs [GSSEdge t
t] 
                            Just Map Nt [GSSEdge t]
m  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. [a] -> [a] -> [a]
(++) Nt
gs [GSSEdge t
t] Map Nt [GSSEdge t]
m
    in ((), Mutable t
mut{mut_gss :: IntMap (Map Nt [GSSEdge t])
mut_gss = IntMap (Map Nt [GSSEdge t])
newGSS})

getPops :: (Nt, Int) -> GLL t [Int]
getPops (Nt
gs,Int
l) = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut -> 
    let res :: [Int]
res = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall {a}. Map Nt [a] -> [a]
inner forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l (forall t. Mutable t -> Pcal t
mut_popset Mutable t
mut)
         where inner :: Map Nt [a] -> [a]
inner = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Nt
gs
    in ([Int]
res, Mutable t
mut)

addSuccess :: GLL t ()
addSuccess = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut -> 
  let mut' :: Mutable t
mut' = Mutable t
mut { mut_counters :: Counters
mut_counters = Counters
counters { count_successes :: Int
count_successes = Int
1 forall a. Num a => a -> a -> a
+ Counters -> Int
count_successes Counters
counters } }
      counters :: Counters
counters = forall t. Mutable t -> Counters
mut_counters Mutable t
mut
  in ((),Mutable t
mut')

getFlags :: GLL t Flags
getFlags = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
fs Mutable t
ctx -> (Flags
fs, Mutable t
ctx)

addMisMatch :: (Ord t) => Int -> S.Set t -> GLL t ()
addMisMatch :: forall t. Ord t => Int -> Set t -> GLL t ()
addMisMatch Int
k Set t
ts = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
flags Mutable t
mut -> 
    let newM :: IntMap (Set t)
newM    = forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith forall a. Ord a => Set a -> Set a -> Set a
S.union Int
k Set t
ts (forall t. Mutable t -> MisMatches t
mut_mismatches Mutable t
mut)
        newM' :: IntMap (Set t)
newM'   | forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. IntMap a -> [Int]
IM.keys IntMap (Set t)
newM) forall a. Ord a => a -> a -> Bool
> Flags -> Int
max_errors Flags
flags = forall a. IntMap a -> IntMap a
IM.deleteMin IntMap (Set t)
newM
                | Bool
otherwise                                = IntMap (Set t)
newM
    in ((), Mutable t
mut{mut_mismatches :: IntMap (Set t)
mut_mismatches = IntMap (Set t)
newM'})

instance (Show t) => Show (SPPFNode t) where
    show :: SPPFNode t -> String
show (SNode (Symbol t
s, Int
l, Int
r))  = String
"(s: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Symbol t
s forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
r forall a. [a] -> [a] -> [a]
++ String
")"
    show (INode (Slot t
s, Int
l, Int
r))  = String
"(i: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Slot t
s forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
r forall a. [a] -> [a] -> [a]
++ String
")"
    show (PNode (Slot t
p, Int
l, Int
k, Int
r))  = String
"(p: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Slot t
p forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
r forall a. [a] -> [a] -> [a]
++ String
")"
    show SPPFNode t
Dummy              = String
"$"

instance Applicative (GLL t) where
    <*> :: forall a b. GLL t (a -> b) -> GLL t a -> GLL t b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    pure :: forall a. a -> GLL t a
pure  = forall (m :: * -> *) a. Monad m => a -> m a
return
instance Functor (GLL t) where
    fmap :: forall a b. (a -> b) -> GLL t a -> GLL t b
fmap  = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Monad (GLL t) where
    return :: forall a. a -> GLL t a
return a
a = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
p -> (a
a, Mutable t
p)
    (GLL Flags -> Mutable t -> (a, Mutable t)
m) >>= :: forall a b. GLL t a -> (a -> GLL t b) -> GLL t b
>>= a -> GLL t b
f  = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
o Mutable t
p -> let (a
a, Mutable t
p')  = Flags -> Mutable t -> (a, Mutable t)
m Flags
o Mutable t
p
                                       (GLL Flags -> Mutable t -> (b, Mutable t)
m') = a -> GLL t b
f a
a
                                    in Flags -> Mutable t -> (b, Mutable t)
m' Flags
o Mutable t
p'

-- | 
-- Run the GLL parser given a 'Grammar' 't' and a list of 't's, 
-- where 't' is an arbitrary token-type.
-- All token-types must be 'Parseable'.
parse :: (Parseable t) => Grammar t -> [t] -> ParseResult t
parse :: forall t. Parseable t => Grammar t -> [t] -> ParseResult t
parse = forall t.
Parseable t =>
ParseOptions -> Grammar t -> [t] -> ParseResult t
parseWithOptions [] 

-- | 
-- Run the GLL parser given a 'Grammar' 't' and an 'Array' of 't's, 
-- where 't' is an arbitrary token-type.
-- All token-types must be 'Parseable'.
parseArray :: (Parseable t) => Grammar t -> Input t -> ParseResult t
parseArray :: forall t. Parseable t => Grammar t -> Input t -> ParseResult t
parseArray = forall t.
Parseable t =>
ParseOptions -> Grammar t -> Input t -> ParseResult t
parseWithOptionsArray []

-- | 
-- Variant of 'parseWithOptionsArray' where the input is a list of 'Parseable's rather than an 'Array'
parseWithOptions :: Parseable t => ParseOptions -> Grammar t -> [t] -> ParseResult t
parseWithOptions :: forall t.
Parseable t =>
ParseOptions -> Grammar t -> [t] -> ParseResult t
parseWithOptions ParseOptions
opts Grammar t
gram  = forall t.
Parseable t =>
ParseOptions -> Grammar t -> Input t -> ParseResult t
parseWithOptionsArray ParseOptions
opts Grammar t
gram forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Parseable t => [t] -> Input t
mkInput

-- | 
-- Run the GLL parser given some options, a 'Grammar' 't' and a list of 't's.
--
-- If no options are given a minimal 'SPPF' will be created:
--
--  * only packed nodes are created
--  * the resulting 'SPPF' is not strictly binarised
parseWithOptionsArray :: Parseable t => ParseOptions -> Grammar t -> Input t -> ParseResult t
parseWithOptionsArray :: forall t.
Parseable t =>
ParseOptions -> Grammar t -> Input t -> ParseResult t
parseWithOptionsArray ParseOptions
opts grammar :: Grammar t
grammar@(Nt
start,Prods t
_) Input t
input = 
    let flags :: Flags
flags           = ParseOptions -> Flags
runOptions ParseOptions
opts
        (Mutable t
mutable,SelectMap t
_,FollowMap t
_)   = forall t.
Parseable t =>
Flags
-> Int
-> Bool
-> Grammar t
-> Input t
-> (Mutable t, SelectMap t, FollowMap t)
gll Flags
flags Int
m Bool
False Grammar t
grammar Input t
input
        (Int
_, Int
m)          = forall i e. Array i e -> (i, i)
A.bounds Input t
input 
    in forall t.
Parseable t =>
Input t -> Flags -> Mutable t -> SNode t -> ParseResult t
resultFromMutable Input t
input Flags
flags Mutable t
mutable (forall t. Nt -> Symbol t
Nt Nt
start, Int
0, Int
m)

gll :: Parseable t => Flags -> Int -> Bool -> Grammar t -> Input t -> 
            (Mutable t, SelectMap t, FollowMap t)
gll :: forall t.
Parseable t =>
Flags
-> Int
-> Bool
-> Grammar t
-> Input t
-> (Mutable t, SelectMap t, FollowMap t)
gll Flags
flags Int
m Bool
debug (Nt
start, Prods t
prods) Input t
input = 
    (forall t a. GLL t a -> Flags -> Mutable t -> Mutable t
runGLL ((Nt, Int) -> GLL t ()
pLhs (Nt
start, Int
0)) Flags
flags Mutable t
context, SelectMap t
selects, FollowMap t
follows)
 where 
    context :: Mutable t
context = forall t.
SPPF t
-> Rcal t
-> Ucal t
-> GSS t
-> Pcal t
-> MisMatches t
-> Counters
-> Mutable t
Mutable forall t. Ord t => SPPF t
emptySPPF [] forall a. IntMap a
IM.empty forall a. IntMap a
IM.empty forall a. IntMap a
IM.empty forall a. IntMap a
IM.empty Counters
counters
    counters :: Counters
counters = Int -> Int -> Counters
Counters Int
0 Int
0

    dispatch :: GLL t ()
dispatch = do
        Maybe (RhsParams t, SPPFNode t)
mnext <- forall {t}. GLL t (Maybe (RhsParams t, SPPFNode t))
getDescr
        case Maybe (RhsParams t, SPPFNode t)
mnext of
            Maybe (RhsParams t, SPPFNode t)
Nothing            -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- no continuation
            Just (RhsParams t
next,SPPFNode t
sppf)   -> RhsParams t -> SPPFNode t -> GLL t ()
pRhs RhsParams t
next SPPFNode t
sppf

    pLhs :: (Nt, Int) -> GLL t ()
pLhs (Nt
bigx, Int
i) = do 
        let     alts :: [(RhsParams t, Set t)]
alts  =  [  ((forall t. Nt -> [Symbol t] -> [Symbol t] -> Slot t
Slot Nt
bigx [] Symbols t
beta, Int
i, Int
i), Set t
first_ts) 
                         | Prod Nt
bigx Symbols t
beta <- Nt -> Prods t
altsOf Nt
bigx
                         , let first_ts :: Set t
first_ts = Symbols t -> Nt -> Set t
select Symbols t
beta Nt
bigx 
                         ]
                first_ts :: Set t
first_ts = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(RhsParams t, Set t)]
alts)
                cands :: [RhsParams t]
cands = [ RhsParams t
descr | (RhsParams t
descr, Set t
first_ts) <- [(RhsParams t, Set t)]
alts
                                , forall {t :: * -> *} {a}.
(Foldable t, Parseable a) =>
a -> t a -> Bool
select_test (Input t
input forall i e. Ix i => Array i e -> i -> e
A.! Int
i) Set t
first_ts ]
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RhsParams t]
cands
            then forall t. Ord t => Int -> Set t -> GLL t ()
addMisMatch Int
i Set t
first_ts
            else forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RhsParams t]
cands (forall {t}. Ord t => SPPFNode t -> (Slot t, Int, Int) -> GLL t ()
addDescr forall t. SPPFNode t
Dummy)
        GLL t ()
dispatch 

    pRhs :: RhsParams t -> SPPFNode t -> GLL t ()
pRhs (Slot Nt
bigx Symbols t
alpha ((Term t
tau):Symbols t
beta), Int
i, Int
l) SPPFNode t
sppf = 
     if (Input t
input forall i e. Ix i => Array i e -> i -> e
A.! Int
i forall a. Parseable a => a -> a -> Bool
`matches` t
tau) 
      then do -- token test successful 
        SPPFNode t
root <-  forall {t}.
Ord t =>
Slot t -> SPPFNode t -> Int -> Int -> Int -> GLL t (SPPFNode t)
joinSPPFs Slot t
slot SPPFNode t
sppf Int
l Int
i (Int
iforall a. Num a => a -> a -> a
+Int
1) 
        RhsParams t -> SPPFNode t -> GLL t ()
pRhs (Slot t
slot, Int
iforall a. Num a => a -> a -> a
+Int
1, Int
l) SPPFNode t
root 
      else do
        forall t. Ord t => Int -> Set t -> GLL t ()
addMisMatch Int
i (forall a. a -> Set a
S.singleton t
tau)
        GLL t ()
dispatch
     where  slot :: Slot t
slot       = forall t. Nt -> [Symbol t] -> [Symbol t] -> Slot t
Slot Nt
bigx (Symbols t
alphaforall a. [a] -> [a] -> [a]
++[forall t. t -> Symbol t
Term t
tau]) Symbols t
beta

    pRhs (Slot Nt
bigx Symbols t
alpha ((Nt Nt
bigy):Symbols t
beta), Int
i, Int
l) SPPFNode t
sppf = 
      if forall {t :: * -> *} {a}.
(Foldable t, Parseable a) =>
a -> t a -> Bool
select_test (Input t
input forall i e. Ix i => Array i e -> i -> e
A.! Int
i) Set t
first_ts
        then do
          forall {t}. (Nt, Int) -> GSSEdge t -> GLL t ()
addGSSEdge (Nt, Int)
ret (Slot t
slot,Int
l,SPPFNode t
sppf)
          [Int]
rs <- forall {t}. (Nt, Int) -> GLL t [Int]
getPops (Nt, Int)
ret     -- has ret been popped?
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
rs forall a b. (a -> b) -> a -> b
$ \Int
r -> do   -- yes, use given extents
                          SPPFNode t
root <- forall {t}.
Ord t =>
Slot t -> SPPFNode t -> Int -> Int -> Int -> GLL t (SPPFNode t)
joinSPPFs Slot t
slot SPPFNode t
sppf Int
l Int
i Int
r
                          forall {t}. Ord t => SPPFNode t -> (Slot t, Int, Int) -> GLL t ()
addDescr SPPFNode t
root (Slot t
slot, Int
r, Int
l)
          (Nt, Int) -> GLL t ()
pLhs (Nt
bigy, Int
i)
        else do
          forall t. Ord t => Int -> Set t -> GLL t ()
addMisMatch Int
i Set t
first_ts
          GLL t ()
dispatch
     where  ret :: (Nt, Int)
ret      = (Nt
bigy, Int
i)
            slot :: Slot t
slot     = forall t. Nt -> [Symbol t] -> [Symbol t] -> Slot t
Slot Nt
bigx (Symbols t
alphaforall a. [a] -> [a] -> [a]
++[forall t. Nt -> Symbol t
Nt Nt
bigy]) Symbols t
beta
            first_ts :: Set t
first_ts = Symbols t -> Nt -> Set t
select ((forall t. Nt -> Symbol t
Nt Nt
bigy)forall a. a -> [a] -> [a]
:Symbols t
beta) Nt
bigx 

    pRhs (Slot Nt
bigy Symbols t
alpha [], Int
i, Int
l) SPPFNode t
sppf | Nt
bigy forall a. Eq a => a -> a -> Bool
== Nt
start Bool -> Bool -> Bool
&& Int
l forall a. Eq a => a -> a -> Bool
== Int
0 = 
        if Int
i forall a. Eq a => a -> a -> Bool
== Int
m 
          then forall {t}. GLL t ()
addSuccess forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GLL t ()
dispatch 
          else forall t. Ord t => Int -> Set t -> GLL t ()
addMisMatch Int
i (forall a. a -> Set a
S.singleton forall a. Parseable a => a
eos) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GLL t ()
dispatch

    pRhs (Slot Nt
bigx Symbols t
alpha [], Int
i, Int
l) SPPFNode t
Dummy  = do
        SPPFNode t
root <- forall {t}.
Ord t =>
Slot t -> SPPFNode t -> Int -> Int -> Int -> GLL t (SPPFNode t)
joinSPPFs forall {t}. Slot t
slot forall t. SPPFNode t
Dummy Int
l Int
i Int
i
        RhsParams t -> SPPFNode t -> GLL t ()
pRhs (forall {t}. Slot t
slot, Int
i, Int
l) SPPFNode t
root
     where  slot :: Slot t
slot    = forall t. Nt -> [Symbol t] -> [Symbol t] -> Slot t
Slot Nt
bigx [] []

    pRhs (Slot Nt
bigy Symbols t
alpha [], Int
i, Int
l) SPPFNode t
ynode = do
        forall {t}. (Nt, Int) -> Int -> GLL t ()
addPop (Nt
bigy,Int
l) Int
i
        [GSSEdge t]
returns <- forall {t}. (Nt, Int) -> GLL t [GSSEdge t]
getChildren (Nt
bigy,Int
l) 
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GSSEdge t]
returns forall a b. (a -> b) -> a -> b
$ \(Slot t
gs',Int
l',SPPFNode t
sppf) -> do  
            SPPFNode t
root <- forall {t}.
Ord t =>
Slot t -> SPPFNode t -> Int -> Int -> Int -> GLL t (SPPFNode t)
joinSPPFs Slot t
gs' SPPFNode t
sppf Int
l' Int
l Int
i  -- create SPPF for lhs
            forall {t}. Ord t => SPPFNode t -> (Slot t, Int, Int) -> GLL t ()
addDescr SPPFNode t
root (Slot t
gs', Int
i, Int
l')   -- add new descriptors
        GLL t ()
dispatch

    (ProdMap t
prodMap,PrefixMap t
_,FollowMap t
_,FollowMap t
follows,SelectMap t
selects)   
        | Flags -> Bool
do_select_test Flags
flags = forall t.
(Eq t, Ord t, Parseable t) =>
Nt
-> [Prod t]
-> (ProdMap t, PrefixMap t, FirstMap t, FirstMap t, SelectMap t)
fixedMaps Nt
start Prods t
prods 
        | Bool
otherwise = (ProdMap t
pmap, forall a. HasCallStack => a
undefined, forall a. HasCallStack => a
undefined, forall a. HasCallStack => a
undefined, 
                         forall a. HasCallStack => String -> a
error String
"select-tests are switched off")
      where pmap :: ProdMap t
pmap = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++) [ (Nt
x,[Prod t
pr]) | pr :: Prod t
pr@(Prod Nt
x Symbols t
_) <- Prods t
prods ]
    follow :: Nt -> Set t
follow Nt
x          = FollowMap t
follows forall k a. Ord k => Map k a -> k -> a
M.! Nt
x
    do_test :: Bool
do_test = Flags -> Bool
do_select_test Flags
flags     
    select :: Symbols t -> Nt -> Set t
select Symbols t
rhs Nt
x      | Bool
do_test   = SelectMap t
selects forall k a. Ord k => Map k a -> k -> a
M.! (Nt
x,Symbols t
rhs)
                      | Bool
otherwise = forall a. Set a
S.empty 
      where 
    select_test :: a -> t a -> Bool
select_test a
t t a
set | Bool
do_test   = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Parseable a => a -> a -> Bool
matches a
t) t a
set
                      | Bool
otherwise = Bool
True
    altsOf :: Nt -> Prods t
altsOf Nt
x          = ProdMap t
prodMap forall k a. Ord k => Map k a -> k -> a
M.! Nt
x
    merge :: IntMap (IntMap (Set a))
-> IntMap (IntMap (Set a)) -> IntMap (IntMap (Set a))
merge IntMap (IntMap (Set a))
m1 IntMap (IntMap (Set a))
m2 = forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap (Set a) -> IntMap (Set a) -> IntMap (Set a)
inner IntMap (IntMap (Set a))
m1 IntMap (IntMap (Set a))
m2
     where inner :: IntMap (Set a) -> IntMap (Set a) -> IntMap (Set a)
inner  = forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith forall a. Ord a => Set a -> Set a -> Set a
S.union 

count_pnode :: GLL t ()
count_pnode :: forall {t}. GLL t ()
count_pnode = forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL forall a b. (a -> b) -> a -> b
$ \Flags
flags Mutable t
mut -> 
    let mut' :: Mutable t
mut' = Mutable t
mut { mut_counters :: Counters
mut_counters = Counters -> Counters
mut_counters' (forall t. Mutable t -> Counters
mut_counters Mutable t
mut) }
          where mut_counters' :: Counters -> Counters
mut_counters' Counters
counters = Counters
counters { count_pnodes :: Int
count_pnodes = Counters -> Int
count_pnodes Counters
counters forall a. Num a => a -> a -> a
+ Int
1 }
    in ((), Mutable t
mut')

joinSPPFs :: Slot t -> SPPFNode t -> Int -> Int -> Int -> GLL t (SPPFNode t)
joinSPPFs (Slot Nt
bigx [Symbol t]
alpha [Symbol t]
beta) SPPFNode t
sppf Int
l Int
k Int
r = do
    Flags
flags <- forall {t}. GLL t Flags
getFlags
    case (Flags -> Bool
flexible_binarisation Flags
flags, SPPFNode t
sppf, [Symbol t]
beta) of
        (Bool
True,SPPFNode t
Dummy, Symbol t
_:[Symbol t]
_) ->  forall (m :: * -> *) a. Monad m => a -> m a
return SPPFNode t
snode
        (Bool
_,SPPFNode t
Dummy, [])     ->  do  forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge forall t. SPPFNode t
xnode SPPFNode t
pnode
                                  forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
snode
                                  forall {t}. GLL t ()
count_pnode
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall t. SPPFNode t
xnode
        (Bool
_,SPPFNode t
_, [])         ->  do  forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge forall t. SPPFNode t
xnode SPPFNode t
pnode
                                  forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
sppf
                                  forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
snode
                                  forall {t}. GLL t ()
count_pnode
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall t. SPPFNode t
xnode
        (Bool, SPPFNode t, [Symbol t])
_                 ->  do  forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
inode SPPFNode t
pnode
                                  forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
sppf
                                  forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
snode
                                  forall {t}. GLL t ()
count_pnode
                                  forall (m :: * -> *) a. Monad m => a -> m a
return SPPFNode t
inode
 where  x :: Symbol t
x       =   forall a. [a] -> a
last [Symbol t]
alpha  -- symbol before the dot
        snode :: SPPFNode t
snode   =   forall t. (Symbol t, Int, Int) -> SPPFNode t
SNode (Symbol t
x, Int
k, Int
r)     
        xnode :: SPPFNode t
xnode   =   forall t. (Symbol t, Int, Int) -> SPPFNode t
SNode (forall t. Nt -> Symbol t
Nt Nt
bigx, Int
l, Int
r)
        inode :: SPPFNode t
inode   =   forall t. (Slot t, Int, Int) -> SPPFNode t
INode ((forall t. Nt -> [Symbol t] -> [Symbol t] -> Slot t
Slot Nt
bigx [Symbol t]
alpha [Symbol t]
beta), Int
l, Int
r)
        pnode :: SPPFNode t
pnode   =   forall t. (Slot t, Int, Int, Int) -> SPPFNode t
PNode ((forall t. Nt -> [Symbol t] -> [Symbol t] -> Slot t
Slot Nt
bigx [Symbol t]
alpha [Symbol t]
beta), Int
l, Int
k, Int
r)

-- | 
-- The "ParseResult" datatype contains the "SPPF" and some other 
--  information about the parse:
--
--  * 'SPPF'
--  * Whether the parse was successful
--  * The number of descriptors that have been processed
--  * The number of symbol nodes (nonterminal and terminal)
--  * The number of intermediate noes
--  * The number of packed nodes
--  * The number of GSS nodes
--  * The number of GSS edges
data ParseResult t = ParseResult{ forall t. ParseResult t -> SPPF t
sppf_result               :: SPPF t
                                , forall t. ParseResult t -> Bool
res_success               :: Bool
                                , forall t. ParseResult t -> Int
res_successes             :: Int
                                , forall t. ParseResult t -> Int
nr_descriptors            :: Int
                                , forall t. ParseResult t -> Int
nr_nterm_nodes            :: Int
                                , forall t. ParseResult t -> Int
nr_term_nodes             :: Int
                                , forall t. ParseResult t -> Int
nr_intermediate_nodes     :: Int
                                , forall t. ParseResult t -> Int
nr_packed_nodes           :: Int
                                , forall t. ParseResult t -> Int
nr_packed_node_attempts   :: Int
                                , forall t. ParseResult t -> Int
nr_sppf_edges             :: Int
                                , forall t. ParseResult t -> Int
nr_gss_nodes              :: Int
                                , forall t. ParseResult t -> Int
nr_gss_edges              :: Int
                                , forall t. ParseResult t -> String
error_message             :: String
                                }

resultFromMutable :: Parseable t => Input t -> Flags -> Mutable t -> SNode t -> ParseResult t
resultFromMutable :: forall t.
Parseable t =>
Input t -> Flags -> Mutable t -> SNode t -> ParseResult t
resultFromMutable Input t
inp Flags
flags Mutable t
mutable s_node :: SNode t
s_node@(Symbol t
s, Int
l, Int
m) =
    let u :: Ucal t
u           = forall t. Mutable t -> Ucal t
mut_descriptors Mutable t
mutable
        gss :: GSS t
gss         = forall t. Mutable t -> GSS t
mut_gss Mutable t
mutable
        usize :: Int
usize       = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum  [ forall a. Set a -> Int
S.size Set (Slot t)
s   | (Int
l, IntMap (Set (Slot t))
r2s) <- forall a. IntMap a -> [(Int, a)]
IM.assocs Ucal t
u
                                        , (Int
r,Set (Slot t)
s) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Set (Slot t))
r2s ]
        s_nodes :: Int
s_nodes     = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ forall a. Set a -> Int
S.size Set (Symbol t)
s    | (Int
l, IntMap (Set (Symbol t))
r2s) <- forall a. IntMap a -> [(Int, a)]
IM.assocs SymbMap t
sMap
                                        , (Int
r, Set (Symbol t)
s)   <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Set (Symbol t))
r2s ]
        i_nodes :: Int
i_nodes     = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ forall a. Set a -> Int
S.size Set (Slot t)
s    | (Int
l, IntMap (Set (Slot t))
r2s) <- forall a. IntMap a -> [(Int, a)]
IM.assocs Ucal t
iMap
                                        , (Int
r, Set (Slot t)
s)   <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Set (Slot t))
r2s ]
        p_nodes :: Int
p_nodes     = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ IntSet -> Int
IS.size IntSet
ks  | (Int
l, IntMap (IntMap (Map (Prod t) IntSet))
r2j) <- forall a. IntMap a -> [(Int, a)]
IM.assocs PackMap t
pMap
                                        , (Int
r, IntMap (Map (Prod t) IntSet)
j2s) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap (Map (Prod t) IntSet))
r2j
                                        , (Int
j, Map (Prod t) IntSet
s2k) <- forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Map (Prod t) IntSet)
j2s
                                        , (Prod t
s, IntSet
ks)  <- forall k a. Map k a -> [(k, a)]
M.assocs Map (Prod t) IntSet
s2k ]
        sppf_edges :: Int
sppf_edges  = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ forall a. Set a -> Int
S.size Set (SPPFNode t)
ts | (SPPFNode t
_, Set (SPPFNode t)
ts) <- forall k a. Map k a -> [(k, a)]
M.assocs EdgeMap t
eMap ]
        gss_nodes :: Int
gss_nodes   = Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map Nt [GSSEdge t]
x2s| (Int
l,Map Nt [GSSEdge t]
x2s) <- forall a. IntMap a -> [(Int, a)]
IM.assocs GSS t
gss] 
        gss_edges :: Int
gss_edges   = Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ forall (t :: * -> *) a. Foldable t => t a -> Int
length [GSSEdge t]
s    | (Int
l,Map Nt [GSSEdge t]
x2s) <- forall a. IntMap a -> [(Int, a)]
IM.assocs GSS t
gss
                                            , (Nt
x,[GSSEdge t]
s)   <- forall k a. Map k a -> [(k, a)]
M.assocs Map Nt [GSSEdge t]
x2s ]
        sppf :: SPPF t
sppf@(SymbMap t
sMap, Ucal t
iMap, PackMap t
pMap, EdgeMap t
eMap) = forall t. Mutable t -> SPPF t
mut_sppf Mutable t
mutable
        successes :: Int
successes = Counters -> Int
count_successes (forall t. Mutable t -> Counters
mut_counters Mutable t
mutable)
    in forall t.
SPPF t
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> String
-> ParseResult t
ParseResult SPPF t
sppf (Int
successes forall a. Ord a => a -> a -> Bool
> Int
0) Int
successes Int
usize Int
s_nodes Int
m Int
i_nodes Int
p_nodes (Counters -> Int
count_pnodes (forall t. Mutable t -> Counters
mut_counters Mutable t
mutable)) Int
sppf_edges Int
gss_nodes Int
gss_edges (forall t. Parseable t => Input t -> Flags -> MisMatches t -> String
renderErrors Input t
inp Flags
flags (forall t. Mutable t -> MisMatches t
mut_mismatches Mutable t
mutable))

renderErrors :: Parseable t => Input t -> Flags -> MisMatches t -> String
renderErrors :: forall t. Parseable t => Input t -> Flags -> MisMatches t -> String
renderErrors Input t
inp Flags
flags MisMatches t
mm = Doc -> String
render Doc
doc 
 where  n :: Int
n       = Flags -> Int
max_errors Flags
flags
        locs :: [(Int, Set t)]
locs    = forall a. [a] -> [a]
reverse (forall a. IntMap a -> [(Int, a)]
IM.assocs MisMatches t
mm)
        doc :: Doc
doc     = String -> Doc
text (String
"Unsuccessful parse, showing "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" furthest matches") Doc -> Doc -> Doc
$+$
                    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int, Set t)
loc -> (forall {a}. Parseable a => (Int, Set a) -> Doc
ppLoc (Int, Set t)
loc Doc -> Doc -> Doc
$+$)) Doc
PP.empty [(Int, Set t)]
locs

        ppLoc :: (Int, Set a) -> Doc
ppLoc (Int
k, Set a
ts) = String -> Doc
text (String
"did not match at position " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k forall a. [a] -> [a] -> [a]
++ String
", where we find " forall a. [a] -> [a] -> [a]
++ String
lexeme) Doc -> Doc -> Doc
$+$
                            Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"Found" Doc -> Doc -> Doc
<+> forall {a}. Parseable a => a -> Doc
ppExp t
token) Doc -> Doc -> Doc
$+$
                            Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"expected:") Doc -> Doc -> Doc
$+$
                                Int -> Doc -> Doc
nest Int
8 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Parseable a => a -> Doc
ppExp (forall a. Set a -> [a]
S.toList Set a
ts)))
         where  token :: t
token = Input t
inp forall i e. Ix i => Array i e -> i -> e
A.! Int
k
                lexeme :: String
lexeme = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Parseable a => a -> String
unlex (forall a. Int -> [a] -> [a]
take Int
5 (forall a. Int -> [a] -> [a]
drop Int
k (forall i e. Array i e -> [e]
A.elems Input t
inp)))
        ppExp :: a -> Doc
ppExp a
t = String -> Doc
text (forall a. Parseable a => a -> String
unlex a
t) Doc -> Doc -> Doc
<+> String -> Doc
text String
"AKA" Doc -> Doc -> Doc
<+> String -> Doc
text (forall a. Show a => a -> String
show a
t)

instance Show (ParseResult t) where
    show :: ParseResult t -> String
show ParseResult t
res | forall t. ParseResult t -> Bool
res_success ParseResult t
res = String
result_string
             | Bool
otherwise       = String
result_string forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall t. ParseResult t -> String
error_message ParseResult t
res
     where result_string :: String
result_string = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
                [   String
"Success             "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Bool
res_success ParseResult t
res)
                ,   String
"#Success            "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
res_successes ParseResult t
res)
                ,   String
"Descriptors:        "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
nr_descriptors ParseResult t
res)
                ,   String
"Nonterminal nodes:  "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
nr_nterm_nodes ParseResult t
res)
                ,   String
"Terminal nodes:     "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
nr_term_nodes ParseResult t
res)
                ,   String
"Intermediate nodes: "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
nr_intermediate_nodes ParseResult t
res)
                ,   String
"Packed nodes:       "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
nr_packed_nodes ParseResult t
res)
                ,   String
"SPPF edges:         "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
nr_sppf_edges ParseResult t
res)
                ,   String
"GSS nodes:          "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
nr_gss_nodes ParseResult t
res)
                ,   String
"GSS edges:          "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. ParseResult t -> Int
nr_gss_edges ParseResult t
res)
                ]