{-|
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.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 = Nt -> Symbols t -> Prod t
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 = Nt -> Symbol t
forall t. Nt -> Symbol t
Nt (Nt -> Symbol t) -> (String -> Nt) -> String -> Symbol t
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 = t -> Symbol t
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 = (Int, Int) -> [t] -> Array Int t
forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0,Int
m) ([t]
input[t] -> [t] -> [t]
forall a. [a] -> [a] -> [a]
++[t
forall a. Parseable a => a
eos])
  where m :: Int
m = [t] -> Int
forall a. [a] -> Int
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 = (a, Mutable t) -> Mutable t
forall a b. (a, b) -> b
snd ((a, Mutable t) -> Mutable t) -> (a, Mutable t) -> Mutable t
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 = (Flags -> Mutable t -> ((), Mutable t)) -> GLL t ()
forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL ((Flags -> Mutable t -> ((), Mutable t)) -> GLL t ())
-> (Flags -> Mutable t -> ((), Mutable t)) -> GLL t ()
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 SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
sNodeInsert SPPFNode t
f SPPFNode t
t else SPPF t -> SPPF t
forall a. a -> a
id) (SPPF t -> SPPF t) -> SPPF t -> SPPF t
forall a b. (a -> b) -> a -> b
$
                (if Flags -> Bool
intermediate_nodes Flags
flags    then SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
iNodeInsert SPPFNode t
f SPPFNode t
t else SPPF t -> SPPF t
forall a. a -> a
id) (SPPF t -> SPPF t) -> SPPF t -> SPPF t
forall a b. (a -> b) -> a -> b
$
                (if Flags -> Bool
edges Flags
flags                 then SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
eMapInsert SPPFNode t
f SPPFNode t
t  else SPPF t -> SPPF t
forall a. a -> a
id) (SPPF t -> SPPF t) -> SPPF t -> SPPF t
forall a b. (a -> b) -> a -> b
$ 
                    SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
forall t. Ord t => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t
pMapInsert SPPFNode t
f SPPFNode t
t (Mutable t -> SPPF t
forall t. Mutable t -> SPPF t
mut_sppf Mutable t
mut)
    in ((),Mutable t
mut{mut_sppf = 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) = (Flags -> Mutable t -> ((), Mutable t)) -> GLL t ()
forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL ((Flags -> Mutable t -> ((), Mutable t)) -> GLL t ())
-> (Flags -> Mutable t -> ((), Mutable t)) -> GLL t ()
forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut -> 
    let new :: Bool
new     = Bool
-> (IntMap (Set (Slot t)) -> Bool)
-> Maybe (IntMap (Set (Slot t)))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True IntMap (Set (Slot t)) -> Bool
inner (Maybe (IntMap (Set (Slot t))) -> Bool)
-> Maybe (IntMap (Set (Slot t))) -> Bool
forall a b. (a -> b) -> a -> b
$ Int
-> IntMap (IntMap (Set (Slot t))) -> Maybe (IntMap (Set (Slot t)))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i (Mutable t -> IntMap (IntMap (Set (Slot t)))
forall t. Mutable t -> Ucal t
mut_descriptors Mutable t
mut)
          where inner :: IntMap (Set (Slot t)) -> Bool
inner IntMap (Set (Slot t))
m = Bool -> (Set (Slot t) -> Bool) -> Maybe (Set (Slot t)) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (Set (Slot t) -> Bool) -> Set (Slot t) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slot t
slot Slot t -> Set (Slot t) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member`)) (Maybe (Set (Slot t)) -> Bool) -> Maybe (Set (Slot t)) -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (Set (Slot t)) -> Maybe (Set (Slot t))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l IntMap (Set (Slot t))
m
        newU :: IntMap (IntMap (Set (Slot t)))
newU = (Maybe (IntMap (Set (Slot t))) -> Maybe (IntMap (Set (Slot t))))
-> Int
-> IntMap (IntMap (Set (Slot t)))
-> IntMap (IntMap (Set (Slot t)))
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 (Mutable t -> IntMap (IntMap (Set (Slot t)))
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 -> IntMap (Set (Slot t)) -> Maybe (IntMap (Set (Slot t)))
forall a. a -> Maybe a
Just (IntMap (Set (Slot t)) -> Maybe (IntMap (Set (Slot t))))
-> IntMap (Set (Slot t)) -> Maybe (IntMap (Set (Slot t)))
forall a b. (a -> b) -> a -> b
$ Int -> Set (Slot t) -> IntMap (Set (Slot t))
forall a. Int -> a -> IntMap a
IM.singleton Int
l Set (Slot t)
single 
                             Just IntMap (Set (Slot t))
m  -> IntMap (Set (Slot t)) -> Maybe (IntMap (Set (Slot t)))
forall a. a -> Maybe a
Just (IntMap (Set (Slot t)) -> Maybe (IntMap (Set (Slot t))))
-> IntMap (Set (Slot t)) -> Maybe (IntMap (Set (Slot t)))
forall a b. (a -> b) -> a -> b
$ (Set (Slot t) -> Set (Slot t) -> Set (Slot t))
-> Int
-> Set (Slot t)
-> IntMap (Set (Slot t))
-> IntMap (Set (Slot t))
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith (Set (Slot t) -> Set (Slot t) -> Set (Slot t)
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 = Slot t -> Set (Slot t)
forall a. a -> Set a
S.singleton Slot t
slot
     in if Bool
new then ((), Mutable t
mut{mut_worklist       = (alt,sppf):(mut_worklist mut)
                            ,mut_descriptors    = newU})
               else ((), Mutable t
mut)

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

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

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

getPops :: (Nt, Int) -> GLL t [Int]
getPops (Nt
gs,Int
l) = (Flags -> Mutable t -> ([Int], Mutable t)) -> GLL t [Int]
forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL ((Flags -> Mutable t -> ([Int], Mutable t)) -> GLL t [Int])
-> (Flags -> Mutable t -> ([Int], Mutable t)) -> GLL t [Int]
forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut -> 
    let res :: [Int]
res = [Int] -> (Map Nt [Int] -> [Int]) -> Maybe (Map Nt [Int]) -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Map Nt [Int] -> [Int]
forall {a}. Map Nt [a] -> [a]
inner (Maybe (Map Nt [Int]) -> [Int]) -> Maybe (Map Nt [Int]) -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Pcal t -> Maybe (Map Nt [Int])
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l (Mutable t -> Pcal t
forall t. Mutable t -> Pcal t
mut_popset Mutable t
mut)
         where inner :: Map Nt [a] -> [a]
inner = [a] -> ([a] -> [a]) -> Maybe [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [a] -> [a]
forall a. a -> a
id (Maybe [a] -> [a])
-> (Map Nt [a] -> Maybe [a]) -> Map Nt [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Nt -> Map Nt [a] -> Maybe [a]
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 = (Flags -> Mutable t -> ((), Mutable t)) -> GLL t ()
forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL ((Flags -> Mutable t -> ((), Mutable t)) -> GLL t ())
-> (Flags -> Mutable t -> ((), Mutable t)) -> GLL t ()
forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
mut -> 
  let mut' :: Mutable t
mut' = Mutable t
mut { mut_counters = counters { count_successes = 1 + count_successes counters } }
      counters :: Counters
counters = Mutable t -> Counters
forall t. Mutable t -> Counters
mut_counters Mutable t
mut
  in ((),Mutable t
mut')

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

instance (Show t) => Show (SPPFNode t) where
    show :: SPPFNode t -> String
show (SNode (Symbol t
s, Int
l, Int
r))  = String
"(s: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Symbol t -> String
forall a. Show a => a -> String
show Symbol t
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    show (INode (Slot t
s, Int
l, Int
r))  = String
"(i: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Slot t -> String
forall a. Show a => a -> String
show Slot t
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    show (PNode (Slot t
p, Int
l, Int
k, Int
r))  = String
"(p: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Slot t -> String
forall a. Show a => a -> String
show Slot t
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
r String -> ShowS
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
(<*>) = 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 a
v = (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL ((Flags -> Mutable t -> (a, Mutable t)) -> GLL t a)
-> (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
forall a b. (a -> b) -> a -> b
$ \Flags
_ Mutable t
p -> (a
v, Mutable t
p)
instance Functor (GLL t) where
    fmap :: forall a b. (a -> b) -> GLL t a -> GLL t b
fmap  = (a -> b) -> GLL t a -> GLL t b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Monad (GLL t) where
    (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  = (Flags -> Mutable t -> (b, Mutable t)) -> GLL t b
forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL ((Flags -> Mutable t -> (b, Mutable t)) -> GLL t b)
-> (Flags -> Mutable t -> (b, Mutable t)) -> GLL t b
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 = ParseOptions -> Grammar t -> [t] -> ParseResult t
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 = ParseOptions -> Grammar t -> Input t -> ParseResult t
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  = ParseOptions -> Grammar t -> Input t -> ParseResult t
forall t.
Parseable t =>
ParseOptions -> Grammar t -> Input t -> ParseResult t
parseWithOptionsArray ParseOptions
opts Grammar t
gram (Input t -> ParseResult t)
-> ([t] -> Input t) -> [t] -> ParseResult t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> Input t
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
_)   = Flags
-> Int
-> Bool
-> Grammar t
-> Input t
-> (Mutable t, 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)          = Input t -> (Int, Int)
forall i e. Array i e -> (i, i)
A.bounds Input t
input 
    in Input t -> Flags -> Mutable t -> SNode t -> ParseResult t
forall t.
Parseable t =>
Input t -> Flags -> Mutable t -> SNode t -> ParseResult t
resultFromMutable Input t
input Flags
flags Mutable t
mutable (Nt -> Symbol t
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 = 
    (GLL t () -> Flags -> Mutable t -> Mutable t
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
forall t. Ord t => Mutable t
context, SelectMap t
selects, FollowMap t
follows)
 where 
    context :: (Ord t) => Mutable t 
    context :: forall t. Ord t => Mutable t
context = SPPF t
-> Rcal t
-> Ucal t
-> GSS t
-> Pcal t
-> MisMatches t
-> Counters
-> Mutable t
forall t.
SPPF t
-> Rcal t
-> Ucal t
-> GSS t
-> Pcal t
-> MisMatches t
-> Counters
-> Mutable t
Mutable SPPF t
forall t. Ord t => SPPF t
emptySPPF [] Ucal t
forall a. IntMap a
IM.empty GSS t
forall a. IntMap a
IM.empty Pcal t
forall a. IntMap a
IM.empty MisMatches t
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 <- GLL t (Maybe (RhsParams t, SPPFNode t))
forall {t}. GLL t (Maybe (RhsParams t, SPPFNode t))
getDescr
        case Maybe (RhsParams t, SPPFNode t)
mnext of
            Maybe (RhsParams t, SPPFNode t)
Nothing            -> () -> GLL t ()
forall a. a -> GLL t a
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  =  [  ((Nt -> [Symbol t] -> [Symbol t] -> Slot t
forall t. Nt -> [Symbol t] -> [Symbol t] -> Slot t
Slot Nt
bigx [] [Symbol t]
beta, Int
i, Int
i), Set t
first_ts) 
                         | Prod Nt
bigx [Symbol t]
beta <- Nt -> Prods t
altsOf Nt
bigx
                         , let first_ts :: Set t
first_ts = [Symbol t] -> Nt -> Set t
select [Symbol t]
beta Nt
bigx 
                         ]
                first_ts :: Set t
first_ts = [Set t] -> Set t
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (((RhsParams t, Set t) -> Set t)
-> [(RhsParams t, Set t)] -> [Set t]
forall a b. (a -> b) -> [a] -> [b]
map (RhsParams t, Set t) -> Set t
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
                                , t -> Set t -> Bool
forall {t :: * -> *} {a}.
(Foldable t, Parseable a) =>
a -> t a -> Bool
select_test (Input t
input Input t -> Int -> t
forall i e. Ix i => Array i e -> i -> e
A.! Int
i) Set t
first_ts ]
        if [RhsParams t] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RhsParams t]
cands
            then Int -> Set t -> GLL t ()
forall t. Ord t => Int -> Set t -> GLL t ()
addMisMatch Int
i Set t
first_ts
            else [RhsParams t] -> (RhsParams t -> GLL t ()) -> GLL t ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RhsParams t]
cands (SPPFNode t -> RhsParams t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> (Slot t, Int, Int) -> GLL t ()
addDescr SPPFNode t
forall t. SPPFNode t
Dummy)
        GLL t ()
dispatch 

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

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

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

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

    pRhs (Slot Nt
bigy [Symbol t]
alpha [], Int
i, Int
l) SPPFNode t
ynode = do
        (Nt, Int) -> Int -> GLL t ()
forall {t}. (Nt, Int) -> Int -> GLL t ()
addPop (Nt
bigy,Int
l) Int
i
        [GSSEdge t]
returns <- (Nt, Int) -> GLL t [GSSEdge t]
forall {t}. (Nt, Int) -> GLL t [GSSEdge t]
getChildren (Nt
bigy,Int
l) 
        [GSSEdge t] -> (GSSEdge t -> GLL t ()) -> GLL t ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GSSEdge t]
returns ((GSSEdge t -> GLL t ()) -> GLL t ())
-> (GSSEdge t -> GLL t ()) -> GLL t ()
forall a b. (a -> b) -> a -> b
$ \(Slot t
gs',Int
l',SPPFNode t
sppf) -> do  
            SPPFNode t
root <- Slot t -> SPPFNode t -> Int -> Int -> Int -> GLL t (SPPFNode t)
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
            SPPFNode t -> RhsParams t -> GLL t ()
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 = Nt
-> Prods t
-> (ProdMap t, PrefixMap t, FollowMap t, FollowMap t, SelectMap t)
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, PrefixMap t
forall a. HasCallStack => a
undefined, FollowMap t
forall a. HasCallStack => a
undefined, FollowMap t
forall a. HasCallStack => a
undefined, 
                         String -> SelectMap t
forall a. HasCallStack => String -> a
error String
"select-tests are switched off")
      where pmap :: ProdMap t
pmap = (Prods t -> Prods t -> Prods t) -> [(Nt, Prods t)] -> ProdMap t
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Prods t -> Prods t -> Prods t
forall a. [a] -> [a] -> [a]
(++) [ (Nt
x,[Prod t
pr]) | pr :: Prod t
pr@(Prod Nt
x [Symbol t]
_) <- Prods t
prods ]
    follow :: Nt -> Set t
follow Nt
x          = FollowMap t
follows FollowMap t -> Nt -> Set t
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 :: [Symbol t] -> Nt -> Set t
select [Symbol t]
rhs Nt
x      | Bool
do_test   = SelectMap t
selects SelectMap t -> (Nt, [Symbol t]) -> Set t
forall k a. Ord k => Map k a -> k -> a
M.! (Nt
x,[Symbol t]
rhs)
                      | Bool
otherwise = Set t
forall a. Set a
S.empty 
      where 
    select_test :: a -> t a -> Bool
select_test a
t t a
set | Bool
do_test   = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> a -> Bool
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 ProdMap t -> Nt -> Prods t
forall k a. Ord k => Map k a -> k -> a
M.! Nt
x
    merge :: IntMap (IntMap (Set t))
-> IntMap (IntMap (Set t)) -> IntMap (IntMap (Set t))
merge IntMap (IntMap (Set t))
m1 IntMap (IntMap (Set t))
m2 = (IntMap (Set t) -> IntMap (Set t) -> IntMap (Set t))
-> IntMap (IntMap (Set t))
-> IntMap (IntMap (Set t))
-> IntMap (IntMap (Set t))
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntMap (Set t) -> IntMap (Set t) -> IntMap (Set t)
forall t.
Ord t =>
IntMap (Set t) -> IntMap (Set t) -> IntMap (Set t)
inner IntMap (IntMap (Set t))
m1 IntMap (IntMap (Set t))
m2
     where inner :: (Ord t) => IM.IntMap (S.Set t) -> IM.IntMap (S.Set t) -> IM.IntMap (S.Set t)
           inner :: forall t.
Ord t =>
IntMap (Set t) -> IntMap (Set t) -> IntMap (Set t)
inner  = (Set t -> Set t -> Set t)
-> IntMap (Set t) -> IntMap (Set t) -> IntMap (Set t)
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith Set t -> Set t -> Set t
forall a. Ord a => Set a -> Set a -> Set a
S.union  

count_pnode :: GLL t ()
count_pnode :: forall {t}. GLL t ()
count_pnode = (Flags -> Mutable t -> ((), Mutable t)) -> GLL t ()
forall t a. (Flags -> Mutable t -> (a, Mutable t)) -> GLL t a
GLL ((Flags -> Mutable t -> ((), Mutable t)) -> GLL t ())
-> (Flags -> Mutable t -> ((), Mutable t)) -> GLL t ()
forall a b. (a -> b) -> a -> b
$ \Flags
flags Mutable t
mut -> 
    let mut' :: Mutable t
mut' = Mutable t
mut { mut_counters = mut_counters' (mut_counters mut) }
          where mut_counters' :: Counters -> Counters
mut_counters' Counters
counters = Counters
counters { count_pnodes = count_pnodes counters + 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 <- GLL t 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]
_) ->  SPPFNode t -> GLL t (SPPFNode t)
forall a. a -> GLL t a
forall (m :: * -> *) a. Monad m => a -> m a
return SPPFNode t
snode
        (Bool
_,SPPFNode t
Dummy, [])     ->  do  SPPFNode t -> SPPFNode t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
forall t. SPPFNode t
xnode SPPFNode t
pnode
                                  SPPFNode t -> SPPFNode t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
snode
                                  GLL t ()
forall {t}. GLL t ()
count_pnode
                                  SPPFNode t -> GLL t (SPPFNode t)
forall a. a -> GLL t a
forall (m :: * -> *) a. Monad m => a -> m a
return SPPFNode t
forall t. SPPFNode t
xnode
        (Bool
_,SPPFNode t
_, [])         ->  do  SPPFNode t -> SPPFNode t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
forall t. SPPFNode t
xnode SPPFNode t
pnode
                                  SPPFNode t -> SPPFNode t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
sppf
                                  SPPFNode t -> SPPFNode t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
snode
                                  GLL t ()
forall {t}. GLL t ()
count_pnode
                                  SPPFNode t -> GLL t (SPPFNode t)
forall a. a -> GLL t a
forall (m :: * -> *) a. Monad m => a -> m a
return SPPFNode t
forall t. SPPFNode t
xnode
        (Bool, SPPFNode t, [Symbol t])
_                 ->  do  SPPFNode t -> SPPFNode t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
inode SPPFNode t
pnode
                                  SPPFNode t -> SPPFNode t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
sppf
                                  SPPFNode t -> SPPFNode t -> GLL t ()
forall {t}. Ord t => SPPFNode t -> SPPFNode t -> GLL t ()
addSPPFEdge SPPFNode t
pnode SPPFNode t
snode
                                  GLL t ()
forall {t}. GLL t ()
count_pnode
                                  SPPFNode t -> GLL t (SPPFNode t)
forall a. a -> GLL t a
forall (m :: * -> *) a. Monad m => a -> m a
return SPPFNode t
inode
 where  x :: Symbol t
x       =   [Symbol t] -> Symbol t
forall a. HasCallStack => [a] -> a
last [Symbol t]
alpha  -- symbol before the dot
        snode :: SPPFNode t
snode   =   (Symbol t, Int, Int) -> SPPFNode t
forall t. (Symbol t, Int, Int) -> SPPFNode t
SNode (Symbol t
x, Int
k, Int
r)     
        xnode :: SPPFNode t
xnode   =   (Symbol t, Int, Int) -> SPPFNode t
forall t. (Symbol t, Int, Int) -> SPPFNode t
SNode (Nt -> Symbol t
forall t. Nt -> Symbol t
Nt Nt
bigx, Int
l, Int
r)
        inode :: SPPFNode t
inode   =   (Slot t, Int, Int) -> SPPFNode t
forall t. (Slot t, Int, Int) -> SPPFNode t
INode ((Nt -> [Symbol t] -> [Symbol t] -> Slot t
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   =   (Slot t, Int, Int, Int) -> SPPFNode t
forall t. (Slot t, Int, Int, Int) -> SPPFNode t
PNode ((Nt -> [Symbol t] -> [Symbol t] -> Slot t
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           = Mutable t -> Ucal t
forall t. Mutable t -> Ucal t
mut_descriptors Mutable t
mutable
        gss :: GSS t
gss         = Mutable t -> GSS t
forall t. Mutable t -> GSS t
mut_gss Mutable t
mutable
        usize :: Int
usize       = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum  [ Set (Slot t) -> Int
forall a. Set a -> Int
S.size Set (Slot t)
s   | (Int
l, IntMap (Set (Slot t))
r2s) <- Ucal t -> [(Int, IntMap (Set (Slot t)))]
forall a. IntMap a -> [(Int, a)]
IM.assocs Ucal t
u
                                        , (Int
r,Set (Slot t)
s) <- IntMap (Set (Slot t)) -> [(Int, Set (Slot t))]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Set (Slot t))
r2s ]
        s_nodes :: Int
s_nodes     = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Set (Symbol t) -> Int
forall a. Set a -> Int
S.size Set (Symbol t)
s    | (Int
l, IntMap (Set (Symbol t))
r2s) <- IntMap (IntMap (Set (Symbol t)))
-> [(Int, IntMap (Set (Symbol t)))]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap (Set (Symbol t)))
sMap
                                        , (Int
r, Set (Symbol t)
s)   <- IntMap (Set (Symbol t)) -> [(Int, Set (Symbol t))]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Set (Symbol t))
r2s ]
        i_nodes :: Int
i_nodes     = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Set (Slot t) -> Int
forall a. Set a -> Int
S.size Set (Slot t)
s    | (Int
l, IntMap (Set (Slot t))
r2s) <- Ucal t -> [(Int, IntMap (Set (Slot t)))]
forall a. IntMap a -> [(Int, a)]
IM.assocs Ucal t
iMap
                                        , (Int
r, Set (Slot t)
s)   <- IntMap (Set (Slot t)) -> [(Int, Set (Slot t))]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Set (Slot t))
r2s ]
        p_nodes :: Int
p_nodes     = [Int] -> Int
forall a. Num a => [a] -> a
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) <- IntMap (IntMap (IntMap (Map (Prod t) IntSet)))
-> [(Int, IntMap (IntMap (Map (Prod t) IntSet)))]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap (IntMap (Map (Prod t) IntSet)))
pMap
                                        , (Int
r, IntMap (Map (Prod t) IntSet)
j2s) <- IntMap (IntMap (Map (Prod t) IntSet))
-> [(Int, IntMap (Map (Prod t) IntSet))]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (IntMap (Map (Prod t) IntSet))
r2j
                                        , (Int
j, Map (Prod t) IntSet
s2k) <- IntMap (Map (Prod t) IntSet) -> [(Int, Map (Prod t) IntSet)]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (Map (Prod t) IntSet)
j2s
                                        , (Prod t
s, IntSet
ks)  <- Map (Prod t) IntSet -> [(Prod t, IntSet)]
forall k a. Map k a -> [(k, a)]
M.assocs Map (Prod t) IntSet
s2k ]
        sppf_edges :: Int
sppf_edges  = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Set (SPPFNode t) -> Int
forall a. Set a -> Int
S.size Set (SPPFNode t)
ts | (SPPFNode t
_, Set (SPPFNode t)
ts) <- Map (SPPFNode t) (Set (SPPFNode t))
-> [(SPPFNode t, Set (SPPFNode t))]
forall k a. Map k a -> [(k, a)]
M.assocs Map (SPPFNode t) (Set (SPPFNode t))
eMap ]
        gss_nodes :: Int
gss_nodes   = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ [Nt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Nt] -> Int) -> [Nt] -> Int
forall a b. (a -> b) -> a -> b
$ Map Nt [GSSEdge t] -> [Nt]
forall k a. Map k a -> [k]
M.keys Map Nt [GSSEdge t]
x2s| (Int
l,Map Nt [GSSEdge t]
x2s) <- GSS t -> [(Int, Map Nt [GSSEdge t])]
forall a. IntMap a -> [(Int, a)]
IM.assocs GSS t
gss] 
        gss_edges :: Int
gss_edges   = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ [GSSEdge t] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GSSEdge t]
s    | (Int
l,Map Nt [GSSEdge t]
x2s) <- GSS t -> [(Int, Map Nt [GSSEdge t])]
forall a. IntMap a -> [(Int, a)]
IM.assocs GSS t
gss
                                            , (Nt
x,[GSSEdge t]
s)   <- Map Nt [GSSEdge t] -> [(Nt, [GSSEdge t])]
forall k a. Map k a -> [(k, a)]
M.assocs Map Nt [GSSEdge t]
x2s ]
        sppf :: SPPF t
sppf@(IntMap (IntMap (Set (Symbol t)))
sMap, Ucal t
iMap, IntMap (IntMap (IntMap (Map (Prod t) IntSet)))
pMap, Map (SPPFNode t) (Set (SPPFNode t))
eMap) = Mutable t -> SPPF t
forall t. Mutable t -> SPPF t
mut_sppf Mutable t
mutable
        successes :: Int
successes = Counters -> Int
count_successes (Mutable t -> Counters
forall t. Mutable t -> Counters
mut_counters Mutable t
mutable)
    in SPPF t
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> String
-> ParseResult t
forall t.
SPPF t
-> Bool
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> String
-> ParseResult t
ParseResult SPPF t
sppf (Int
successes Int -> Int -> Bool
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 (Mutable t -> Counters
forall t. Mutable t -> Counters
mut_counters Mutable t
mutable)) Int
sppf_edges Int
gss_nodes Int
gss_edges (Input t -> Flags -> MisMatches t -> String
forall t. Parseable t => Input t -> Flags -> MisMatches t -> String
renderErrors Input t
inp Flags
flags (Mutable t -> MisMatches t
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    = [(Int, Set t)] -> [(Int, Set t)]
forall a. [a] -> [a]
reverse (MisMatches t -> [(Int, Set t)]
forall a. IntMap a -> [(Int, a)]
IM.assocs MisMatches t
mm)
        doc :: Doc
doc     = String -> Doc
text (String
"Unsuccessful parse, showing "String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" furthest matches") Doc -> Doc -> Doc
$+$
                    ((Int, Set t) -> Doc -> Doc) -> Doc -> [(Int, Set t)] -> Doc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int, Set t)
loc -> ((Int, Set t) -> Doc
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", where we find " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lexeme) Doc -> Doc -> Doc
$+$
                            Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"Found" Doc -> Doc -> Doc
<+> t -> 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 ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall {a}. Parseable a => a -> Doc
ppExp (Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
ts)))
         where  token :: t
token = Input t
inp Input t -> Int -> t
forall i e. Ix i => Array i e -> i -> e
A.! Int
k
                lexeme :: String
lexeme = (t -> String) -> [t] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap t -> String
forall a. Parseable a => a -> String
unlex (Int -> [t] -> [t]
forall a. Int -> [a] -> [a]
take Int
5 (Int -> [t] -> [t]
forall a. Int -> [a] -> [a]
drop Int
k (Input t -> [t]
forall i e. Array i e -> [e]
A.elems Input t
inp)))
        ppExp :: a -> Doc
ppExp a
t = String -> Doc
text (a -> String
forall a. Parseable a => a -> String
unlex a
t) Doc -> Doc -> Doc
<+> String -> Doc
text String
"AKA" Doc -> Doc -> Doc
<+> String -> Doc
text (a -> String
forall a. Show a => a -> String
show a
t)

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