packages feed

gll 0.2.0.3 → 0.3.0.0

raw patch · 17 files changed

+1495/−2071 lines, 17 filesdep +prettydep ~base

Dependencies added: pretty

Dependency ranges changed: base

Files

gll.cabal view
@@ -3,67 +3,56 @@  -- The name of the package. name:                gll-version:             0.2.0.3+version:             0.3.0.0 synopsis:            GLL parser with simple combinator interface  license:             BSD3 license-file:        LICENSE author:              L. Thomas van Binsbergen-maintainer:          ltvanbinsbergen@acm.org+maintainer:          L. Thomas van Binsbergen <ltvanbinsbergen@acm.org> category:            Compilers build-type:          Simple  cabal-version:       >=1.8 tested-with:         GHC == 7.6.3+copyright:           Copyright (C) 2015 L. Thomas van Binsbergen+stability:           experimental description:          -        GLL is a parser combinator library for writing generalised parsers.-        The user can write parsers for arbitrary context-free grammars, including -        both non-determinism and all forms of left and right-recursion.-        The underlying parsing algorithm is GLL (Scott and Johnstone 2013).-        .-        The library provides an interface in 'Control.Applicative' style: -        it uses the combinators '<*>', '<|>', '<$>' and derivations. -        With '<$>' arbitrary semantic actions are added to the parser. +        The package gll provides generalised top-down parsing according to the GLL+        parsing algorithm [Scott and Johnstone 2010,2013].          .-        Four functions can be used to run a parser: 'parse', 'parseString', -        'parseWithOptions' and 'parseStringWithOptions'. -        Function 'parse' relies on the builtin 'Token' datatype, receiving a list of-        'Token' as an input string. User-defined token-types are currently not supported. -        Function *parseString* enables parsing character-level parsing.-        The result of aparse is a list of semantic results, one result for each derivation. -        To avoid infinite recursion, only 'good parse trees' are considered (Ridge 2014).-        To limit the number of accepted derivation, and therefore avoiding potential-        exponential blow-up, 'GLL.Combinators.Options' are available to specify certain -        disambiguation rules.+        The user can either invoke the GLL+        parser directly by importing "GLL.Parser" and providing a+        value of the Grammar datatype in (exported by "GLL.Parser"). +        Alternatively, the user can import "GLL.Combinators" to write combinator expressions +        from which a grammar of the required form is extracted.+        The combinators enable applying arbitrary semantic actions to parse results.+        The documentation of the respective packages provides more information.         .-        'GLL.Combinators.MemInterface' is a memoised version of the library.-        Memoisation is used to speed up the process of applying semantic actions,-        it is not necessary for generalised parsing: -        'GLL.Combinators.Interface' and 'GLL.Combinators.MemInterface' are -        equally general.-        In the memoised version, parsers are no longer pure functions and must be -        developed inside the IO monad.+        The main motivation for this package+        is the development of Domain Specific Languages (DSLs).+        More specifically: designing DSLs with minimal differences between+        between abstract and concrete syntax (abstract syntax is often ambiguous).          .-        Examples can be found in the 'GLL.Combinators.Test' directory.+        Please email any questions, comments and suggestions to the +        maintainer.  library     hs-source-dirs  :   src-    build-depends   :     base >=4.5 && <= 4.8.0.0+    build-depends   :     base >=4.3.1.0 && <= 4.8.0.0                         , containers >= 0.4                         , array                         , TypeCompose+                        , pretty     exposed-modules :     GLL.Combinators.Interface-                        , GLL.Combinators.MemInterface-                        , GLL.Combinators.BinInterface-                        , GLL.Combinators.MemBinInterface                         , GLL.Combinators.Test.Interface-                        , GLL.Combinators.Test.MemInterface-                        , GLL.Combinators.Test.BinInterface-                        , GLL.Combinators.Test.MemBinInterface-    other-modules   :   GLL.Types.Abstract-                        , GLL.Types.Grammar+                        , GLL.Combinators                         , GLL.Parser+    other-modules   :   GLL.Types.Abstract                         , GLL.Combinators.Memoisation                         , GLL.Combinators.Options+                        , GLL.Types.Grammar+                        , GLL.Combinators.Visit.Grammar+                        , GLL.Combinators.Visit.Sem     extensions      : TypeOperators, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances-+    ghc-options:         -fwarn-incomplete-patterns -fwarn-monomorphism-restriction -fwarn-unused-imports
+ src/GLL/Combinators.hs view
@@ -0,0 +1,8 @@++-- |+-- "GLL.Combinators" imports "GLL.Combinators.Interface" as the default library.+module GLL.Combinators (+    module GLL.Combinators.Interface +    ) where++import GLL.Combinators.Interface
− src/GLL/Combinators/BinInterface.hs 
@@ -1,239 +0,0 @@-module GLL.Combinators.BinInterface (-    Parser,-    parse, parseString,-    char, token, Token(..),-    epsilon, satisfy,-    many,some,optional,-    (<::=>),(<:=>),-    (<$>),-    (<$),-    (<*>),-    (*>),-    (<*),-    (<|>),-) where--import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))--import GLL.Combinators.Options-import GLL.Types.Abstract-import GLL.Types.Grammar hiding (epsilon)-import GLL.Parser (gllSPPF,ParseResult(..))--import qualified    Data.Array  as A-import qualified    Data.IntMap as IM-import qualified    Data.Map    as M-import qualified    Data.Set    as S--type Visit1     = Symbol -type Visit2     = M.Map Nt [Alt] -> M.Map Nt [Alt]-type Visit3 a   = PCOptions -> A.Array Int Token -> ParseContext -> SPPF -                    -> Int -> Int -> Int -> S.Set a--type Parser a   = (Visit1, Visit2, Visit3 a)--type ParseContext = IM.IntMap (IM.IntMap Nt)---- | Given a parser and a string of tokens, return:---  * The grammar (GLL.Types.Abstract)---  * a list of results, which are all semantic evaluations of 'good derivations'---      - semantic evaluations are specified by using <$> and satisfy---      - 'good derivations' as defined by by Tom Ridge-parse' :: PCOptions -> Parser a -> [Token] -> (Grammar, ParseResult, [a])-parse' opts (Nt start,rules,sem) str = -    let cfg     = Grammar start [] [ Rule x alts  -                                   | (x, alts) <- M.assocs (rules M.empty) ]-        parse_r = gllSPPF cfg str-        sppf    = sppf_result parse_r-        as      = sem opts arr IM.empty sppf 0 m m-        m       = length str-        arr     = A.array (0,m) (zip [0..] str)-    in (cfg,parse_r,S.toList as)---- | The grammar of a given parser-grammar :: Parser a -> Grammar-grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])---- | The semantic results of a parser, given a token string-parse :: Parser a -> [Token] -> [a]-parse = parseWithOptions defaultOptions ---- | The semantic results of a parser, given a token string ---      and GLL.Combinator.Options-parseWithOptions :: PCOptions -> Parser a -> [Token] -> [a]-parseWithOptions opts p str = (\(_,_,t) -> t) (parse' opts  p str)---- | Get the SPPF produced by parsing the given input with the given parser-sppf :: Parser a -> [Token] -> ParseResult-sppf p str =  (\(_,s,_) -> s) (parse' defaultOptions p str)---- | Parse a given string of characters -parseString :: Parser a -> [Char] -> [a]-parseString p = parse p . charS---- | Parse a given string of characters and options -parseStringWithOptions :: PCOptions -> Parser a -> [Char] -> [a]-parseStringWithOptions opts p = parseWithOptions opts p . charS-infixl 3 <::=>--- | use <::=> to enforce using parse context (to handle left-recursion)-(<::=>) :: String -> Parser a -> Parser a-x <::=> _r = let (sym,_r_rules,_r_sem) = _r-                 alt     = Alt x [sym] -- TODO indirection (extra alt)-                 rules m = case M.lookup x m of-                            Nothing -> _r_rules (M.insert x [alt] m)-                            Just _  -> m--                 sem opts arr ctx sppf l r m-                    | (l,r,x) `inContext` ctx = S.empty-                    | otherwise = let ctx' = (l,r,x) `toContext` ctx-                                   in _r_sem opts arr ctx' sppf l r m-              in (Nt x,rules,sem)---- | useful for non-recursive definitions (only internally)-infixl 3 <:=>-(<:=>) :: String -> Parser a -> Parser a-x <:=> _r = let (sym,_r_rules,_r_sem) = _r-                alt     = Alt x [sym] -- TODO indirection (extra alt)-                rules m = case M.lookup x m of-                          Nothing -> _r_rules (M.insert x [alt] m)-                          Just _  -> m-              in (Nt x,rules,_r_sem)--infixl 5 <$>--- | Application of a semantic action. -(<$>) :: (Ord b, Ord a) => (a -> b) -> Parser a -> Parser b-f <$> _r = let (sym,rules,_r_sem) = _r-               sem opts arr ctx sppf l r m = S.map f (_r_sem opts arr ctx sppf l r m)-            in (sym,rules,sem)--infixl 6 <*>--- | Sequence two parsers, the results of the two parsers are tupled.-(<*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser (a,b)-_l <*> _r = (Nt lhs_id,rules,sem)- where  l_id    = id_ _l-        r_id    = id_ _r-        lhs_id  = concat [l_id, "*", r_id]-        -        -- ** one can bind this parser and recurse on it + other duplicate work-        alt     = Alt lhs_id [sym_ _l, sym_ _r]-        rules m = case M.lookup lhs_id m of -- necessary? **-                    Nothing -> rules_ _r (rules_ _l (M.insert lhs_id [alt] m))-                    Just _  -> m-        -        sem opts arr ctx sppf l r m = -            let filter = maybe id id $ pivot_select opts in S.fromList-            [ (a,b) | k <- filter ks-                    , a <- S.toList (sem_ _l opts arr ctx sppf l k m)-                    , b <- S.toList (sem_ _r opts arr ctx sppf k r m) ]-         where ks = maybe [] id $ sppf `pNodeLookup` ((alt,2), l, r)--infixl 4 <|>--- | A choice between two parsers, results of the two are concatenated-(<|>) :: (Ord a) => Parser a -> Parser a -> Parser a-_l <|> _r = (Nt lhs_id,rules,sem)- where  l_id    = id_ _l-        r_id    = id_ _r-        lhs_id  = concat [l_id, "|", r_id]--        alts    = [Alt lhs_id [sym_ _l], Alt lhs_id [sym_ _r]]-        rules m = case M.lookup lhs_id m of-                    Nothing -> rules_ _r (rules_ _l (M.insert lhs_id alts m))-                    Just _  -> m--        sem opts arr ctx sppf l r m =  -            concatChoice opts (sem_ _l opts arr ctx sppf l r m)-                              (sem_ _r opts arr ctx sppf l r m)---- derived combinators-infixl 6 <*--- | Sequencing, ignoring the result to the right-(<*) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser a-_l <* _r = (\(x,y) -> x) <$> _l <*> _r--infixl 6 *>--- | Sequencing, ignoring the result to the left -(*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser b-_l *> _r = (\(x,y) -> y) <$> _l <*> _r--infixl 5 <$--- | Ignore all results and just return the given value-(<$) :: (Ord a, Ord b) => a -> Parser b -> Parser a-f <$ _r = const f <$> _r ---- elementary parsers-raw_parser :: String -> Token -> (Token -> a) -> Parser a-raw_parser str t f = (Nt str, rules, sem)-    where   alt     = Alt str [Term t]-            rules   = M.insert str [alt] -            sem _ arr ctx sppf l r m -                | l + 1 == r && l < m && arr A.! l == t = S.singleton (f t)-                | otherwise = S.empty---- | A parser that recognises a given character-char :: Char -> Parser Char-char c = raw_parser ([c]) (Char c) (\(Char c) -> c)---- | A parser that recognises a given token-token :: Token -> Parser Token-token t = raw_parser (show t) t id---- | A parser that always succeeds (and returns unit)-epsilon :: Parser ()-epsilon = (Nt x, rules, sem)-    where   x       = "__eps"-            alt     = Alt x [Term Epsilon]-            rules   = M.insert x [alt]-            sem _ arr ctx sppf l r m  | l == r    = S.singleton ()-                                      | otherwise = S.empty---- | A parser that always succeeds and returns a given value-satisfy :: (Ord a) => a -> Parser a-satisfy a = a <$ epsilon---- helpers-sym_ :: Parser a -> Symbol-sym_ (f,_,_) = f--id_   :: Parser a -> Nt -id_ (Nt x,_,_)   = x--rules_ :: Parser a -> Visit2-rules_ (_,f,_) = f--sem_   :: Parser a -> Visit3 a-sem_ (_,_,f)   = f--mkNt :: String -> Char -> Nt-mkNt x c = concat ["(",x,")",[c]]--inContext :: (Int, Int, Nt) -> ParseContext -> Bool-inContext (l,r,x) = maybe False inner . IM.lookup l -    where inner = maybe False ((==) x) . IM.lookup r--toContext :: (Int, Int, Nt) -> ParseContext -> ParseContext-toContext (l,r,x) = IM.insertWith IM.union l (IM.singleton r x)--concatChoice :: (Ord a) => PCOptions -> S.Set a -> S.Set a -> S.Set a-concatChoice opts ls rs = if left_biased_choice opts-                            then firstRes-                            else ls `S.union` rs- where  firstRes | S.null ls  = rs-                 | otherwise  = ls---- higher level patterns---- | Optionally use the given parser-optional :: (Ord a) => Parser a -> Parser (Maybe a)-optional p@(Nt x,_,_) = (mkNt x '?') <:=> satisfy Nothing <|> Just <$> p---- | Apply the given parser many times, 0 or more times (Kleene closure)-many :: (Ord a) => Parser a -> Parser [a]-many p@(Nt x,_,_) = (mkNt x '^') <::=> satisfy [] -                                   <|> uncurry (:) <$> p <*> many p---- | Apply the given parser some times, 1 or more times (positive closure)-some :: (Ord a) => Parser a -> Parser [a]-some p@(Nt x,_,_) = let rec = (mkNt x '+') <::=> (:[]) <$> p-                                            <|> uncurry (:) <$> p <*> rec-                    in rec-
src/GLL/Combinators/Interface.hs view
@@ -1,289 +1,581 @@ {-# LANGUAGE TypeOperators, FlexibleInstances #-} -module GLL.Combinators.Interface (-    SymbParser, IMParser, -    HasAlts(..), IsSymbParser(..), IsIMParser(..),-    parse, parseString, -    char, token,Token(..),-    epsilon, satisfy,-    many, some, optional,-    (<::=>),(<:=>),-    (<$>),-    (<$),-    (<*>),-    (<*),-    (<|>),-    (:.)-    ) where+{-| +This module provides a combinator library in which combinators act as an interface+to a back-end parser. This technique is inspired by Tom Ridge (2014) and + Peter Ljunglöf (2002).+The library is fully general: it enables writing parsers for arbitrary context-free+grammars. -import Prelude hiding ((<*>), (<*), (<$>), (<$))+The user writes a combinator expression representing a grammar.+The represented grammar is extracted and given, together with an input string,+to a back-end parser.+The derivations constructed by the parser act as a guide in the "semantic phase"+in which the combinator expressions are evaluated to produce semantic results+for all derivations. Infinitely many derivations would result in a loop. +This problem is avoided by discarding the derivations that would arise from such a loop. -import GLL.Combinators.Options-import GLL.Types.Grammar hiding (epsilon)-import GLL.Types.Abstract-import GLL.Parser (gllSPPF, pNodeLookup, ParseResult(..))+This library uses "GLL.Parser" as the back-end parser and provides +"Control.Applicative"-like parser combinators: '<**>' for sequencing, '<||>' for +choice, '<$$>' for application, 'satisfy' instead of pure and derived +combinators '<**', '**>', '<$$', 'many', 'some' and 'optional'. -import Control.Compose ((:.)(..),unO)-import Control.Monad-import Data.List (unfoldr,intersperse)-import qualified Data.IntMap as IM-import qualified Data.Map as M-import qualified Data.Set as S+The semantic phase might benefit from memoisation which is provided in a separate (impure)+library "GLL.Combinators.MemInterface".  --- | A parser expression representing a symbol.-data SymbParser b = SymbParser (SymbVisit1 b,SymbVisit2 b, SymbVisit3 b)--- | A parser expression representing an alternative (right-hand side).-data IMParser b   = IMParser (IMVisit1 b, IMVisit2 b, IMVisit3 b)+=== Example usage+This library differs from parser combinator libraries in that combinator expressions+are used to describe a grammar rather than a parser. --- | The represented symbol.-type SymbVisit1 b = Symbol --- | Add the rules of this symbol to the given map--- If the symbol is a terminal, no rules will be added (identity function)-type SymbVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt]-type SymbVisit3 b = PCOptions -> ParseContext -> SPPF -> Int -> Int -> [b]+A rule is considered to be of the form X ::= a | .. | z, and represented by the combinator+expression. -type IMVisit1 b   = [Symbol] -type IMVisit2 b   = M.Map Nt [Alt] -> M.Map Nt [Alt]-type IMVisit3 b   = PCOptions -> (Alt,Int) -> ParseContext -> SPPF -> Int -> Int -> [b]+@+pX = "X" '<::=>' altA '<||>' ... '<||>' altZ+@ -type ParseContext = IM.IntMap (IM.IntMap (S.Set Nt))+Alternates ('a' ... 'z') start with the application of +a semantic action using '<$$>' (or variants '<$$' and 'satisfy'). +The alternate is extended with '<**>' (or variants '**>', '<**'). +@+altA = action1 '<$$>' 'keychar' \'a\' '<**>' pX+altZ = action2 '<$$>' 'keychar' \'z\'+@ -parse' :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> (Grammar, ParseResult, [a])-parse' opts p' input' =  -    let input               = input' ++ [Char 'z']-        SymbParser (Nt start,vpa2,vpa3) = toSymb (id <$> p' <* char 'z')-        snode               = (start, 0, m)-        m                   = length input-        rules               = vpa2 M.empty-        as                  = vpa3 opts IM.empty sppf 0 m-        grammar = Grammar start [] [ Rule x alts | (x, alts) <- M.assocs rules ]-        parse_res           = gllSPPF grammar input-        sppf                = sppf_result parse_res-    in (grammar, parse_res, as)+Usability is improved by automatic lifting between expressions that represent symbols+and alternates. The main difference with "Control.Applicative" style parser combinator+libraries is that the user must use '<:=>' (or '<::=>') to represent all recursive +nonterminals and must use '<::=>' to represent all nonterminals that potentially lead+to an infinite number of derivations. It is, however, possible to represent left-recursive+nonterminals. --- | The grammar of a given parser-grammar :: (IsSymbParser s) => s a -> Grammar-grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])+=== Example --- | The semantic results of a parser, given a string of Tokens-parse :: (IsSymbParser s) => s a -> [Token] -> [a]-parse = parseWithOptions defaultOptions +In this example we define expressions for parsing (and evaluating) simple arithmetic +expressions for single digit integers.  --- | Change the behaviour of the parse using GLL.Combinators.Options-parseWithOptions :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> [a]-parseWithOptions opts p = (\(_,_,t) -> t) . parse' opts p+The library is capable of parsing arbitrary token types that are 'Parseable', orderable+and have a 'Show' instance.+This example demonstrates the usage of the builtin 'Token' datatype and uses the+elementary parsers 'keychar' and 'int_lit' to create parsers for character- and integer-terminals. --- | Parse a string of characters-parseString :: (IsSymbParser s) => s a -> String -> [a]-parseString = parseStringWithOptions defaultOptions+We define a very simpler lexer first. --- | Parse a string of characters using options-parseStringWithOptions :: (IsSymbParser s) => PCOptions -> s a -> String -> [a]-parseStringWithOptions opts p  = parseWithOptions opts p . map Char+@+lexer :: String -> [Token]+lexer [] = []+lexer (x:xs)+    | isDigit x = 'IntLit' (Just (read [x])) : lexer xs+    | otherwise = 'Char' x                   : lexer xs+@ +Note that the Char constructor of the 'Token' type is used for character-level parsing.+Char contains no lexeme, unlike the Int constructor.++Consider the following (highly ambiguous and left-recursive) grammar:++@+Expr ::= Expr \'-\' Expr+       | Expr \'+\' Expr+       | Expr \'*\' Expr+       | Expr \'/\' Expr+       | INT+       | \'(\' Expr \')\'+@++The grammar is translated to the following combinator expression, adding the expected+evaluation functions as semantic actions.++@+pExpr :: Grammar Token Int+pExpr = \"Expr\" <::=> (-) '<$$>' pExpr '<**' 'keychar' \'-\' '<**>' pExpr+              '<||>' (+) '<$$>' pExpr '<**' 'keychar' \'+\' '<**>' pExpr+              '<||>' (*) '<$$>' pExpr '<**' 'keychar' \'*\' '<**>' pExpr+              '<||>' div '<$$>' pExpr '<**' 'keychar' \'/\' '<**>' pExpr+              '<||>' 'int_lit'+              '<||>' parens pExpr+@++Note that '<**' is used to ignore the parse result of the second argument and that '**>' +is used to ignore the parse result of the first argument. These combinators+help us to define the /derived combinator/s /within/ and /parens/.++@+within :: 'BNF' 'Token' a -> 'BNF' 'Token' b -> 'BNF' 'Token' a -> 'BNF' 'Token' b+within l p r = 'mkRule' $ l '**>' p '<**' r++parens :: 'BNF' 'Token' a -> 'BNF' 'Token' a+parens p = within ('keychar' '(') p ('keychar' ')')+@++All possible evaluations are obtained by invoking the 'parse' function.++@+run1 = 'parse' pExpr (lexer "1+2*2-5")            -- [0,1,0,-5,-9] +run2 = 'parse' pExpr (lexer "((1+(2*2))-3)-5")    -- [-3]+@++With every introduction of an operator '+', '-', '*' or '/' the number of ambiguities is +multiplied. The number of ambiguities behaves like the sequence https://oeis.org/A000108.++=== Simple disambiguation++This library offers simple disambiguation strategies that are applied post-parse +(the parser still faces the ambiguity, but the semantic evaluation only yields +the results according to the strategy). The disambiguations strategies are still+in the /experimental/ phase. ++We group the operators according to their priorities and use +'<::=' to turn the choice operator '<||>' into a left-biased operator locally+(use 'leftBiased' for the same effect globally).++@+pExpr1 :: Grammar Token Int+pExpr1 = \"Expr\" '<::='  (      (-) '<$$>' pExpr1 '<**' 'keychar' \'-\' '<**>' pExpr1+                        '<||>' (+) '<$$>' pExpr1 '<**' 'keychar' \'+\' '<**>' pExpr1 )+                 '<||>' (      (*) '<$$>' pExpr1 '<**' 'keychar' \'*\' '<**>' pExpr1+                        '<||>' div '<$$>' pExpr1 '<**' 'keychar' \'/\' '<**>' pExpr1 )+                 '<||>' (      'int_lit'+                        '<||>' 'parens' pExpr1 )++run3 = 'parseWithOptions' ['maximumPivotAtNt'] pExpr1 (lexer "1+2*2-5") -- [0]+@++The option 'maximumPivotAtNt' enables the 'longest-match' disambiguation strategy +and makes the arithmetic operators left-associative.++=== Grammar rewrites++To deal with the particular ambiguities associated with operators we can +rewrite the grammar to disambiguate pre-parse.++We define the /chainl/ combinator for parsing chains of left-associative operators.++@+chainl :: 'BNF' 'Token' a -> 'BNF' 'Token' (a -> a -> a) -> 'BNF' 'Token' a+chainl p s = 'mkRule' $+    foldl (flip ($)) '<$$>' p '<**>' many (flip '<$$>' s '<**>' p)+@++The expression parser is written with chainl as follows:++@+pExpr2 :: Grammar Token Int+pExpr2 = pE1+ where  pE1 = chainl pE2 (\"E1\" '<::=>' (+) '<$$' 'keychar' \'+\' '<||>' (-) '<$$' 'keychar' \'-\')+        pE2 = chainl pE3 (\"E2\" '<::=>' (*) '<$$' 'keychar' \'*\' '<||>' div '<$$' 'keychar' \'/\')+        pE3 = \"E3\" '<::=>' 'int_lit' '<||>' parens pExpr2++run4 = 'parse' 'pExpr2' (lexer "1+2*2-5")       -- [0]+@++Pre-parse disambiguation is desirable, as the parsing process could +speed up dramatically. In general however, it is not always possible to find +the appropriate grammar rewrite and implement it in a high-level combinator such +as chainl, /motivating the existence of this library/.++More simple examples can be found in "GLL.Combinators.Test.Interface".++-}+module GLL.Combinators.Interface (+    -- * Elementary parsers+    term_parser, satisfy,+    -- ** Elementary parsers using the 'Token' datatype +    keychar, keyword, int_lit, bool_lit, string_lit, id_lit, token,+    -- ** Elementary character-level parsers+    char, +    -- * Elementary combinators+    -- *** Sequencing+    (<**>),+    -- *** Choice+    (<||>),+    -- *** Semantic actions+    (<$$>),+    -- *** Nonterminal introduction+    (<:=>),(<::=>),+    -- * Types+    -- ** Grammar (combinator expression) types+    BNF, SymbExpr, AltExpr, AltExprs,+    -- ** Parseable token types +    Token(..), Parseable(..), +    -- * Running a parser +    parse,+    -- **  Running a parser with disambiguation options+    parseWithOptions,+    -- *** Possible options+    Options, Option, leftBiased, maximumPivot, maximumPivotAtNt,+             GLL.Combinators.Options.maximumErrors, throwErrors,+    -- * Derived combinators+    mkNt, +    -- *** Ignoring semantic results+    (<$$), (**>), (<**),+    -- *** Post-parse disambiguation+    (<::=),+    -- *** EBNF patterns+    optional, many, some,+     -- * Lifting+    HasAlts(..), IsSymbExpr(..), IsAltExpr(..),+     -- * Memoisation+    memo, newMemoTable, memClear, MemoTable, MemoRef, useMemoisation,+    ) where++import GLL.Combinators.Options+import GLL.Combinators.Visit.Sem+import GLL.Combinators.Visit.Grammar+import GLL.Combinators.Memoisation+import GLL.Types.Abstract+import GLL.Parser hiding (parse, parseWithOptions)+import qualified GLL.Parser as GLL++import Control.Arrow+import Control.Compose (OO(..),unOO)+import Data.List (intersperse)+import qualified Data.Array as A+import qualified Data.IntMap as IM+import qualified Data.Map as M+import Data.IORef +import System.IO.Unsafe++-- | A combinator expression representing a symbol.+-- A 'SymbExpr' either represents a terminal or a nonterminal.+-- In the latter case it is constructed with (a variant of) '<:=>' and +-- adds a rule to the grammar of which the represented symbol is the +-- left-hand side.+data SymbExpr t a = SymbExpr (Symbol t, Grammar_Expr t, Sem_Symb t a)+-- | A combinator expression representing a BNF-grammar. The terminals of+-- the grammar are of type 't'. When used to parse, the expression yields+-- semantic results of type 'a'. +type BNF t a = SymbExpr t a+-- | +-- A combinator expression representing an alternative: +-- the right-hand side of a production.+data AltExpr t a = AltExpr ([Symbol t], Grammar_Expr t, Sem_Alt t a)++-- | A list of alternatives represents the right-hand side of a rule.+type AltExprs = OO [] AltExpr++parse' :: (Show t, Parseable t, IsSymbExpr s) => +            PCOptions -> s t a -> [t] -> (Grammar t, ParseResult t, Either String [a])+parse' opts p' input =  +    let SymbExpr (Nt start,vpa2,vpa3) = mkRule ("__Start" <:=> OO [id <$$> p'])+        snode       = (start, 0, m)+        m           = length input+        rules       = vpa2 M.empty+        as          = vpa3 opts IM.empty sppf arr 0 m+        grammar     = (start, [ p | (_, alts) <- M.assocs rules, p <- alts ])+        max_err     = max_errors opts+        parse_res   = GLL.parseWithOptions [strictBinarisation, packedNodesOnly, GLL.maximumErrors max_err] grammar input+        sppf        = sppf_result parse_res+        arr         = A.array (0,m) (zip [0..] input)+    in (grammar, parse_res, if res_success parse_res +                            then Right $ unsafePerformIO as+                            else Left (error_message parse_res) )++-- | The grammar of a given parser+grammar :: (Show t, Parseable t, IsSymbExpr s) => s t a -> Grammar t+grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])+ -- | Get the SPPF produced by parsing the given input with the given parser-sppf :: (IsSymbParser s) => s a -> [Token] -> ParseResult+sppf :: (Show t, Parseable t, IsSymbExpr s) => +            s t a -> [t] -> ParseResult t sppf p str =  (\(_,s,_) -> s) $ parse' defaultOptions p str -inParseContext :: ParseContext -> (Symbol, Int, Int) -> Bool-inParseContext ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx- where  inner = maybe False (S.member x) . IM.lookup r+-- | +-- Runs a parser given a string of 'Parseable's and returns a list of +-- semantic results, corresponding to all finitely many derivations.+parse :: (Show t, Parseable t, IsSymbExpr s) => s t a -> [t] -> [a]+parse = parseWithOptions []  -toParseContext :: ParseContext -> (Nt, Int, Int) -> ParseContext-toParseContext ctx (x, l, r) = IM.alter inner l ctx- where  inner mm = case mm of -                    Nothing -> Just $ singleRX-                    Just m  -> Just $ IM.insertWith (S.union) r singleX m-        singleRX = IM.singleton r singleX-        singleX  = S.singleton x+-- | +-- Run the parser with some 'Options'.+parseWithOptions :: (Show t, Parseable t, IsSymbExpr s) => +                        Options -> s t a -> [t] -> [a]+parseWithOptions opts p ts = +    case parseWithOptionsAndError opts p ts of+        Left str | throw_errors opts'   -> error str+                 | otherwise            -> []+        Right as                        -> as+    where opts' = runOptions opts+-- | +-- Run the parser with some 'Options' and return either an error or the results.+-- Any returned results will be a list of length greater than 0.+parseWithOptionsAndError :: (Show t, Parseable t, IsSymbExpr s) => +                        Options -> s t a -> [t] -> Either String [a]+parseWithOptionsAndError opts p = (\(_,_,t) -> t) . parse' (runOptions opts) p +infixl 2 <:=>+-- | +-- Form a rule by giving the name of the left-hand side of the new rule.+-- Use this combinator on recursive non-terminals.+(<:=>) :: (Show t, Ord t, HasAlts b) => Nt -> b t a -> SymbExpr t a +x <:=> altPs = mkNtRule False False x altPs infixl 2 <::=>--- | Use this combinator on all combinators that might have an infinite---  number of derivations for some input string. A non-terminal has---  this property if and only if it is left-recursive and would be++-- | +--  Variant of '<:=>' for recursive non-terminals that have a potentially infinite+--  number of derivations for some input string.+--+--  A non-terminal yields infinitely many derivations  +--  if and only if it is left-recursive and would be --  left-recursive if all the right-hand sides of the productions of the --  grammar are reversed.-(<::=>) :: (HasAlts b) => String -> b a -> SymbParser a -x <::=> altPs' =-    let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ]-        alts  = map (Alt x) vas1    -        altPs = unO $ altsOf altPs' in SymbParser-        (Nt x-       ,\rules ->-           if x `M.member` rules -            then rules -            else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs)-       ,\opts ctx sppf l r -> -        let ctx' = ctx `toParseContext` (x,l,r)-            vas2 = [ va3 opts (alt,length rhs) ctx' sppf l r -                   | (alt@(Alt _ rhs), va3) <- zip alts (map (\(IMParser (_,_,t)) -> t) altPs) ]-        in if ctx `inParseContext` (Nt x, l, r) -                then []-                else concatChoice opts vas2-       )--infixl 2 <:=>--- | Use this combinator on all recursive non-terminals-(<:=>) :: (HasAlts b) => String -> b a -> SymbParser a -x <:=> altPs' =-    let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ]-        alts  = map (Alt x) vas1    -        altPs = unO $ altsOf altPs' in SymbParser-        (Nt x-       ,\rules ->-           if x `M.member` rules -            then rules -            else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs)-       ,\opts ctx sppf l r -> -        let vas2 = [ va3 opts (alt,length rhs) ctx sppf l r -                   | (alt@(Alt _ rhs), va3) <- zip alts (map (\(IMParser (_,_,t)) -> t) altPs) ]-        in concatChoice opts vas2-       )+(<::=>) :: (Show t, Ord t, HasAlts b) => Nt -> b t a -> SymbExpr t a +x <::=> altPs = mkNtRule True False x altPs -concatChoice :: PCOptions -> [[a]] -> [a]-concatChoice opts ress = if left_biased_choice opts-                            then firstRes ress-                            else concat ress- where  firstRes []         = []-        firstRes ([]:ress)  = firstRes ress-        firstRes (res:_)    = res+mkNtRule :: (Show t, Ord t, HasAlts b) => Bool -> Bool -> Nt -> b t a -> SymbExpr t a+mkNtRule use_ctx left_biased x altPs' =+    let vas1 = map (\(AltExpr (f,_,_)) -> f) altPs +        vas2 = map (\(AltExpr (_,s,_)) -> s) altPs+        vas3 = map (\(AltExpr (_,_,t)) -> t) altPs+        alts  = map (Prod x) vas1    +        altPs = altsOf altPs'+    in SymbExpr (Nt x, grammar_nterm x alts vas2, sem_nterm use_ctx left_biased x alts vas3) -infixl 4 <*>-(<*>) :: (IsIMParser i, IsSymbParser s) => i (a -> b) -> s a -> IMParser b-pl' <*> pr' = -  let IMParser (vimp1,vimp2,vimp3) = toImp pl'-      SymbParser (vpa1,vpa2,vpa3)  = toSymb pr' in IMParser-  (vimp1++[vpa1]-  ,\rules ->  let rules1  = vpa2 rules-                  rules2  = vimp2 rules1 in rules2-  ,\opts (alt@(Alt x rhs),j) ctx sppf l r ->-    let ks     = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)-        filter = maybe id id $ pivot_select opts-    in [ a2b a  | k <- (filter ks)  , a <- vpa3 opts ctx sppf k r-                                    , a2b <- vimp3 opts(alt,j-1) ctx sppf l k ]-  )+infixl 4 <$$>+-- |+-- Form an 'AltExpr' by mapping some semantic action overy the result+-- of the second argument.+(<$$>) :: (Show t, Ord t, IsSymbExpr s) => (a -> b) -> s t a -> AltExpr t b+f <$$> p' = +    let SymbExpr (vpa1,vpa2,vpa3) = mkRule p' in AltExpr+          ([vpa1],grammar_apply vpa2, sem_apply f vpa3)  +infixl 4 <**>+-- | +-- Add a 'SymbExpr' to the right-hand side represented by an 'AltExpr'+-- creating a new 'AltExpr'. +-- The semantic result of the first argument is applied to the second +-- as a cross-product. +(<**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => +            i t (a -> b) -> s t a -> AltExpr t b+pl' <**> pr' = +  let AltExpr (vimp1,vimp2,vimp3) = toAlt pl'+      SymbExpr (vpa1,vpa2,vpa3)  = mkRule pr' in AltExpr+  (vimp1++[vpa1], grammar_seq vimp2 vpa2, sem_seq vimp3 vpa3) -infixl 4 <*-(<*) :: (IsIMParser i, IsSymbParser s) => i b -> s a -> IMParser b+infixr 3 <||>+-- |+-- Add an 'AltExpr' to a list of 'AltExpr'+-- The resuling  '[] :. AltExpr' forms the right-hand side of a rule.+(<||>) :: (Show t, Ord t, IsAltExpr i, HasAlts b) => i t a -> b t a -> AltExprs t a+l' <||> r' = let l = toAlt l'+                 r = altsOf r'+             in OO (l : r) -pl' <* pr' = -  let IMParser (vimp1,vimp2,vimp3) = toImp pl'-      SymbParser (vpa1,vpa2,vpa3)  = toSymb pr' in IMParser-  (vimp1++[vpa1]-  ,\rules ->-    let rules1  = vpa2 rules-        rules2  = vimp2 rules1-    in rules2-  ,\opts (alt@(Alt x rhs),j) ctx sppf l r ->-    let ks      = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)-        filter  = maybe id id $ pivot_select opts-    in [ b | k <- (filter ks)   , a <- vpa3 opts ctx sppf k r-                                , b <- vimp3 opts (alt,j-1) ctx sppf l k ]-  )+-- | Create a symbol-parse for a terminal given:+--+--  * The 'Parseable' token represented by the terminal.+--  * A function from that 'Parseable' to a semantic result.+term_parser :: t -> (t -> a) -> SymbExpr t a +term_parser t f = SymbExpr (Term t, id,\_ _ _ arr l _ -> return [f (arr A.! l)]) -infixl 4 <$>-(<$>) :: (IsSymbParser s) => (a -> b) -> s a -> IMParser b-f <$> p' = -    let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser-      ([vpa1]-      ,\rules -> -        vpa2 rules-      ,\opts (alt,j) ctx sppf l r ->-        let a = vpa3 opts ctx sppf l r-        in maybe [] (const (map f a)) $ sppf `pNodeLookup` ((alt,1),l,r)-      )+-- | Parse a single character.+--+-- @+-- char c = term_parser c id+-- @+--+-- Currently, this is the only character-level combinator exported+-- by this module. Please use token-level combinators for practical parsing.+-- Might change in the future.+char :: Char -> SymbExpr Char Char+char c = term_parser c id+{-+-- | Parse a list of characters.+string :: [Char] -> SymbExpr Char [Char]+string [] = mkRule $ satisfy []+string (c:cs) = mkRule $ (:) <$$> char c <**> string cs -infixl 4 <$-(<$) :: (IsSymbParser s) => b -> s a -> IMParser b-f <$ p' = -    let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser -      ([vpa1]-      ,\rules -> -        vpa2 rules-      ,\opts (alt,j) ctx sppf l r ->-        let a = vpa3 opts ctx sppf l r-        in maybe [] (const (map (const f) a)) $ sppf `pNodeLookup` ((alt,1),l,r)-      )+-- | +-- Apply a parser within two other parsers.+within :: BNF Char a -> BNF Char b -> BNF Char c -> BNF Char b+within l p r = mkRule $ l *> p <* r -infixr 3 <|>-(<|>) :: (IsIMParser i, HasAlts b) => i a -> b a -> ([] :. IMParser) a-l' <|> r' = let l = toImp l'-                r = altsOf r'-            in O (l : unO r)+-- | +-- Apply a parser within parentheses.+-- parens p = within (char '(') p (char ')')+parens :: BNF Char a -> BNF Char a +parens p = within (char '(') p (char ')')+-} -raw_parser :: Token -> (Token -> a) -> SymbParser a -raw_parser t f = SymbParser (Term t, id,\_ _ _ _ _ -> [f t])+-- | Parse a single character, using the 'Token' datatype.+keychar :: Char -> SymbExpr Token Char+keychar c = term_parser (Char c) (const c)        -- helper for Char tokens -token :: Token -> SymbParser Token-token t = raw_parser t id +-- | Parse a single character, using the 'Token' datatype.+keyword :: String -> SymbExpr Token String+keyword k = term_parser (Keyword k) (const k)        -- helper for Char tokens -char :: Char -> SymbParser Char-char c = raw_parser (Char c) (\(Char c) -> c) +-- | Parse a single integer, using the 'Token' datatype.+-- Returns the lexeme interpreted as an integer.+int_lit :: SymbExpr Token Int+int_lit  = term_parser (IntLit Nothing) unwrap+ where  unwrap (IntLit (Just i))  = i+        unwrap _                  = error "int_lit: the token must store lexeme" -epsilon :: SymbParser ()-epsilon = raw_parser (Epsilon) (\_ -> ()) +-- | Parse a single Boolean, using the 'Token' datatype.+-- Returns the lexeme interpreter as a Boolean.+bool_lit :: SymbExpr Token Bool+bool_lit  = term_parser (BoolLit Nothing) unwrap+ where  unwrap (BoolLit (Just b))  = b+        unwrap _                   = error "bool_lit: the token must store lexeme" -satisfy :: a -> IMParser a-satisfy a = a <$ epsilon+-- | Parse a single String literal, using the 'Token' datatype.+-- Returns the lexeme interpreted as a String literal.+string_lit :: SymbExpr Token String+string_lit  = term_parser (StringLit Nothing) unwrap+ where  unwrap (StringLit (Just i)) = i+        unwrap _                    = error "string_lit: the token must store lexeme" -many :: SymbParser a -> SymbParser [a]-many p = SymbParser f- where  SymbParser (myx,_,_) = p-        SymbParser f = many_ ("(" ++ show myx ++ ")^") p+-- | Parse a single identifier, using the 'Token' datatype.+-- Returns the lexeme as a String+id_lit :: SymbExpr Token String+id_lit = term_parser (IDLit Nothing) unwrap+ where  unwrap (IDLit (Just i)) = i+        unwrap _                = error "id_lit: the token must store lexeme" -many_ x p = x <:=> (:) <$> p <*> many_ x p <|> [] <$ epsilon+-- | Parse a single arbitrary token, using the 'Token' datatype.+-- Returns the lexeme.+token :: String -> SymbExpr Token String+token name = term_parser (Token name Nothing) unwrap+ where  unwrap (Token name' (Just i)) | name == name' = i+        unwrap _                                      = error "tokenT: the token must store the lexeme" -some :: SymbParser a -> SymbParser [a]-some p = SymbParser f- where  SymbParser (myx,_, _) = p-        SymbParser f = some_ ("(" ++ show myx ++ ")+") p +epsilon :: (Show t, Ord t) => AltExpr t ()+epsilon = AltExpr ([], M.insert x [Prod x []],\_ _ _ _ _ l r -> +                        if l == r then return [(l,())] else return [] )+    where x = "__eps" -some_ x p = x <:=> (:) <$> p <*> some_ x p <|> (:[]) <$> p+-- | The empty right-hand side that yields its +--  first argument as a semantic result.+satisfy :: (Show t, Ord t ) => a -> AltExpr t a+satisfy a = a <$$ epsilon -optional :: SymbParser a -> SymbParser (Maybe a)-optional p = SymbParser f-    where SymbParser (myx, _, _) = p -          SymbParser f = optional_ ("(" ++ show myx ++ ")?") p+-- | +-- This function memoises a parser, given:+--+-- * A 'MemoRef' pointing to a fresh 'MemoTable', created using 'newMemoTable'.+-- * The 'SymbExpr' to memoise.+--+-- Use 'memo' on all parsers that are expected to derive the same +-- substring multiple times. If the same combinator expression is used+-- to parse multiple times the 'MemoRef' needs to be cleared using 'memClear'.+--+-- 'memo' relies on 'unsafePerformIO' and is therefore potentially unsafe.+-- The option 'useMemoisation' enables memoisation.+-- It is off by default, even if 'memo' is used in a combinator expression.+memo :: (Ord t, Show t, IsSymbExpr s) => MemoRef [a] -> s t a -> SymbExpr t a+memo ref p' = let   SymbExpr (sym,rules,sem) = toSymb p'+                    lhs_sem opts ctx sppf arr l r +                        | not (do_memo opts) = sem opts ctx sppf arr l r+                        | otherwise = do+                            tab <- readIORef ref+                            case memLookup (l,r) tab of+                                Just as -> return as+                                Nothing -> do   as <- sem opts ctx sppf arr l r+                                                modifyIORef ref (memInsert (l,r) as)+                                                return as+               in SymbExpr (sym, rules, lhs_sem) -optional_ x p = x <:=> Just <$> p <|> (Nothing <$ epsilon)+-- | +-- Helper function for defining new combinators.+-- Use 'mkNt' to form a new unique non-terminal name based on+-- the symbol of a given 'SymbExpr' and a 'String' that is unique to+-- the newly defined combinator.+mkNt :: (Show t, Ord t, IsSymbExpr s) => s t a -> String -> Nt+mkNt p str = let SymbExpr (myx,_,_) = mkRule p+                in "_(" ++ show myx ++ ")" ++ str -class HasAlts a where-    altsOf :: a b -> ([] :. IMParser) b+-- | Specialised fmap for altparsers+(.$.) :: (Show t, Ord t, IsAltExpr i) => (a -> b) -> i t a -> AltExpr t b+f .$. i = let AltExpr (s,r,sem) = toAlt i+            in AltExpr (s,r,\opts slot ctx sppf arr l r -> +                                do  as <- sem opts slot ctx sppf arr l r+                                    return $ map (id *** f) as ) -instance HasAlts IMParser where-    altsOf = O . (:[])+-- | +-- Version of '<$$>' that ignores the semantic result of its second argument. +(<$$) :: (Show t, Ord t, IsSymbExpr s) => b -> s t a -> AltExpr t b+f <$$ p = const f <$$> p+infixl 4 <$$ -instance HasAlts SymbParser where-    altsOf = altsOf . toImp+-- | +-- Version of '<**>' that ignores the semantic result of the first argument.+(**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t b+l **>r = flip const .$. l <**> r+infixl 4 **> -instance HasAlts ([] :. IMParser) where-    altsOf = id+-- | +-- Version of '<**>' that ignores the semantic result of the second argument.+(<**) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t a+l <** r = const .$. l <**> r +infixl 4 <** -class IsIMParser a where-    toImp :: a b -> IMParser b+-- | +-- Left-biased version of '<::='+x <::= altPs = mkNtRule True True x altPs +infixl 2 <::= -instance IsIMParser IMParser where-    toImp = id+-- | Try to apply a parser `many' (0 or more) times. The results are returned in a list.+many :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]+many p = let fresh = mkNt p "*" --TODO using <:=> or <::=> ? +            in fresh <::=> (:) <$$> p <**> many p <||> satisfy [] -instance IsIMParser SymbParser where-    toImp p = id <$> p+-- | Try to apply a parser `some' (1 or more) times. The results are returned in a list.+some :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]+some p = let fresh = mkNt p "+"+            in fresh <::=> (:) <$$> p <**> many p  -instance IsIMParser ([] :. IMParser) where-    toImp = toImp . toSymb+-- | Try to apply a parser once, but proceed if unsuccessful +-- (yielding 'Nothing' as a result in that case).+optional :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a)+optional p = let fresh = mkNt p "?"+                in fresh <::=> Just <$$> p <||> satisfy Nothing  -class IsSymbParser a where-    toSymb :: a b -> SymbParser b+-- | +-- Class for lifting to 'SymbExpr'.+class IsSymbExpr a where+    toSymb :: (Show t, Ord t) => a t b -> SymbExpr t b+    -- | Synonym of 'toSymb' for creating /derived combinators/. +    mkRule :: (Show t, Ord t) => a t b -> BNF t b+    mkRule = toSymb -instance IsSymbParser IMParser where-    toSymb = toSymb . O . (:[]) +instance IsSymbExpr AltExpr where+    toSymb = toSymb . OO . (:[])  -instance IsSymbParser SymbParser where+instance IsSymbExpr SymbExpr where     toSymb = id  -instance IsSymbParser ([] :. IMParser) where+instance IsSymbExpr AltExprs where     toSymb a = mkName <:=> a -        where mkName = "_" ++ concat (intersperse "|" (map op (unO a)))-                where op (IMParser (rhs,_,_)) = concat (intersperse "*" (map show rhs))+        where mkName = "_(" ++ concat (intersperse "|" (map op (unOO a))) ++ ")_"+                where op (AltExpr (rhs,_,_)) = concat (intersperse "*" (map show rhs))+-- | +-- Class for lifting to 'AltExprs'. +class HasAlts a where+    altsOf :: (Show t, Ord t) => a t b -> [AltExpr t b]++instance HasAlts AltExpr where+    altsOf = (:[])++instance HasAlts SymbExpr where+    altsOf = altsOf . toAlt++instance HasAlts AltExprs where+    altsOf = unOO ++-- | +-- Class for lifting to 'AltExpr'. +class IsAltExpr a where+    toAlt :: (Show t, Ord t) => a t b -> AltExpr t b++instance IsAltExpr AltExpr where+    toAlt = id++instance IsAltExpr SymbExpr where+    toAlt p = id <$$> p++instance IsAltExpr AltExprs where+    toAlt = toAlt . mkRule
− src/GLL/Combinators/MemBinInterface.hs 
@@ -1,264 +0,0 @@---- | Parser Combinators for GLL parsing inspired by Tom Ridge's P3 OCaml library-module GLL.Combinators.MemBinInterface (-    Parser,-    parse, parseString,-    (<::=>),(<:=>),-    (<$>),-    (<$),-    (<*>),-    (*>),-    (<*),-    (<|>),-    char, token, Token(..),-    epsilon,satisfy,-    optional, many, some,-    memo, newMemoTable, MemoRef, MemoTable-    ) where--import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))--import GLL.Combinators.Options-import GLL.Combinators.Memoisation-import GLL.Types.Abstract-import GLL.Types.Grammar hiding (epsilon)-import GLL.Parser (gllSPPF,ParseResult(..))--import              Control.Monad-import qualified    Data.Array      as A-import qualified    Data.Map        as M-import              Data.IORef-import qualified    Data.IntMap     as IM-import qualified    Data.Set        as S--type Visit1     = Symbol -type Visit2     = M.Map Nt [Alt] -> M.Map Nt [Alt]-type Visit3 a   = PCOptions -> A.Array Int Token -> ParseContext -> SPPF -                    -> Int -> Int -> Int -> IO (S.Set a)--type Parser a   = (Visit1, Visit2, Visit3 a)--type ParseContext = IM.IntMap (IM.IntMap Nt)---- | Given a parser and a string of tokens, return:---  * The grammar (GLL.Types.Abstract)---  * a list of results, which are all semantic evaluations of 'good derivations'---      - semantic evaluations are specified by using <$> and satisfy---      - 'good derivations' as defined by by Tom Ridge-parse' :: PCOptions -> Parser a -> [Token] -> (Grammar, ParseResult, IO [a])-parse' opts (Nt start,rules,sem) str = -    let cfg     = Grammar start [] [ Rule x alts  -                                   | (x, alts) <- M.assocs (rules M.empty) ]-        parse_r = gllSPPF cfg str-        sppf    = sppf_result parse_r-        as      = sem opts arr IM.empty sppf 0 m m-        m       = length str-        arr     = A.array (0,m) (zip [0..] str)-    in (cfg,parse_r,as >>= return . S.toList)---- | The grammar of a given parser-grammar :: Parser a -> Grammar-grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])---- | The semantic results of a parser, given a token string-parse :: Parser a -> [Token] -> IO [a]-parse = parseWithOptions defaultOptions ---- | The semantic results of a parser, given a token string ---      and GLL.Combinator.Options-parseWithOptions :: PCOptions -> Parser a -> [Token] -> IO [a]-parseWithOptions opts p str = (\(_,_,t) -> t) (parse' opts  p str)---- | Get the SPPF produced by parsing the given input with the given parser-sppf :: Parser a -> [Token] -> ParseResult-sppf p str =  (\(_,s,_) -> s) (parse' defaultOptions p str)---- | Parse a given string of characters -parseString :: Parser a -> [Char] -> IO [a]-parseString p = parse p . charS---- | Parse a given string of characters and options -parseStringWithOptions :: PCOptions -> Parser a -> [Char] -> IO [a]-parseStringWithOptions opts p = parseWithOptions opts p . charS--infixl 3 <::=>-(<::=>) :: String -> Parser a -> Parser a-x <::=> _r = let (sym,_r_rules,_r_sem) = _r-                 alt     = Alt x [sym] -- TODO indirection (extra alt)-                 rules m = case M.lookup x m of-                            Nothing -> _r_rules (M.insert x [alt] m)-                            Just _  -> m--                 sem opts arr ctx sppf l r m-                    | (l,r,x) `inContext` ctx = return S.empty-                    | otherwise = let ctx' = (l,r,x) `toContext` ctx-                                   in _r_sem opts arr ctx' sppf l r m-              in (Nt x,rules,sem)---- | useful for non-recursive definitions (only internally)-infixl 3 <:=>-(<:=>) :: String -> Parser a -> Parser a-x <:=> _r = let (sym,_r_rules,_r_sem) = _r-                alt     = Alt x [sym] -- TODO indirection (extra alt)-                rules m = case M.lookup x m of-                          Nothing -> _r_rules (M.insert x [alt] m)-                          Just _  -> m-              in (Nt x,rules,_r_sem)--infixl 5 <$>--- | Application of a semantic action. -(<$>) :: (Ord b, Ord a) => (a -> b) -> Parser a -> Parser b-f <$> _r = let (sym,rules,_r_sem) = _r-               sem opts arr ctx sppf l r m = -                    do  as <- _r_sem opts arr ctx sppf l r m-                        return (S.map f as)-            in (sym,rules,sem)--infixl 6 <*>--- | Sequence two parsers, the results of the two parsers are tupled.-(<*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser (a,b)-_l <*> _r = (Nt lhs_id,rules,sem)- where  l_id    = id_ _l-        r_id    = id_ _r-        lhs_id  = concat [l_id, "*", r_id]-        -        -- ** one can bind this parser and recurse on it + other duplicate work-        alt     = Alt lhs_id [sym_ _l, sym_ _r]-        rules m = case M.lookup lhs_id m of -- necessary? **-                    Nothing -> rules_ _r (rules_ _l (M.insert lhs_id [alt] m))-                    Just _  -> m-        -        sem opts arr ctx sppf l r m = do    ass <- forM (filter ks) seq-                                            return (S.unions ass)-         where  ks      = maybe [] id $ sppf `pNodeLookup` ((alt,2), l, r)-                filter  = maybe id id $ pivot_select opts-                seq k = do  as <- sem_ _l opts arr ctx sppf l k m-                            bs <- sem_ _r opts arr ctx sppf k r m-                            return $ S.fromList [ (a,b) | a <- S.toList as-                                                        , b <- S.toList bs ]--infixl 4 <|>--- | A choice between two parsers, results of the two are concatenated-(<|>) :: (Ord a) => Parser a -> Parser a -> Parser a-_l <|> _r = (Nt lhs_id,rules,sem)- where  l_id    = id_ _l-        r_id    = id_ _r-        lhs_id  = concat [l_id, "|", r_id]--        alts    = [Alt lhs_id [sym_ _l], Alt lhs_id [sym_ _r]]-        rules m = case M.lookup lhs_id m of-                    Nothing -> rules_ _r (rules_ _l (M.insert lhs_id alts m))-                    Just _  -> m--        sem opts arr ctx sppf l r m = -            do as1 <- sem_ _l opts arr ctx sppf l r m-               as2 <- sem_ _r opts arr ctx sppf l r m -               return (concatChoice opts as1 as2)---- | Use this function on a parser to memoise the semantic phase of the parser--- It is advised to only use 'memo' on a parser whose symbol occurs many times---  in a highly ambiguous grammar--- Every symbol on which 'memo' is used should have its own table.-memo :: MemoRef (S.Set a) -> Parser a -> Parser a-memo ref (sym@(Nt x),rules,sem) = (sym, rules, lhs_sem)-    where   lhs_sem opts arr ctx sppf l r m = do    -                    tab <- readIORef ref-                    case memLookup (l,r) tab of-                     Just as -> return as-                     Nothing -> do  as <- sem opts arr ctx sppf l r m-                                    modifyIORef ref (memInsert (l,r) as)-                                    return as--- derived combinators-infixl 6 <*--- | Sequencing, ignoring the result to the right-(<*) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser a-_l <* _r = (\(x,y) -> x) <$> _l <*> _r--infixl 6 *>--- | Sequencing, ignoring the result to the left -(*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser b-_l *> _r = (\(x,y) -> y) <$> _l <*> _r--infixl 5 <$--- | Ignore all results and just return the given value-(<$) :: (Ord a, Ord b) => a -> Parser b -> Parser a-f <$ _r = const f <$> _r ---- elementary parsers-raw_parser :: String -> Token -> (Token -> a) -> Parser a-raw_parser str t f = (Nt str, rules, sem)-    where   alt     = Alt str [Term t]-            rules   = M.insert str [alt] -            sem _ arr ctx sppf l r m -                | l + 1 == r && l < m && arr A.! l == t -                            = return $ S.singleton (f t)-                | otherwise = return $ S.empty---- | A parser that recognises a given character-char :: Char -> Parser Char-char c = raw_parser ([c]) (Char c) (\(Char c) -> c)---- | A parser that recognises a given token-token :: Token -> Parser Token-token t = raw_parser (show t) t id---- | A parser that always succeeds (and returns unit)-epsilon :: Parser ()-epsilon = (Nt x, rules, sem)-    where   x       = "__eps"-            alt     = Alt x [Term Epsilon]-            rules   = M.insert x [alt]-            sem _ arr ctx sppf l r m  | l == r    = return $ S.singleton ()-                                      | otherwise = return $ S.empty---- | A parser that always succeeds and returns a given value-satisfy :: (Ord a) => a -> Parser a-satisfy a = a <$ epsilon---- helpers-sym_ :: Parser a -> Symbol-sym_ (f,_,_) = f--id_   :: Parser a -> Nt -id_ (Nt x,_,_)   = x--rules_ :: Parser a -> Visit2-rules_ (_,f,_) = f--sem_   :: Parser a -> Visit3 a-sem_ (_,_,f)   = f--mkNt :: String -> Char -> Nt-mkNt x c = concat ["(",x,")",[c]]--inContext :: (Int, Int, Nt) -> ParseContext -> Bool-inContext (l,r,x) = maybe False inner . IM.lookup l -    where inner = maybe False ((==) x) . IM.lookup r--toContext :: (Int, Int, Nt) -> ParseContext -> ParseContext-toContext (l,r,x) = IM.insertWith IM.union l (IM.singleton r x)--concatChoice :: (Ord a) => PCOptions -> S.Set a -> S.Set a -> S.Set a-concatChoice opts ls rs = if left_biased_choice opts-                            then firstRes-                            else ls `S.union` rs- where  firstRes | S.null ls  = rs-                 | otherwise  = ls---- higher level patterns---- | Optionally use the given parser-optional :: (Ord a) => Parser a -> Parser (Maybe a)-optional p@(Nt x,_,_) = (mkNt x '?') <:=> satisfy Nothing <|> Just <$> p---- | Apply the given parser many times, 0 or more times (Kleene closure)-many :: (Ord a) => Parser a -> Parser [a]-many p@(Nt x,_,_) = (mkNt x '^') <::=> satisfy [] -                                   <|> uncurry (:) <$> p <*> many p---- | Apply the given parser some times, 1 or more times (positive closure)-some :: (Ord a) => Parser a -> Parser [a]-some p@(Nt x,_,_) = let rec = (mkNt x '+') <::=> (:[]) <$> p-                                            <|> uncurry (:) <$> p <*> rec-                    in rec-
− src/GLL/Combinators/MemInterface.hs 
@@ -1,309 +0,0 @@-{-# LANGUAGE TypeOperators, FlexibleInstances #-}--module GLL.Combinators.MemInterface (-    SymbParser, IMParser,-    HasAlts(..), IsSymbParser(..), IsIMParser(..),-    parse, parseString,-    char, token, Token(..),-    epsilon, satisfy,-    many, some, optional,-    (<::=>),(<:=>),-    (<$>),-    (<$),-    (<*>),-    (<*),-    (<|>),-    (:.),-    memo, newMemoTable, MemoRef, MemoTable-    ) where--import Prelude hiding ((<*>), (<*), (<$>), (<$))--import GLL.Combinators.Options-import GLL.Combinators.Memoisation-import GLL.Types.Grammar hiding (epsilon)-import GLL.Types.Abstract-import GLL.Parser (gllSPPF, pNodeLookup, ParseResult(..))--import Control.Compose-import Control.Monad-import Data.List (unfoldr,intersperse)-import           Data.IORef-import qualified Data.IntMap as IM-import qualified Data.Map as M-import qualified Data.Set as S--type SymbVisit1 b = Symbol -type SymbVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt]-type SymbVisit3 b = PCOptions -> ParseContext -> SPPF -> Int -> Int -> IO [b]--type IMVisit1 b   = [Symbol] -type IMVisit2 b   = M.Map Nt [Alt] -> M.Map Nt [Alt]-type IMVisit3 b   = PCOptions -> (Alt,Int) -> ParseContext -> SPPF -> Int -> Int -> IO [b]--type ParseContext = IM.IntMap (IM.IntMap (S.Set Nt))--data SymbParser b = SymbParser (SymbVisit1 b,SymbVisit2 b, SymbVisit3 b)-data IMParser b   = IMParser (IMVisit1 b, IMVisit2 b, IMVisit3 b)--parse' :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> (Grammar, ParseResult, IO [a])-parse' opts p' input' =  -    let input               = input' ++ [Char 'z']-        SymbParser (Nt start,vpa2,vpa3) = toSymb (id <$> p' <* char 'z')-        snode               = (start, 0, m)-        m                   = length input-        rules               = vpa2 M.empty-        as                  = vpa3 opts IM.empty sppf 0 m-        grammar = Grammar start [] [ Rule x alts | (x, alts) <- M.assocs rules ]-        parse_res           = gllSPPF grammar input-        sppf                = sppf_result parse_res-    in (grammar, parse_res, as)---- | The grammar of a given parser-grammar :: (IsSymbParser s) => s a -> Grammar-grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])---- | The semantic results of a parser, given a string of Tokens-parse :: (IsSymbParser s) => s a -> [Token] -> IO [a]-parse = parseWithOptions defaultOptions ---- | Change the behaviour of the parse using GLL.Combinators.Options-parseWithOptions :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> IO [a]-parseWithOptions opts p = (\(_,_,t) -> t) . parse' opts p---- | Parse a string of characters-parseString :: (IsSymbParser s) => s a -> String -> IO [a]-parseString = parseStringWithOptions defaultOptions---- | Parse a string of characters using options-parseStringWithOptions :: (IsSymbParser s) => PCOptions -> s a -> String -> IO [a]-parseStringWithOptions opts p  = parseWithOptions opts p . map Char---- | Get the SPPF produced by parsing the given input with the given parser-sppf :: (IsSymbParser s) => s a -> [Token] -> ParseResult-sppf p str =  (\(_,s,_) -> s) $ parse' defaultOptions p str--inParseContext :: ParseContext -> (Symbol, Int, Int) -> Bool-inParseContext ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx- where  inner = maybe False (S.member x) . IM.lookup r--toParseContext :: ParseContext -> (Nt, Int, Int) -> ParseContext-toParseContext ctx (x, l, r) = IM.alter inner l ctx- where  inner mm = case mm of -                    Nothing -> Just $ singleRX-                    Just m  -> Just $ IM.insertWith (S.union) r singleX m-        singleRX = IM.singleton r singleX-        singleX  = S.singleton x--infixl 2 <::=>--- | Use this combinator on all combinators that might have an infinite---  number of derivations for some input string. A non-terminal has---  this property if and only if it is left-recursive and would be---  left-recursive if all the right-hand sides of the productions of the---  grammar are reversed.-(<::=>) :: (HasAlts b) => String -> b a -> SymbParser a -x <::=> altPs' =-    let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ]-        alts  = map (Alt x) vas1    -        altPs = unO $ altsOf altPs' in SymbParser-        (Nt x-       ,\rules ->-           if x `M.member` rules -            then rules -            else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs)-       ,\opts ctx sppf l r -> -        let ctx' = ctx `toParseContext` (x,l,r)-            sems = zip alts (map (\(IMParser (_,_,t)) -> t) altPs) -            seq (alt@(Alt _ rhs), va3) = va3 opts (alt,length rhs) ctx' sppf l r -        in if ctx `inParseContext` (Nt x, l, r) -                then return []-                else do ass <- forM sems seq-                        return (concatChoice opts ass)-       )--infixl 2 <:=>--- | Use this combinator on all recursive non-terminals-(<:=>) :: (HasAlts b) => String -> b a -> SymbParser a -x <:=> altPs' =-    let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ]-        alts  = map (Alt x) vas1    -        altPs = unO $ altsOf altPs' in SymbParser-        (Nt x-       ,\rules ->-           if x `M.member` rules -            then rules -            else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs)-       ,\opts ctx sppf l r -> -        let sems = zip alts (map (\(IMParser (_,_,t)) -> t) altPs)-            seq (alt@(Alt _ rhs), va3) = va3 opts (alt,length rhs) ctx sppf l r -        in do   ass <- forM sems seq-                return (concatChoice opts ass)-       )--concatChoice :: PCOptions -> [[a]] -> [a]-concatChoice opts ress = if left_biased_choice opts-                            then firstRes ress-                            else concat ress- where  firstRes []         = []-        firstRes ([]:ress)  = firstRes ress-        firstRes (res:_)    = res--infixl 4 <*>-(<*>) :: (IsIMParser i, IsSymbParser s) => i (a -> b) -> s a -> IMParser b-pl' <*> pr' = -  let IMParser (vimp1,vimp2,vimp3) = toImp pl'-      SymbParser (vpa1,vpa2,vpa3)  = toSymb pr' in IMParser-  (vimp1++[vpa1]-  ,\rules ->  let rules1  = vpa2 rules-                  rules2  = vimp2 rules1 in rules2-  ,\opts (alt@(Alt x rhs),j) ctx sppf l r ->-    let ks     = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)-        filter = maybe id id $ pivot_select opts-        seq k  = do     as      <- vpa3 opts ctx sppf k r-                        a2bs    <- vimp3 opts(alt,j-1) ctx sppf l k-                        return [ a2b a | a2b <- a2bs, a <- as ]-    in do   ass <- forM (filter ks) seq-            return (concat ass)-  )---infixl 4 <*-(<*) :: (IsIMParser i, IsSymbParser s) => i b -> s a -> IMParser b--pl' <* pr' = -  let IMParser (vimp1,vimp2,vimp3) = toImp pl'-      SymbParser (vpa1,vpa2,vpa3)  = toSymb pr' in IMParser-  (vimp1++[vpa1]-  ,\rules ->-    let rules1  = vpa2 rules-        rules2  = vimp2 rules1-    in rules2-  ,\opts (alt@(Alt x rhs),j) ctx sppf l r ->-    let ks      = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)-        filter  = maybe id id $ pivot_select opts-        seq k   = do    as <- vpa3 opts ctx sppf k r-                        bs <- vimp3 opts (alt,j-1) ctx sppf l k-                        return [ b | b <- bs, a <- as ]-    in do   ass <- forM (filter ks) seq-            return (concat ass)-  )--infixl 4 <$>-(<$>) :: (IsSymbParser s) => (a -> b) -> s a -> IMParser b-f <$> p' = -    let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser-      ([vpa1]-      ,\rules -> -        vpa2 rules-      ,\opts (alt,j) ctx sppf l r ->-        let a   = vpa3 opts ctx sppf l r-            ks  = maybe [] id $ sppf `pNodeLookup` ((alt,1),l,r)-        in if null ks then return [] else do  res <- a-                                              return (map f res)-      )--infixl 4 <$-(<$) :: (IsSymbParser s) => b -> s a -> IMParser b-f <$ p' = -    let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser -      ([vpa1]-      ,\rules -> -        vpa2 rules-      ,\opts (alt,j) ctx sppf l r ->-        let a   = vpa3 opts ctx sppf l r-            ks  = maybe [] id $ sppf `pNodeLookup` ((alt,1),l,r)-        in if null ks then return [] else do  res <- a-                                              return (map (const f) res)-      )--infixr 3 <|>-(<|>) :: (IsIMParser i, HasAlts b) => i a -> b a -> ([] :. IMParser) a-l' <|> r' = let l = toImp l'-                r = altsOf r'-            in O (l : unO r)--memo :: (IsSymbParser s) => MemoRef [a] -> s a -> SymbParser a-memo ref p' = let   SymbParser (sym,rules,sem) = toSymb p' -                    lhs_sem opts ctx sppf l r = do-                        tab <- readIORef ref-                        case memLookup (l,r) tab of-                            Just as -> return as-                            Nothing -> do   as <- sem opts ctx sppf l r-                                            modifyIORef ref (memInsert (l,r) as)-                                            return as-               in SymbParser (sym, rules, lhs_sem)--raw_parser :: Token -> (Token -> a) -> SymbParser a -raw_parser t f = SymbParser (Term t, id,\_ _ _ _ _ -> return [f t])--token :: Token -> SymbParser Token-token t = raw_parser t id --char :: Char -> SymbParser Char-char c = raw_parser (Char c) (\(Char c) -> c) --epsilon :: SymbParser ()-epsilon = raw_parser (Epsilon) (\_ -> ()) --satisfy :: a -> IMParser a-satisfy a = a <$ epsilon--many :: SymbParser a -> SymbParser [a]-many p = SymbParser f- where  SymbParser (myx,_,_) = p-        SymbParser f = many_ ("(" ++ show myx ++ ")^") p--many_ x p = x <:=> (:) <$> p <*> many_ x p <|> [] <$ epsilon--some :: SymbParser a -> SymbParser [a]-some p = SymbParser f- where  SymbParser (myx,_, _) = p-        SymbParser f = some_ ("(" ++ show myx ++ ")+") p --some_ x p = x <:=> (:) <$> p <*> some_ x p <|> (:[]) <$> p--optional :: SymbParser a -> SymbParser (Maybe a)-optional p = SymbParser f-    where SymbParser (myx, _, _) = p -          SymbParser f = optional_ ("(" ++ show myx ++ ")?") p--optional_ x p = x <:=> Just <$> p <|> (Nothing <$ epsilon)--class HasAlts a where-    altsOf :: a b -> ([] :. IMParser) b--instance HasAlts IMParser where-    altsOf = O . (:[])--instance HasAlts SymbParser where-    altsOf = altsOf . toImp--instance HasAlts ([] :. IMParser) where-    altsOf = id--class IsIMParser a where-    toImp :: a b -> IMParser b--instance IsIMParser IMParser where-    toImp = id--instance IsIMParser SymbParser where-    toImp p = id <$> p--instance IsIMParser ([] :. IMParser) where-    toImp = toImp . toSymb--class IsSymbParser a where-    toSymb :: a b -> SymbParser b--instance IsSymbParser IMParser where-    toSymb = toSymb . O . (:[]) --instance IsSymbParser SymbParser where-    toSymb = id --instance IsSymbParser ([] :. IMParser) where-    toSymb a = mkName <:=> a -        where mkName = "_" ++ concat (intersperse "|" (map op (unO a)))-                where op (IMParser (rhs,_,_)) = concat (intersperse "*" (map show rhs))-
src/GLL/Combinators/Memoisation.hs view
@@ -2,9 +2,14 @@  import              Data.IORef import qualified    Data.IntMap     as IM+import System.IO.Unsafe --- | use <::=> to enforce using parse context (to handle left-recursion)+-- | +-- A 'MemoTable' maps left-extent /l/ to right-extent /r/ to some results /a/+-- indicating the the substring ranging from /l/ to /r/ is derived with parse result /a/. type MemoTable a = IM.IntMap (IM.IntMap a)++-- | An impure reference to a 'MemoTable'. type MemoRef a   = IORef (MemoTable a)  memLookup :: (Int, Int) -> MemoTable a -> Maybe a@@ -17,8 +22,13 @@                     Nothing -> Just $ IM.singleton r as                     Just m  -> Just $ IM.insert r as m --- create a new memo-table to use with the memo function-newMemoTable :: IO (MemoRef a)-newMemoTable = newIORef IM.empty+-- |+-- Clears the 'MemoTable' to which the given reference refers.+memClear :: MemoRef a -> IO ()+memClear ref = modifyIORef ref (const IM.empty) +-- | +-- Create a reference to a fresh 'MemoTable'.+newMemoTable :: MemoRef a+newMemoTable = unsafePerformIO $ newIORef IM.empty
src/GLL/Combinators/Options.hs view
@@ -1,26 +1,87 @@ module GLL.Combinators.Options where +import Data.Function (on)+ -- | Options datatype --      * left_biased_choice: see function leftBiased --      * pivot_select: provide a filtering function on `pivots' data PCOptions = PCOptions  { left_biased_choice    :: Bool-                            , pivot_select          :: Maybe ([Int] -> [Int])+                            , pivot_select          :: Maybe (Int -> Int -> Ordering)+                            , pivot_select_nt       :: Bool+                            , max_errors            :: Int+                            , throw_errors          :: Bool+                            , do_memo               :: Bool                             } --- | The default options: no disambiguation+-- | A list of 'Option's for evaluating combinator expressions.+type Options    = [Option]++-- | A single option.+type Option     = PCOptions -> PCOptions++runOptions :: [Option] -> PCOptions+runOptions = foldr ($) defaultOptions++-- | The default options: no disambiguation. defaultOptions :: PCOptions-defaultOptions = PCOptions False Nothing+defaultOptions = PCOptions False Nothing False 3 False False --- | Perform a disambiguation similar to 'longest-match'-maximumPivot :: PCOptions -> PCOptions-maximumPivot opts = opts {pivot_select = Just op}- where  op [] = []-        op xs = (:[]) $ maximum xs+-- | Enables a 'longest-match' at production level.+maximumPivot :: Option+maximumPivot opts = opts {pivot_select = Just compare} --- | Make the <|> combinator left-biased such that it---  only returns results of the right child if the left---  child does not has any results.-leftBiased :: PCOptions-leftBiased = defaultOptions { left_biased_choice = True }+-- | Enables a 'shortest-match' at production level.+minimumPivot :: Option+minimumPivot opts = opts {pivot_select = Just (flip compare)} +-- | Enables 'longest-match' at non-terminal level. +maximumPivotAtNt :: Option+maximumPivotAtNt opts = opts {pivot_select_nt = True, pivot_select = Just compare}++-- | +-- Set the maximum number of errors shown in case of an unsuccessful parse.+maximumErrors :: Int -> Option+maximumErrors n flags = flags {max_errors = n}++-- | +-- If there are no parse results, the default behaviour is to return an empty list.+-- If this option is used, a runtime error will be reported, with debugging information.+throwErrors :: Option+throwErrors opts = opts{throw_errors = True}+++-- | +-- Turns all occurrences of '<||>' into a 'left biased' variant:+--  only return results of the second alternate if the first alternate+-- does not have any results.+leftBiased :: Option+leftBiased opts = opts { left_biased_choice = True }++-- | +-- Whether to use unsafe memoisation to speed up the enumeration of parse results+useMemoisation :: Option+useMemoisation opts = opts { do_memo = True }++-- | Filter a list such that the only remaining elements are equal to+-- the maximum element, given an ordering operator.+maximumsWith :: (a -> a -> Ordering) -> [a] -> [a]+maximumsWith compare xs = +    case xs of+    []      -> []+    [x]     -> [x]+    x:xs    -> maxx xs x []+ where  maxx []     x acc = x : acc+        maxx (y:ys) x acc = case y `compare` x of+                            LT -> maxx ys x acc+                            GT -> maxx ys y []+                            EQ -> maxx ys y (x:acc)++-- assumes every sub-list contains only maximums already+maintainWith :: (Eq k) => (k -> k -> Ordering) -> [[(k,a)]] -> [[(k,a)]]+maintainWith compare = +    maintain .+    filter (not . null)+ where  maintain xss = +            let (max,_):_ = maximumsWith (compare `on` fst) $ map head xss+             in (filter ((== max) . fst . head) xss)
− src/GLL/Combinators/Test/BinInterface.hs 
@@ -1,187 +0,0 @@-{-| This model contains unit-tests for 'GLL.Combinators.BinInterface'--= Included examples--  * Elementary parsers-  * Sequencing-  * Alternatives-  * Simple binding-  * Binding with alternatives-  * Recursion (non-left)--  * Higher-order patterns:--      * Optional-      * Kleene-closure / positive closure-      * Seperator-      * Inline choice--  * Ambiguities:--      * "aaa"-      * longambig-      * aho_s-      * EEE--  * Left recursion-  * Hidden left-recursion--}-module GLL.Combinators.Test.BinInterface where--import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))--import Control.Compose-import Control.Monad-import Data.Char (ord)-import Data.List (sort)-import Data.IORef-import qualified Data.Map as M--import GLL.Combinators.BinInterface---- | Defines and executes some unit-tests -main = do-    count <- newIORef 1-    let test name p arg_pairs = do-            i <- readIORef count-            modifyIORef count succ-            subcount <- newIORef 'a'-            putStrLn (">> testing " ++ show i ++ " (" ++ name ++ ")")-            forM_ arg_pairs $ \(str,res) -> do-                j <- readIORef subcount-                modifyIORef subcount succ-                let parse_res   = parseString p str-                    norm        = sort . take 100-                    b           = norm parse_res == norm res-                putStrLn ("  >> " ++ [j,')',' '] ++ show b)-                unless b (putStrLn ("    >> " ++ show parse_res))--    -- Elementary parsers-    test "eps1" (satisfy 0) [("", [0])]-    test "eps2" (0 <$ epsilon) [("", [0]), ("111", [])]-    test "single" (char 'a') [("a", ['a'])-                    ,("abc", [])]-    test "semfun1" (1 <$ char 'a') [("a", [1])]--    -- Elementary combinators-    test "<*>" ((\b -> ['1',b]) <$> char 'a' *> char 'b')-         [("ab", ["1b"])-         ,("b", [])]-   -    -- Alternation-    test "<|>" (ord <$> char 'a' *> char 'b' <|> ord <$> char 'c')-         [("a", []), ("ab", [98]), ("c", [99]), ("cab", [])]--    -- Simple binding-    let pX = "X" <::=> ord <$> char 'a' <* char 'b'-    test "<::=>" pX [("ab",[97]),("a",[])]--    let  pX = "X" <::=> uncurry (flip (:)) <$> pY <*> char 'a'-         pY = "Y" <::=> uncurry (\x y -> [x,y]) <$> char 'b' <*> char 'c'-    test "<::=> 2" pX [("bca", ["abc"]), ("cba", [])]--    -- Binding with alternatives-    let pX = "X" <::=> pY <* char 'c'-        pY = "Y" <::=> char 'a' <|> char 'b'-    test "<::=> <|>" pX [("ac", "a"), ("bc", "b")]--    -- (Right) Recursion-    let pX = "X" <::=> (+1) <$> char 'a' *> pX <|> 0 <$ epsilon-    test "rec1" pX [("", [0]), ("aa",[2]), (replicate 42 'a', [42]), ("bbb", [])]--    -- EBNF-    let pX = "X" <::=> id <$> char 'a' *> char 'b' *> optional (char 'z')-    test "optional" pX [("abz", [Just 'z']), ("abab", []), ("ab", [Nothing])]--    let pX = "X" <::=> (char 'a' <|> char 'b')-    test "<|> optional" (pX <* optional (char 'z'))-                [("az", "a"), ("bz", "b"), ("z", []), ("b", "b"), ("a", "a")]--    let pX = "X" <::=> (1 <$ optional (char 'a') <|> 2 <$ optional (char 'b'))-    test "optional-ambig" (pX <* optional (char 'z'))-                [("az", [1]), ("bz", [2]), ("z", [1,2]), ("b", [2]), ("a", [1])]--    let pX = "X" <::=> id <$> char 'a' *> (char 'b' <|> char 'c')-    test "inline choice (1)" pX-                [("ab", "b"), ("ac", "c"), ("a", []), ("b", [])]--    let pX = "X" <::=> length <$> many (char '1')-    test "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])]--    let pX = "X" <::=> length <$> some (char '1')-    test "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])]--    let pX = "X" <::=> 1 <$ many (char 'a') <|> 2 <$ many (char 'b')-    test "(many <|> many) <*> optional" (pX <* optional (char 'z'))-                [("az", [1]), ("bz", [2]), ("z", [1,2])-                ,("", [1,2]), ("b", [2]), ("a", [1])]--    let pX = "X" <::=> pY <* optional (char 'z')-         where pY = "Y" <::=> length <$> many (char 'a')-                          <|> length <$> some (char 'b') <* char 'e'-    test "many & some & optional" -        pX  [("aaaz", [3]), ("bbbez", [3]), ("ez", []), ("z", [0])-            ,("aa", [2]), ("bbe", [2]) -            ]--    -- Simple ambiguities-    let pX = uncurry (++) <$> pA <*> pB-        pA = "a" <$ char 'a' <|> "aa" <$ char 'a' <* char 'a'-        pB = "b" <$ char 'a' <|> "bb" <$ char 'a' <* char 'a' -    test "aaa" pX   [("aaa", ["aab", "abb"])-                    ,("aa", ["ab"])]--    let pX = (\(x,y) -> [x,y]) <$> char 'a' *> pL <*> pL <* char 'e'-        pL =    1 <$ char 'b'-            <|> 2 <$ char 'b' <* char 'c'-            <|> 3 <$ char 'c' <* char 'd'-            <|> 4 <$ char 'd'-    test "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])]--    let pX = "X" <::=> (1 <$ some (char 'a') <|> 2 <$ many (char 'b'))-        pY = "Y" <::=> uncurry (+) <$> pX <*> pY-                   <|> satisfy 0-    test "some & many & recursion + ambiguities" pY-        [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])]--    let pX = "X" <::=>  1 <$ char 'a' <|> satisfy 0-        pY = "Y" <::=> uncurry (+) <$> pX <*> pY-    -- shouldn't this be 1 + infinite 0's?-    test "no parse infinite rec?" pY -        [("a", [])]--    let pS = "S" <::=> ((\(x,y) -> x+y+1) <$> char '1' *> pS <*> pS) <|> satisfy 0    -    test "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]---    let pS = "S" <::=> ((\(x,y) -> '1':x++y) <$> char '1' *> pS <*> pS) <|> satisfy "0"-    test "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])-                    ,(replicate 5 '1', aho_S_5)]--    let pE = "E" <::=> (\((x,y),z) -> x+y+z) <$> pE <*> pE <*> pE -                             <|> 1 <$ char '1'-                             <|> satisfy 0-    test "EEE" pE [("", [0]), ("1", [1]), ("11", [2])-                  ,(replicate 5 '1', [5]), ("112", [])]--    let pE = "E" <::=> (\((x,y),z) -> x++y++z) <$> pE <*> pE <*> pE -                             <|> "1" <$ char '1'-                             <|> satisfy "0"-    test "EEE ambig" pE [("", ["0"]), ("1", ["1"])-                        ,("11", ["110", "011", "101"]), ("111", _EEE_3)]--    let pX = "X" <::=>  maybe 0 (const 1) <$> optional (char 'z') -                    <|> (+1) <$> pX <* char '1'-    test "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])-                                    ,(replicate 100 '1', [100])]--    let pX = "X" <::=> satisfy 0 -                    <|> (+1) <$> pB *> pX <* char '1'-        pB = maybe 0 (const 0) <$> optional (char 'z')-    test "hidden left-recursion" pX -        [("", [0]), ("zz11", [2]), ("z11", [2]), ("11", [2])-        ,(replicate 100 '1', [100])]- where-    aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"]--    _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"]
src/GLL/Combinators/Test/Interface.hs view
@@ -1,4 +1,4 @@-{-| This model contains unit-tests for 'GLL.Combinators.Interface'+{-| This model contains unit-tests for 'GLL.Combinators.Interface'.  = Included examples @@ -28,29 +28,28 @@ -} module GLL.Combinators.Test.Interface where -import Prelude hiding ((<$>),(<*>),(<*),(<$))--import Control.Compose import Control.Monad import Data.Char (ord) import Data.List (sort, nub) import Data.IORef-import qualified Data.Map as M  import GLL.Combinators.Interface  -- | Defines and executes some unit-tests  main = do     count <- newIORef 1-    let test name p arg_pairs = do+    let test mref name p arg_pairs = do             i <- readIORef count             modifyIORef count succ             subcount <- newIORef 'a'             putStrLn (">> testing " ++ show i ++ " (" ++ name ++ ")")             forM_ arg_pairs $ \(str,res) -> do+                case mref of -- empty memtable between parses+                    Nothing     -> return ()+                    Just ref    -> memClear ref                  j <- readIORef subcount                 modifyIORef subcount succ-                let parse_res   = parseString p str+                let parse_res   = parseWithOptions[useMemoisation] p str                     norm        = take 100 . sort . nub                     norm_p_res  = norm parse_res                     b           = norm_p_res == norm res@@ -58,135 +57,182 @@                 unless b (putStrLn ("    >> " ++ show norm_p_res))      --  Elementary parsers-    test "eps1" (satisfy 0) [("", [0])]-    test "eps2" (0 <$ epsilon) [("", [0]), ("111", [])]-    test "single" (char 'a') [("a", ['a'])+    test Nothing "eps1" (satisfy 0) [("", [0])]+    test Nothing "eps2" (satisfy 0) [("", [0]), ("111", [])]+    test Nothing "single" (char 'a') [("a", ['a'])                     ,("abc", [])]-    test "semfun1" (1 <$ char 'a') [("a", [1])]+    test Nothing "semfun1" (1 <$$ char 'a') [("a", [1])]      --  Elementary combinators-    test "<*>" ((\b -> ['1',b]) <$ char 'a' <*> char 'b')+    test Nothing "<**>" ((\b -> ['1',b]) <$$ char 'a' <**> char 'b')          [("ab", ["1b"])          ,("b", [])]         --  Alternation-    test "<|>" (ord <$ char 'a' <*> char 'b' <|> ord <$> char 'c')+    test Nothing "<||>" (ord <$$ char 'a' <**> char 'b' <||> ord <$$> char 'c')          [("a", []), ("ab", [98]), ("c", [99]), ("cab", [])]      --  Simple binding-    let pX = "X" <:=> ord <$> char 'a' <* char 'b'-    test "<:=>" pX [("ab",[97]),("a",[])]+    let pX = "X" <:=> ord <$$> char 'a' <** char 'b'+    test Nothing "<:=>" pX [("ab",[97]),("a",[])]      --  Simple binding-    let pX = "X" <::=> ord <$> char 'a' <* char 'b'-    test "<::=>" pX [("ab",[97]),("a",[])]+    let pX = "X" <::=> ord <$$> char 'a' <** char 'b'+    test Nothing "<::=>" pX [("ab",[97]),("a",[])] -    let  pX = "X" <:=> flip (:) <$> pY <*> char 'a'-         pY = "Y" <:=> (\x y -> [x,y]) <$> char 'b' <*> char 'c'-    test "<::=> 2" pX [("bca", ["abc"]), ("cba", [])]+    let  pX = "X" <:=> flip (:) <$$> pY <**> char 'a'+         pY = "Y" <:=> (\x y -> [x,y]) <$$> char 'b' <**> char 'c'+    test Nothing "<::=> 2" pX [("bca", ["abc"]), ("cba", [])]      --  Binding with alternatives-    let pX = "X" <::=> pY <* char 'c'-        pY = "Y" <::=> char 'a' <|> char 'b'-    test "<::=> <|>" pX [("ac", "a"), ("bc", "b")]+    let pX = "X" <::=> pY <** char 'c'+        pY = "Y" <::=> char 'a' <||> char 'b'+    test Nothing "<::=> <||>" pX [("ac", "a"), ("bc", "b")]      --  (Right) Recursion-    let pX = "X" <::=> (+1) <$ char 'a' <*> pX <|> 0 <$ epsilon-    test "rec1" pX [("", [0]), ("aa",[2]), (replicate 42 'a', [42]), ("bbb", [])]+    let pX = "X" <::=> (+1) <$$ char 'a' <**> pX <||> satisfy 0 +    test Nothing "rec1" pX [("", [0]), ("aa",[2]), (replicate 42 'a', [42]), ("bbb", [])]      --  EBNF-    let pX = "X" <::=> id <$ char 'a' <* char 'b' <*> optional (char 'z')-    test "optional" pX [("abz", [Just 'z']), ("abab", []), ("ab", [Nothing])]+    let pX = "X" <::=> id <$$ char 'a' <** char 'b' <**> optional (char 'z')+    test Nothing "optional" pX [("abz", [Just 'z']), ("abab", []), ("ab", [Nothing])] -    let pX = "X" <::=> (char 'a' <|> char 'b')-    test "<|> optional" (pX <* optional (char 'z'))+    let pX = "X" <::=> (char 'a' <||> char 'b')+    test Nothing "<||> optional" (pX <** optional (char 'z'))                 [("az", "a"), ("bz", "b"), ("z", []), ("b", "b"), ("a", "a")] -    let pX = "X" <::=> (1 <$ optional (char 'a') <|> 2 <$ optional (char 'b'))-    test "optional-ambig" (pX <* optional (char 'z'))+    let pX = "X" <::=> (1 <$$ optional (char 'a') <||> 2 <$$ optional (char 'b'))+    test Nothing "optional-ambig" (pX <** optional (char 'z'))                 [("az", [1]), ("bz", [2]), ("z", [1,2]), ("b", [2]), ("a", [1])] -    let pX = "X" <::=> id <$ char 'a' <*> (char 'b' <|> char 'c')-    test "inline choice (1)" pX+    let pX = "X" <::=> id <$$ char 'a' <**> (char 'b' <||> char 'c')+    test Nothing "inline choice (1)" pX                 [("ab", "b"), ("ac", "c"), ("a", []), ("b", [])] -    let pX = "X" <::=> length <$> many (char '1')-    test "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])]+    let pX = "X" <::=> length <$$> many (char '1')+    test Nothing "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])] -    let pX = "X" <::=> length <$> some (char '1')-    test "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])]+    let pX = "X" <::=> length <$$> some (char '1')+    test Nothing "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])] -    let pX = "X" <::=> 1 <$ many (char 'a') <|> 2 <$ many (char 'b')-    test "(many <|> many) <*> optional" (pX <* optional (char 'z'))+    let pX = "X" <::=> 1 <$$ many (char 'a') <||> 2 <$$ many (char 'b')+    test Nothing "(many <||> many) <**> optional" (pX <** optional (char 'z'))                 [("az", [1]), ("bz", [2]), ("z", [1,2])                 ,("", [1,2]), ("b", [2]), ("a", [1])] -    let pX = "X" <::=> pY <* optional (char 'z')-         where pY = "Y" <::=> length <$> many (char 'a')-                          <|> length <$> some (char 'b') <* char 'e'-    test "many & some & optional" +    let pX = "X" <::=> pY <** optional (char 'z')+         where pY = "Y" <::=> length <$$> many (char 'a')+                          <||> length <$$> some (char 'b') <** char 'e'+    test Nothing "many & some & optional"          pX  [("aaaz", [3]), ("bbbez", [3]), ("ez", []), ("z", [0])             ,("aa", [2]), ("bbe", [2])              ] +    -- many with nullable argument+    let pX = 1 <$$ char '1' <||> satisfy 0+    test Nothing "many (nullable arg)" +        (many pX) [("11", [[1,1]]), ("",[[]]), ("e", [])]+     --  Simple ambiguities-    let pX = (++) <$> pA <*> pB-        pA = "a" <$ char 'a' <|> "aa" <$ char 'a' <* char 'a'-        pB = "b" <$ char 'a' <|> "bb" <$ char 'a' <* char 'a' -    test "aaa" pX   [("aaa", ["aab", "abb"])+    let pX = (++) <$$> pA <**> pB+        pA = "a" <$$ char 'a' <||> "aa" <$$ char 'a' <** char 'a'+        pB = "b" <$$ char 'a' <||> "bb" <$$ char 'a' <** char 'a' +    test Nothing "aaa" pX   [("aaa", ["aab", "abb"])                     ,("aa", ["ab"])] -    let pX = (\x y -> [x,y]) <$ char 'a' <*> pL <*> pL <* char 'e'-        pL =    1 <$ char 'b'-            <|> 2 <$ char 'b' <* char 'c'-            <|> 3 <$ char 'c' <* char 'd'-            <|> 4 <$ char 'd'-    test "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])]+    let pX = (\x y -> [x,y]) <$$ char 'a' <**> pL <**> pL <** char 'e'+        pL =    1 <$$ char 'b'+            <||> 2 <$$ char 'b' <** char 'c'+            <||> 3 <$$ char 'c' <** char 'd'+            <||> 4 <$$ char 'd'+    test Nothing "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])] -    let pX = "X" <::=> (1 <$ some (char 'a') <|> 2 <$ many (char 'b'))-        pY = "Y" <::=> (+) <$> pX <*> pY-                   <|> satisfy 0-    test "some & many & recursion + ambiguities" pY+    let pX = "X" <::=> (1 <$$ some (char 'a') <||> 2 <$$ many (char 'b'))+        pY = "Y" <::=> (+) <$$> pX <**> pY+                   <||> satisfy 0+    test Nothing "some & many & recursion + ambiguities" pY         [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])] -    let pX = "X" <::=>  1 <$ char 'a' <|> satisfy 0-        pY = "Y" <::=> (+) <$> pX <*> pY+    let pX = "X" <::=>  1 <$$ char 'a' <||> satisfy 0+        pY = "Y" <::=> (+) <$$> pX <**> pY     -- shouldn't this be 1 + infinite 0's?-    test "no parse infinite rec?" pY +    test Nothing "no parse infinite rec?" pY          [("a", [])] -    let pS = "S" <::=> ((\x y -> x+y+1) <$ char '1' <*> pS <*> pS) <|> satisfy 0    -    test "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]+    let pS = "S" <::=> ((\x y -> x+y+1) <$$ char '1' <**> pS <**> pS) <||> satisfy 0    +    test Nothing "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]  -    let pS = "S" <::=> ((\x y -> '1':x++y) <$ char '1' <*> pS <*> pS) <|> satisfy "0"-    test "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])+    let pS = "S" <::=> ((\x y -> '1':x++y) <$$ char '1' <**> pS <**> pS) <||> satisfy "0"+    test Nothing "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])                     ,(replicate 5 '1', aho_S_5)] -    let pE = "E" <::=> (\x y z -> x+y+z) <$> pE <*> pE <*> pE -                             <|> 1 <$ char '1'-                             <|> satisfy 0-    test "EEE" pE [("", [0]), ("1", [1]), ("11", [2])+    let pE = "E" <::=> (\x y z -> x+y+z) <$$> pE <**> pE <**> pE +                             <||> 1 <$$ char '1'+                             <||> satisfy 0+    test Nothing "EEE" pE [("", [0]), ("1", [1]), ("11", [2])                   ,(replicate 5 '1', [5]), ("112", [])] -    let pE = "E" <::=> (\x y z -> x++y++z) <$> pE <*> pE <*> pE -                             <|> "1" <$ char '1'-                             <|> satisfy "0"-    test "EEE ambig" pE [("", ["0"]), ("1", ["1"])+    let pE = "E" <::=> (\x y z -> x++y++z) <$$> pE <**> pE <**> pE +                             <||> "1" <$$ char '1'+                             <||> satisfy "0"+    test Nothing "EEE ambig" pE [("", ["0"]), ("1", ["1"])                         ,("11", ["110", "011", "101"]), ("111", _EEE_3)] -    let pX = "X" <::=>  maybe 0 (const 1) <$> optional (char 'z') -                    <|> (+1) <$> pX <* char '1'-    test "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])+    let pX = "X" <::=>  maybe 0 (const 1) <$$> optional (char 'z') +                    <||> (+1) <$$> pX <** char '1'+    test Nothing "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])                                     ,(replicate 100 '1', [100])]      let pX = "X" <::=> satisfy 0 -                    <|> (+1) <$ pB <*> pX <* char '1'-        pB = maybe 0 (const 0) <$> optional (char 'z')-    test "hidden left-recursion" pX +                    <||> (+1) <$$ pB <**> pX <** char '1'+        pB = maybe 0 (const 0) <$$> optional (char 'z')+    test Nothing "hidden left-recursion" pX          [("", [0]), ("zz11", [2]), ("z11", [2]), ("11", [2])         ,(replicate 100 '1', [100])]++    let pX = "X" <::=> (+) <$$> pY <**> pA+        pA = 1 <$$ char 'a' <** char 'b' <||> satisfy 0+        pY = "Y" <::=> satisfy 0 <||> pX +    test Nothing "hidden left-recursion + infinite derivations" pX+        [("", [0]), ("ab", [1]), ("ababab", [3])]++    putStrLn "Tests that use memoisation"++    let tab = newMemoTable+        pX = "X" <::=> (1 <$$ some (char 'a') <||> 2 <$$ many (char 'b'))+        pY = memo tab ("Y" <::=> (+) <$$> pX <**> pY+                   <||> satisfy 0)+    test (Just tab) "some & many & recursion + ambiguities" pY+        [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])]++    let tab = newMemoTable +        pX = "X" <::=>  1 <$$ char 'a' <||> satisfy 0+        pY = memo tab ("Y" <::=> (+) <$$> pX <**> pY)+    -- shouldn't this be 1 + infinite 0's?+    test (Just tab) "no parse infinite rec?" pY +        [("a", [])]++    --  Higher ambiguities+    let tab = newMemoTable+        pE = memo tab ("E" <::=> (\x y z -> x+y+z) <$$> pE <**> pE <**> pE +                             <||> 1 <$$ char '1'+                             <||> satisfy 0)+    test (Just tab) "EEE" pE [("", [0]), ("1", [1]), ("11", [2])+                             ,(replicate 5 '1', [5]), ("112", [])]++    let tab = newMemoTable+        pX = "X" <::=> (+) <$$> pY <**> pA+        pA = 1 <$$ char 'a' <** char 'b' <||> satisfy 0+        pY = memo tab ("Y" <::=> satisfy 0 <||> pX)+    test (Just tab) "hidden left-recursion + infinite derivations" pX+        [("", [0]), ("ab", [1]), ("ababab", [3])]+  where     aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"]      _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"]++instance Parseable Char where+    eos = '$'+    eps = '#'
− src/GLL/Combinators/Test/MemBinInterface.hs 
@@ -1,196 +0,0 @@-{-| This model contains unit-tests for 'GLL.Combinators.MemBinInterface'--= Included examples--  * Elementary parsers-  * Sequencing-  * Alternatives-  * Simple binding-  * Binding with alternatives-  * Recursion (non-left)--  * Higher-order patterns:--      * Optional-      * Kleene-closure / positive closure-      * Seperator-      * Inline choice--  * Ambiguities:--      * "aaa"-      * longambig-      * aho_s-      * EEE--  * Left recursion-  * Hidden left-recursion--}-module GLL.Combinators.Test.MemBinInterface where--import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))--import Control.Compose-import Control.Monad-import Data.Char (ord)-import Data.List (sort)-import Data.IORef-import qualified Data.Map as M-import qualified Data.IntMap as IM--import GLL.Combinators.MemBinInterface---- | Defines and executes some unit-tests -main = do-    count <- newIORef 1-    let test mref name p arg_pairs = do-            i <- readIORef count-            modifyIORef count succ-            subcount <- newIORef 'a'-            putStrLn (">> testing " ++ show i ++ " (" ++ name ++ ")")-            forM_ arg_pairs $ \(str,res) -> do-                case mref of -- empty memtable between parses-                    Nothing     -> return ()-                    Just ref    -> modifyIORef ref (const IM.empty)-                j <- readIORef subcount-                modifyIORef subcount succ-                parse_res <- parseString p str-                let norm        = sort . take 100-                    b           = norm parse_res == norm res-                putStrLn ("  >> " ++ [j,')',' '] ++ show b)-                unless b (putStrLn ("    >> " ++ show parse_res))--    -- Elementary parsers-    test Nothing "eps1" (satisfy 0) [("", [0])]-    test Nothing "eps2" (0 <$ epsilon) [("", [0]), ("111", [])]-    test Nothing "single" (char 'a') [("a", ['a'])-                    ,("abc", [])]-    test Nothing "semfun1" (1 <$ char 'a') [("a", [1])]--    -- Elementary combinators-    test Nothing "<*>" ((\b -> ['1',b]) <$> char 'a' *> char 'b')-         [("ab", ["1b"])-         ,("b", [])]-   -    -- Alternation-    test Nothing "<|>" (ord <$> char 'a' *> char 'b' <|> ord <$> char 'c')-         [("a", []), ("ab", [98]), ("c", [99]), ("cab", [])]--    -- Simple binding-    let pX = "X" <::=> ord <$> char 'a' <* char 'b'-    test Nothing "<::=>" pX [("ab",[97]),("a",[])]--    let  pX = "X" <::=> uncurry (flip (:)) <$> pY <*> char 'a'-         pY = "Y" <::=> uncurry (\x y -> [x,y]) <$> char 'b' <*> char 'c'-    test Nothing "<::=> 2" pX [("bca", ["abc"]), ("cba", [])]--    -- Binding with alternatives-    let pX = "X" <::=> pY <* char 'c'-        pY = "Y" <::=> char 'a' <|> char 'b'-    test Nothing "<::=> <|>" pX [("ac", "a"), ("bc", "b")]--    -- (Right) Recursion-    let pX = "X" <::=> (+1) <$> char 'a' *> pX <|> 0 <$ epsilon-    test Nothing "rec1" pX [("", [0]), ("aa",[2]), (replicate 42 'a', [42]), ("bbb", [])]--    -- EBNF-    let pX = "X" <::=> id <$> char 'a' *> char 'b' *> optional (char 'z')-    test Nothing "optional" pX [("abz", [Just 'z']), ("abab", []), ("ab", [Nothing])]--    let pX = "X" <::=> (char 'a' <|> char 'b')-    test Nothing "<|> optional" (pX <* optional (char 'z'))-                [("az", "a"), ("bz", "b"), ("z", []), ("b", "b"), ("a", "a")]--    let pX = "X" <::=> (1 <$ optional (char 'a') <|> 2 <$ optional (char 'b'))-    test Nothing "optional-ambig" (pX <* optional (char 'z'))-                [("az", [1]), ("bz", [2]), ("z", [1,2]), ("b", [2]), ("a", [1])]--    let pX = "X" <::=> id <$> char 'a' *> (char 'b' <|> char 'c')-    test Nothing "inline choice (1)" pX-                [("ab", "b"), ("ac", "c"), ("a", []), ("b", [])]--    let pX = "X" <::=> length <$> many (char '1')-    test Nothing "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])]--    let pX = "X" <::=> length <$> some (char '1')-    test Nothing "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])]--    let pX = "X" <::=> (1 <$ many (char 'a') <|> 2 <$ many (char 'b'))-    test Nothing "(many <|> many) <*> optional" (pX <* optional (char 'z'))-                [("az", [1]), ("bz", [2]), ("z", [1,2])-                ,("", [1,2]), ("b", [2]), ("a", [1])]--    let pX = "X" <::=> pY <* optional (char 'z')-         where pY = "Y" <::=> length <$> many (char 'a')-                          <|> length <$> some (char 'b') <* char 'e'-    test Nothing "many & some & optional" -        pX  [("aaaz", [3]), ("bbbez", [3]), ("ez", []), ("z", [0])-            ,("aa", [2]), ("bbe", [2]) -            ]--    -- Simple ambiguities-    let pX = uncurry (++) <$> pA <*> pB-        pA = "a" <$ char 'a' <|> "aa" <$ char 'a' <* char 'a'-        pB = "b" <$ char 'a' <|> "bb" <$ char 'a' <* char 'a' -    test Nothing "aaa" pX   [("aaa", ["aab", "abb"])-                    ,("aa", ["ab"])]--    let pX = (\(x,y) -> [x,y]) <$> char 'a' *> pL <*> pL <* char 'e'-        pL =    1 <$ char 'b'-            <|> 2 <$ char 'b' <* char 'c'-            <|> 3 <$ char 'c' <* char 'd'-            <|> 4 <$ char 'd'-    test Nothing "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])]--    tab1 <- newMemoTable-    let pX = "X" <::=> (1 <$ some (char 'a') <|> 2 <$ many (char 'b'))-        pY = memo tab1 ("Y" <::=> uncurry (+) <$> pX <*> pY-                   <|> satisfy 0)-    test (Just tab1) "some & many & recursion + ambiguities" pY-        [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])]--    tab <- newMemoTable-    let pX = "X" <::=>  1 <$ char 'a' <|> satisfy 0-        pY = memo tab ("Y" <::=> uncurry (+) <$> pX <*> pY)-    -- shouldn't this be 1 + infinite 0's?-    test (Just tab) "no parse infinite rec?" pY -        [("a", [])]--    -- Higher ambiguities-    let pS = "S" <::=> ((\(x,y) -> x+y+1) <$> char '1' *> pS <*> pS) <|> satisfy 0    -    test Nothing "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]---    let pS = "S" <::=> ((\(x,y) -> '1':x++y) <$> char '1' *> pS <*> pS) <|> satisfy "0"-    test Nothing "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])-                    ,(replicate 5 '1', aho_S_5)]---    tab <- newMemoTable-    let pE = memo tab ("E" <::=> (\((x,y),z) -> x+y+z) <$> pE <*> pE <*> pE -                             <|> 1 <$ char '1'-                             <|> satisfy 0)-    test (Just tab) "EEE" pE [("", [0]), ("1", [1]), ("11", [2])-                             ,(replicate 5 '1', [5]), ("112", [])]--    let pE = "E" <::=> (\((x,y),z) -> x++y++z) <$> pE <*> pE <*> pE -                             <|> "1" <$ char '1'-                             <|> satisfy "0"-    test Nothing "EEE ambig" pE [("", ["0"]), ("1", ["1"])-                                ,("11", ["110", "011", "101"]), ("111", _EEE_3)]--    let pX = "X" <::=>  maybe 0 (const 1) <$> optional (char 'z') -                    <|> (+1) <$> pX <* char '1'-    test Nothing "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])-                                            ,(replicate 100 '1', [100])]--    let pX = "X" <::=> satisfy 0 -                    <|> (+1) <$> pB *> pX <* char '1'-        pB = maybe 0 (const 0) <$> optional (char 'z')-    test Nothing "hidden left-recursion" pX -        [("", [0]), ("zz11", [2]), ("z11", [2]), ("11", [2])-        ,(replicate 100 '1', [100])]- where-    aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"]--    _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"]
− src/GLL/Combinators/Test/MemInterface.hs 
@@ -1,196 +0,0 @@-{-| This model contains unit-tests for 'GLL.Combinators.MemInterface'--= Included examples--  * Elementary parsers-  * Sequencing-  * Alternatives-  * Simple binding-  * Binding with alternatives-  * Recursion (non-left)--  * Higher-order patterns:--      * Optional-      * Kleene-closure / positive closure-      * Seperator-      * Inline choice--  * Ambiguities:--      * "aaa"-      * longambig-      * aho_s-      * EEE--  * Left recursion-  * Hidden left-recursion--}-module GLL.Combinators.Test.MemInterface where--import Prelude hiding ((<$>),(<*>),(<*),(<$))--import Control.Compose-import Control.Monad-import Data.Char (ord)-import Data.List (sort,nub)-import Data.IORef-import qualified Data.Map as M-import qualified Data.IntMap as IM--import GLL.Combinators.MemInterface---- | Defines and executes some unit-tests -main = do-    count <- newIORef 1-    let test mref name p arg_pairs = do-            i <- readIORef count-            modifyIORef count succ-            subcount <- newIORef 'a'-            putStrLn (">> testing " ++ show i ++ " (" ++ name ++ ")")-            forM_ arg_pairs $ \(str,res) -> do-                case mref of -- empty memtable between parses-                    Nothing     -> return ()-                    Just ref    -> modifyIORef ref (const IM.empty)-                j <- readIORef subcount-                modifyIORef subcount succ-                parse_res <- parseString p str-                let norm        = take 100 . sort . nub-                    b           = norm parse_res == norm res-                putStrLn ("  >> " ++ [j,')',' '] ++ show b)-                unless b (putStrLn ("    >> " ++ show parse_res))--    --  Elementary parsers-    test Nothing "eps1" (satisfy 0) [("", [0])]-    test Nothing "eps2" (0 <$ epsilon) [("", [0]), ("111", [])]-    test Nothing "single" (char 'a') [("a", ['a'])-                    ,("abc", [])]-    test Nothing "semfun1" (1 <$ char 'a') [("a", [1])]--    --  Elementary combinators-    test Nothing "<*>" ((\b -> ['1',b]) <$ char 'a' <*> char 'b')-         [("ab", ["1b"])-         ,("b", [])]-   -    --  Alternation-    test Nothing "<|>" (ord <$ char 'a' <*> char 'b' <|> ord <$> char 'c')-         [("a", []), ("ab", [98]), ("c", [99]), ("cab", [])]--    --  Simple binding-    let pX = "X" <::=> ord <$> char 'a' <* char 'b'-    test Nothing "<::=>" pX [("ab",[97]),("a",[])]--    let  pX = "X" <::=> (flip (:)) <$> pY <*> char 'a'-         pY = "Y" <::=> (\x y -> [x,y]) <$> char 'b' <*> char 'c'-    test Nothing "<::=> 2" pX [("bca", ["abc"]), ("cba", [])]--    --  Binding with alternatives-    let pX = "X" <::=> pY <* char 'c'-        pY = "Y" <::=> char 'a' <|> char 'b'-    test Nothing "<::=> <|>" pX [("ac", "a"), ("bc", "b")]--    --  (Right) Recursion-    let pX = "X" <::=> (+1) <$ char 'a' <*> pX <|> 0 <$ epsilon-    test Nothing "rec1" pX [("", [0]), ("aa",[2]), (replicate 42 'a', [42]), ("bbb", [])]--    --  EBNF-    let pX = "X" <::=> id <$ char 'a' <* char 'b' <*> optional (char 'z')-    test Nothing "optional" pX [("abz", [Just 'z']), ("abab", []), ("ab", [Nothing])]--    let pX = "X" <::=> (char 'a' <|> char 'b')-    test Nothing "<|> optional" (pX <* optional (char 'z'))-                [("az", "a"), ("bz", "b"), ("z", []), ("b", "b"), ("a", "a")]--    let pX = "X" <::=> (1 <$ optional (char 'a') <|> 2 <$ optional (char 'b'))-    test Nothing "optional-ambig" (pX <* optional (char 'z'))-                [("az", [1]), ("bz", [2]), ("z", [1,2]), ("b", [2]), ("a", [1])]--    let pX = "X" <::=> id <$ char 'a' <*> (char 'b' <|> char 'c')-    test Nothing "inline choice (1)" pX-                [("ab", "b"), ("ac", "c"), ("a", []), ("b", [])]--    let pX = "X" <::=> length <$> many (char '1')-    test Nothing "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])]--    let pX = "X" <::=> length <$> some (char '1')-    test Nothing "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])]--    let pX = "X" <::=> (1 <$ many (char 'a') <|> 2 <$ many (char 'b'))-    test Nothing "(many <|> many) <*> optional" (pX <* optional (char 'z'))-                [("az", [1]), ("bz", [2]), ("z", [1,2])-                ,("", [1,2]), ("b", [2]), ("a", [1])]--    let pX = "X" <::=> pY <* optional (char 'z')-         where pY = "Y" <::=> length <$> many (char 'a')-                          <|> length <$> some (char 'b') <* char 'e'-    test Nothing "many & some & optional" -        pX  [("aaaz", [3]), ("bbbez", [3]), ("ez", []), ("z", [0])-            ,("aa", [2]), ("bbe", [2]) -            ]--    --  Simple ambiguities-    let pX = (++) <$> pA <*> pB-        pA = "a" <$ char 'a' <|> "aa" <$ char 'a' <* char 'a'-        pB = "b" <$ char 'a' <|> "bb" <$ char 'a' <* char 'a' -    test Nothing "aaa" pX   [("aaa", ["aab", "abb"])-                    ,("aa", ["ab"])]--    let pX = (\x y -> [x,y]) <$ char 'a' <*> pL <*> pL <* char 'e'-        pL =    1 <$ char 'b'-            <|> 2 <$ char 'b' <* char 'c'-            <|> 3 <$ char 'c' <* char 'd'-            <|> 4 <$ char 'd'-    test Nothing "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])]--    tab1 <- newMemoTable-    let pX = "X" <::=> (1 <$ some (char 'a') <|> 2 <$ many (char 'b'))-        pY = memo tab1 ("Y" <::=> (+) <$> pX <*> pY-                   <|> satisfy 0)-    test (Just tab1) "some & many & recursion + ambiguities" pY-        [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])]--    tab <- newMemoTable-    let pX = "X" <::=>  1 <$ char 'a' <|> satisfy 0-        pY = memo tab ("Y" <::=> (+) <$> pX <*> pY)-    -- shouldn't this be 1 + infinite 0's?-    test (Just tab) "no parse infinite rec?" pY -        [("a", [])]--    --  Higher ambiguities-    let pS = "S" <::=> ((\x y -> x+y+1) <$ char '1' <*> pS <*> pS) <|> satisfy 0    -    test Nothing "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]---    let pS = "S" <::=> ((\x y -> '1':x++y) <$ char '1' <*> pS <*> pS) <|> satisfy "0"-    test Nothing "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])-                    ,(replicate 5 '1', aho_S_5 )]---    tab <- newMemoTable-    let pE = memo tab ("E" <::=> (\x y z -> x+y+z) <$> pE <*> pE <*> pE -                             <|> 1 <$ char '1'-                             <|> satisfy 0)-    test (Just tab) "EEE" pE [("", [0]), ("1", [1]), ("11", [2])-                             ,(replicate 5 '1', [5]), ("112", [])]--    let pE = "E" <::=> (\x y z -> x++y++z) <$> pE <*> pE <*> pE -                             <|> "1" <$ char '1'-                             <|> satisfy "0"-    test Nothing "EEE ambig" pE [("", ["0"]), ("1", ["1"])-                                ,("11", ["110", "011", "101"]), ("111", _EEE_3)]--    let pX = "X" <::=>  maybe 0 (const 1) <$> optional (char 'z') -                    <|> (+1) <$> pX <* char '1'-    test Nothing "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])-                                            ,(replicate 100 '1', [100])]--    let pX = "X" <::=> satisfy 0 -                    <|> (+1) <$ pB <*> pX <* char '1'-        pB = maybe 0 (const 0) <$> optional (char 'z')-    test Nothing "hidden left-recursion" pX -        [("", [0]), ("zz11", [2]), ("z11", [2]), ("11", [2])-        ,(replicate 100 '1', [100])]- where-    aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"]--    _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"]
+ src/GLL/Combinators/Visit/Grammar.hs view
@@ -0,0 +1,22 @@++module GLL.Combinators.Visit.Grammar where++import GLL.Types.Abstract++import qualified Data.Map as M++type Grammar_Expr t = M.Map Nt [Prod t] -> M.Map Nt [Prod t]++grammar_nterm :: Nt -> [Prod t] -> [Grammar_Expr t] -> Grammar_Expr t+grammar_nterm x alts ps rules +    | x `M.member` rules = rules+    | otherwise = foldr ($) (M.insert x alts rules) $ ps ++grammar_apply :: Grammar_Expr t -> Grammar_Expr t+grammar_apply = id++grammar_seq :: Grammar_Expr t -> Grammar_Expr t -> Grammar_Expr t+grammar_seq p q rules =+    let rules1  = q rules+        rules2  = p rules1 in rules2+
+ src/GLL/Combinators/Visit/Sem.hs view
@@ -0,0 +1,74 @@++module GLL.Combinators.Visit.Sem where++import GLL.Combinators.Options+import GLL.Types.Abstract+import GLL.Types.Grammar++import Control.Monad (forM)+import qualified Data.Array as A+import qualified Data.IntMap as IM+import qualified Data.Set as S++type Sem_Symb t a = PCOptions -> Ancestors t +                        -> SPPF t -> A.Array Int t -> Int -> Int -> IO [a]+type Sem_Alt  t a = PCOptions -> (Prod t,Int) -> Ancestors t +                        -> SPPF t -> A.Array Int t -> Int -> Int -> IO [(Int,a)]++sem_nterm :: Bool -> Bool -> Nt -> [Prod t] -> [Sem_Alt t a] -> Sem_Symb t a+sem_nterm use_ctx left_biased x alts ps opts ctx sppf arr l r =+        let ctx' = ctx `toAncestors` (x,l,r)+            sems = zip alts ps +            seq (alt@(Prod _ rhs), va3) = va3 opts (alt,length rhs) ctx' sppf arr l r +        in if use_ctx && ctx `inAncestors` (Nt x, l, r) +                then return []+                else do ass <- forM sems seq+                        let choices = case (pivot_select_nt opts, pivot_select opts) of+                                        (True,Just compare) -> maintainWith compare ass+                                        _                   -> ass+                        return (concatChoice left_biased opts (map (map snd) choices))+ where+    concatChoice :: Bool -> PCOptions -> [[a]] -> [a]+    concatChoice left_biased opts ress = +        if left_biased || left_biased_choice opts+        then firstRes ress+        else concat ress+     where  firstRes []         = []+            firstRes ([]:ress)  = firstRes ress+            firstRes (res:_)    = res++sem_apply :: Ord t => (a -> b) -> Sem_Symb t a -> Sem_Alt t b+sem_apply f p opts (alt,j) ctx sppf arr l r = +        let op f a = (r,f a)+        in do   as <- p opts ctx sppf arr l r+                return (maybe [] (const (map (op f) as)) $ sppf `pNodeLookup` ((alt,1),l,r))++sem_seq :: Ord t => Sem_Alt t (a -> b) -> Sem_Symb t a -> Sem_Alt t b +sem_seq p q opts (alt@(Prod x rhs),j) ctx sppf arr l r = +    let ks      = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)+        choices = case pivot_select opts of+                    Nothing      -> ks+                    Just compare -> maximumsWith compare ks+        seq k  = do     as      <- q opts ctx sppf arr k r+                        a2bs    <- p opts(alt,j-1) ctx sppf arr l k+                        return [ (k,a2b a) | (_,a2b) <- a2bs, a <- as ]+    in do   ass <- forM choices seq+            return (concat ass)++--- contexts+type Ancestors t = IM.IntMap (IM.IntMap (S.Set Nt))++inAncestors :: Ancestors t -> (Symbol t, Int, Int) -> Bool+inAncestors ctx (Term _, _, _) = False+inAncestors ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx+ where  inner = maybe False (S.member x) . IM.lookup r++toAncestors :: Ancestors t -> (Nt, Int, Int) -> Ancestors t+toAncestors ctx (x, l, r) = IM.alter inner l ctx+ where  inner mm = case mm of +                    Nothing -> Just $ singleRX+                    Just m  -> Just $ IM.insertWith (S.union) r singleX m+        singleRX = IM.singleton r singleX+        singleX  = S.singleton x++
src/GLL/Parser.hs view
@@ -1,150 +1,378 @@++{-|+Implementation of the GLL parsing algorithm [Scott and Johnstone 2010,2013]+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 orderable.+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.++"GLL.Parser" exports 'Prod' for constructing 'Grammar's.++@+grammar1 = (\"X\", [Prod \"X\" [Nt \"A\", Nt \"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 (given that the +packed node stores the left and right extent of its parent).+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") to option+'strictBinarisation' is available.++=== Combinator interface+Module "GLL.Combinators.Interface" provides a combinator interface to access+"GLL.Parser". Applicative-like combinators are used to extract a 'Grammar' and+call 'parse'. The 'SPPF' is then used to produce semantic results.++-} module GLL.Parser (-        gllSPPF              -- run the parser-      , charS, charT, nT, epsilon   -- create terminals-      , pNodeLookup, ParseResult(..)+        -- * Grammar+        Grammar(..), Prods(..), Prod(..), Symbols(..), Symbol(..), Slot(..),+        -- ** Parseable tokens +        Parseable(..),+        -- * Run the GLL parser+        parse, +        -- ** Run the GLL parser with options+        parseWithOptions,+        -- *** Options+        strictBinarisation, fullSPPF, allNodes, packedNodesOnly, maximumErrors,+        -- ** Result+        ParseResult(..), SPPF(..), SPPFNode(..), SymbMap, ImdMap, PackMap, EdgeMap,      ) where  import Data.Foldable hiding (forM_, toList, sum) import Prelude  hiding (lookup, foldr, fmap, foldl, elem) import Control.Monad-import Control.Applicative hiding (empty)-import Data.Map (Map(..), empty, insertWith, (!), toList, lookup)-import Data.Set (member, Set(..)) 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 Text.PrettyPrint.HughesPJ as PP  import GLL.Types.Abstract import GLL.Types.Grammar  -- | Representation of the input string-type Input          =   A.Array Int Token+type Input t        =   A.Array Int t   -- | Types for -type LhsParams      =   (Nt     , Int   , GSSNode)-type RhsParams      =   (Slot   , Int   , GSSNode)+type LhsParams t    =   (Nt     , Int   , GSSNode t)+type RhsParams t    =   (Slot t , Int   , GSSNode t)  -- | The worklist and descriptor set-type Rcal           =   [(RhsParams,SPPFNode)]-type Ucal           =   IM.IntMap (IM.IntMap (S.Set (Slot, GSlot)))+type Rcal t         =   [(RhsParams t, SPPFNode t)]+type Ucal t         =   IM.IntMap (IM.IntMap (S.Set (Slot t, GSlot t)))  -- | GSS representation-type GSS            =   IM.IntMap (M.Map GSlot [GSSEdge])-type GSSEdge        =   (GSSNode, SPPFNode)-type GSSNode        =   (GSlot, Int)-data GSlot          =   GSlot Slot+type GSS t          =   IM.IntMap (M.Map (GSlot t) [GSSEdge t])+type GSSEdge t      =   (GSSNode t, SPPFNode t)+type GSSNode t      =   (GSlot t, Int)+data GSlot t        =   GSlot (Slot t)                     |   U0      deriving (Ord, Eq) +type MisMatches t   =   IM.IntMap (S.Set t)  -- | Pop-set-type Pcal           =   IM.IntMap (Map GSlot [Int])+type Pcal t         =   IM.IntMap (M.Map (GSlot t) [Int])  -- | Connecting it all-type Mutable        =   (SPPF,Rcal, Ucal, GSS, Pcal)+data Mutable t      =   Mutable { mut_success       :: Bool+                                , mut_sppf          :: SPPF t+                                , mut_worklist      :: Rcal t+                                , mut_descriptors   :: Ucal t+                                , mut_gss           :: GSS t+                                , mut_popset        :: Pcal t +                                , mut_mismatches    :: MisMatches t +                                }  -- | Monad for implicitly passing around 'context'-data GLL a          =   GLL (Mutable -> (a, Mutable))+data GLL t a        =   GLL (Flags -> Mutable t -> (a, Mutable t)) -addDescr        ::  SPPFNode -> RhsParams  ->   GLL ()-getDescr        ::  GLL (Maybe (RhsParams,SPPFNode))-addSPPFEdge     ::  SPPFNode    -> SPPFNode     ->  GLL ()-addPop          ::  GSSNode     -> Int          ->  GLL () -getChildren     ::  GSSNode                     ->  GLL [GSSEdge]-addGSSEdge      ::  GSSNode     -> GSSEdge      ->  GLL ()-getPops         ::  GSSNode     -> GLL [Int]-joinSPPFs       ::  Slot -> SPPFNode -> Int -> Int -> Int -                            -> GLL SPPFNode-runGLL :: GLL a -> Mutable -> Mutable-runGLL (GLL f) p = snd $ f p-addSPPFEdge f t = GLL $ \(sppf,r,u,gss,p) -> -       ((), -        (-        pMapInsert f t $-            sppf-        ,r,u,gss,p))+runGLL :: GLL t a -> Flags -> Mutable t -> Mutable t+runGLL (GLL f) o p = snd $ f o p -addDescr sppf alt@(slot,i,(gs,l)) = GLL $ \(dv,r,u,gss,p) -> -    let new     = maybe True inner $ IM.lookup i u-          where inner m = maybe True (not . ((slot,gs) `S.member`)) $ IM.lookup l m  -        newU = IM.alter inner i u+addSPPFEdge f t = GLL $ \flags mut -> +    let sppf' = (if symbol_nodes flags          then sNodeInsert f t else id) $+                (if intermediate_nodes flags    then iNodeInsert f t else id) $+                (if edges flags                 then eMapInsert f t  else id) $ +                    pMapInsert f t (mut_sppf mut)+    in ((),mut{mut_sppf = sppf'})++addDescr sppf alt@(slot,i,(gs,l)) = GLL $ \_ mut -> +    let new     = maybe True inner $ IM.lookup i (mut_descriptors mut)+          where inner m = maybe True (not . ((slot,gs) `S.member`)) $ IM.lookup l m+        newU = IM.alter inner i (mut_descriptors mut)          where inner mm = case mm of                               Nothing -> Just $ IM.singleton l single                               Just m  -> Just $ IM.insertWith (S.union) l single m                single = S.singleton (slot,gs)-     in if new then ((), (dv, (alt,sppf):r, newU, gss , p))-               else ((), (dv, r, u, gss, p))+     in if new then ((), mut{mut_worklist       = (alt,sppf):(mut_worklist mut)+                            ,mut_descriptors    = newU})+               else ((), mut) -getDescr = GLL $ \(dv,r,u,gss,p) -> -    case r of -        []              -> (Nothing, (dv,r,u,gss,p))-        (next@(alt,sppf):rest)     -> -            let res = (Just next, (dv,rest,u,gss,p))-            in res+getDescr = GLL $ \_ mut -> +    case mut_worklist mut of +        []                      -> (Nothing, mut)+        (next@(alt,sppf):rest)  -> (Just next, mut{mut_worklist = rest}) -addPop (gs,l) i = GLL $ \(dv,r,u,gss,p) ->-    let newP = IM.alter inner l p+addPop (gs,l) i = GLL $ \_ mut ->+    let newP = IM.alter inner l (mut_popset mut)          where inner mm = case mm of                              Nothing -> Just $ M.singleton gs [i]                             Just m  -> Just $ M.insertWith (++) gs [i] m-    in ((), (dv,r,u,gss,newP))+    in ((), mut{mut_popset = newP}) -getChildren (gs,l) = GLL $ \(dv,r,u,gss,p) ->-    let res = maybe [] inner $ IM.lookup l gss+getChildren (gs,l) = GLL $ \_ mut ->+    let res = maybe [] inner $ IM.lookup l (mut_gss mut)          where inner m = maybe [] id $ M.lookup gs m-     in (res, (dv,r,u,gss,p))+     in (res, mut) -addGSSEdge f@(gs,i) t = GLL $ \(dv,r,u,gss,p) -> -    let newGSS = IM.alter inner i gss+addGSSEdge f@(gs,i) t = GLL $ \_ mut -> +    let newGSS = IM.alter inner i (mut_gss mut)          where inner mm = case mm of                              Nothing -> Just $ M.singleton gs [t]                              Just m  -> Just $ M.insertWith (++) gs [t] m-    in ((), (dv,r,u,newGSS,p))+    in ((), mut{mut_gss = newGSS}) -getPops (gs,l) = GLL $ \ctx@(dv,r,u,gss,p) -> -    let res = maybe [] inner $ IM.lookup l p+getPops (gs,l) = GLL $ \_ mut -> +    let res = maybe [] inner $ IM.lookup l (mut_popset mut)          where inner = maybe [] id .  M.lookup gs-    in (res, ctx)+    in (res, mut) -instance Show GSlot where+addSuccess = GLL $ \_ mut -> ((),mut{mut_success = True})++getFlags = GLL $ \fs ctx -> (fs, ctx)++addMisMatch :: (Ord t) => Int -> S.Set t -> GLL t ()+addMisMatch k ts = GLL $ \flags mut -> +    let newM    = IM.insertWith S.union k ts (mut_mismatches mut)+        newM'   | length (IM.keys newM) > max_errors flags = IM.deleteMin newM+                | otherwise                                = newM+    in ((), mut{mut_mismatches = newM'})++instance (Show t) => Show (GSlot t) where     show (U0)       = "u0"     show (GSlot gn) = show gn -instance Show SPPFNode where+instance (Show t) => Show (SPPFNode t) where     show (SNode (s, l, r))  = "(s: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")"     show (INode (s, l, r))  = "(i: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")"     show (PNode (p, l, k, r))  = "(p: " ++ show p ++ ", " ++ show l ++ ", " ++ show k ++ ", " ++ show r ++ ")"     show Dummy              = "$" -instance Applicative GLL where+instance Applicative (GLL t) where     (<*>) = ap     pure  = return-instance Functor GLL where+instance Functor (GLL t) where     fmap  = liftM-instance Monad GLL where-    return a = GLL $ \p -> (a, p)-    (GLL m) >>= f  = GLL $ \p -> let (a, p')  = m p-                                     (GLL m') = f a-                                    in m' p'-gllSPPF :: Grammar -> [Token] -> ParseResult -gllSPPF grammar@(Grammar start _ _ ) input = -    let (mutable,_,_,_) = gll m False grammar input-        m = length input-    in resultFromMutable mutable (Nt start, 0, m)+instance Monad (GLL t) where+    return a = GLL $ \_ p -> (a, p)+    (GLL m) >>= f  = GLL $ \o p -> let (a, p')  = m o p+                                       (GLL m') = f a+                                    in m' o p' -gll :: Int -> Bool -> Grammar -> [Token] -> (Mutable, [Alt], SelectMap, FollowMap)-gll m debug (Grammar start _ rules) input' = -    (runGLL (pLhs (start, 0, (U0,0))) context, prs, selects, follows)- where -    prs     = [ alt | Rule _ alts <- rules, alt <- (reverse alts) ]-    context = (emptySPPF, [], IM.empty, IM.empty, IM.empty)-    input   = A.array (0,m) $ zip [0..] $ input' ++ [EOS]+data Flags   = Flags    { symbol_nodes          :: Bool+                        , intermediate_nodes    :: Bool+                        , edges                 :: Bool+                        , flexible_binarisation :: Bool+                        , max_errors            :: Int+                        }+defaultOptions = Flags False False False True 3+runOptions = foldr ($) defaultOptions -    dispatch    ::                                  GLL ()-    pLhs        :: LhsParams                    ->  GLL () -    pRhs        :: RhsParams    ->  SPPFNode    ->  GLL ()+type Option = Flags -> Flags+type Options = [Option] +-- | +-- Create the 'SPPF' with all nodes and edges, not necessarily strictly binarised.+fullSPPF :: Option+fullSPPF flags = flags{symbol_nodes = True, intermediate_nodes = True, edges = True}++-- |+-- Create all nodes, but no edges between nodes.+allNodes :: Option+allNodes flags = flags{symbol_nodes = True, intermediate_nodes = True}++-- | +-- Create packed-nodes only.+packedNodesOnly :: Option+packedNodesOnly flags = flags{symbol_nodes = False, intermediate_nodes = False, edges = False}++-- | +-- Fully binarise the SPPF, resulting in a larger 'SPPF' and possibly slower runtimes.+-- When this flag is on, packed nodes can only have a single symbol node child +-- or one intermediate node child and one symbol node child.+-- With the flag disabled a packed node can have two symbol node children.+strictBinarisation :: Option+strictBinarisation flags = flags{flexible_binarisation = False}++-- | +-- Set the maximum number of errors shown in case of an unsuccessful parse.+maximumErrors :: Int -> Option+maximumErrors n flags = flags {max_errors = n}++-- | +-- 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 = parseWithOptions [] ++-- | +-- 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+parseWithOptions :: Parseable t => [Option] -> Grammar t -> [t] -> ParseResult t+parseWithOptions opts grammar@(start,_) str = +    let flags           = runOptions opts+        (mutable,_,_,_) = gll flags m False grammar input+        m = length str +        input   = A.array (0,m) $ zip [0..] $ str ++ [eos]+    in resultFromMutable input flags mutable (Nt start, 0, m)++gll :: Parseable t => Flags -> Int -> Bool -> Grammar t -> Input t -> +            (Mutable t, [Prod t], SelectMap t, FollowMap t)+gll flags m debug (start, prods) input = +    (runGLL (pLhs (start, 0, (U0,0))) flags context, prs, selects, follows)+ where +    prs     = [ alt | alt <- (reverse prods) ]+    context = Mutable False emptySPPF [] IM.empty IM.empty IM.empty IM.empty+     dispatch = do         mnext <- getDescr         case mnext of@@ -152,28 +380,30 @@             Just (next,sppf)   -> pRhs next sppf      pLhs (bigx, i, gn) = do -        let     alts  =  [  (Slot bigx [] beta, i, gn) | (Alt bigx beta) <- altsOf bigx-                         ,  select (input A.! i) beta bigx+        let     alts  =  [  ((Slot bigx [] beta, i, gn), first_ts) +                         | Prod bigx beta <- altsOf bigx+                         , let first_ts = select beta bigx                           ]-        forM_ alts (addDescr Dummy)+                first_ts = S.unions (map snd alts)+                cands = [ descr | (descr, first_ts) <- alts+                                , any (matches (input A.! i)) first_ts ]+        if null cands+            then addMisMatch i first_ts+            else forM_ cands (addDescr Dummy)         dispatch  -    pRhs (Slot bigx [] [Term Epsilon], i, (gs,l)) _  = do-        root <- joinSPPFs slot Dummy l i i-        pRhs (slot, i, (gs,l)) root-     where  slot    = Slot bigx [Term Epsilon] []-     pRhs (Slot bigx alpha ((Term tau):beta), i, (gs,l)) sppf = -     if (input A.! i == tau) +     if (input A.! i `matches` tau)        then do -- token test          root <-  joinSPPFs slot sppf l i (i+1)          pRhs (slot, i+1, (gs,l)) root -      else+      else do+        addMisMatch i (S.singleton tau)         dispatch      where  slot       = Slot bigx (alpha++[Term tau]) beta      pRhs (Slot bigx alpha ((Nt bigy):beta), i, (gs, l)) sppf = -      if (select (input A.! i) ((Nt bigy):beta) bigx) +      if any (matches (input A.! i)) first_ts         then do           addGSSEdge ret ((gs,l), sppf)            rs <- getPops ret     -- has ret been popped?@@ -181,13 +411,24 @@                           root <- joinSPPFs slot sppf l i r                           addDescr root (slot, r, (gs,l))           pLhs (bigy, i, ret)-        else+        else do+          addMisMatch i first_ts           dispatch      where  ret      = (GSlot slot, i)             slot     = Slot bigx (alpha++[Nt bigy]) beta+            first_ts = select ((Nt bigy):beta) bigx  -    pRhs (Slot bigy alpha [], i, (U0,0)) sppf = dispatch +    pRhs (Slot bigy alpha [], i, (U0,_)) sppf = do+        when (bigy /= start) (error "assert: start symbol with U0") +        if i == m +            then addSuccess >> dispatch +            else addMisMatch i (S.singleton eos) >> dispatch +    pRhs (Slot bigx alpha [], i, (gs,l)) Dummy  = do+        root <- joinSPPFs slot Dummy l i i+        pRhs (slot, i, (gs,l)) root+     where  slot    = Slot bigx [] []+     pRhs (Slot bigy alpha [], i, gn@(GSlot slot,l)) ynode = do         addPop gn i         returns <- getChildren gn@@ -197,54 +438,101 @@         dispatch      (prodMap,_,_,follows,selects)   = fixedMaps start prs-    follow x          = follows ! x-    select t rhs x    = t `member` (selects ! (x,rhs))-    altsOf x          = prodMap ! x+    follow x          = follows M.! x+    select rhs x      = selects M.! (x,rhs)+    altsOf x          = prodMap M.! x     merge m1 m2 = IM.unionWith inner m1 m2      where inner  = IM.unionWith S.union  -joinSPPFs (Slot bigx alpha beta) sppf l k r =-    case (sppf, beta) of---        (Dummy, _:_)    ->  return snode-        (Dummy, [])     ->  do  addSPPFEdge xnode pnode-                                addSPPFEdge pnode snode-                                return xnode-        (_, [])         ->  do  addSPPFEdge xnode pnode-                                addSPPFEdge pnode sppf-                                addSPPFEdge pnode snode-                                return xnode-        _               ->  do  addSPPFEdge inode pnode-                                addSPPFEdge pnode sppf-                                addSPPFEdge pnode snode-                                return inode+joinSPPFs (Slot bigx alpha beta) sppf l k r = do+    flags <- getFlags+    case (flexible_binarisation flags, sppf, beta) of+        (True,Dummy, _:_) ->  return snode+        (_,Dummy, [])     ->  do  addSPPFEdge xnode pnode+                                  addSPPFEdge pnode snode+                                  return xnode+        (_,_, [])         ->  do  addSPPFEdge xnode pnode+                                  addSPPFEdge pnode sppf+                                  addSPPFEdge pnode snode+                                  return xnode+        _                 ->  do  addSPPFEdge inode pnode+                                  addSPPFEdge pnode sppf+                                  addSPPFEdge pnode snode+                                  return inode  where  x       =   last alpha  -- symbol before the dot         snode   =   SNode (x, k, r)              xnode   =   SNode (Nt bigx, l, r)         inode   =   INode ((Slot bigx alpha beta), l, r)         pnode   =   PNode ((Slot bigx alpha beta), l, k, r) -data ParseResult = ParseResult  { sppf_result       :: SPPF-                                , success           :: Bool-                                , nr_descriptors    :: Int-                                , nr_sppf_edges     :: Int-                                , nr_gss_nodes      :: Int+-- | +-- 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{ sppf_result               :: SPPF t+                                , res_success               :: Bool+                                , nr_descriptors            :: Int+                                , nr_symbol_nodes           :: Int+                                , nr_intermediate_nodes     :: Int+                                , nr_packed_nodes           :: Int+                                , nr_sppf_edges             :: Int+                                , nr_gss_nodes              :: Int+                                , nr_gss_edges              :: Int+                                , error_message             :: String                                 } -resultFromMutable :: Mutable -> SNode -> ParseResult-resultFromMutable (sppf@(_,_,_,eMap,_),_,u,gss,_) s_node =-    ParseResult sppf success usize sppf_edges gsssize- where  success     = sppf `sNodeLookup` s_node+resultFromMutable :: (Show t, Ord t) => Input t -> Flags -> Mutable t -> SNode t -> ParseResult t+resultFromMutable inp flags mutable s_node@(s, l, m) =+    let u           = mut_descriptors mutable+        gss         = mut_gss mutable         usize       = sum  [ S.size s   | (l, r2s) <- IM.assocs u                                         , (r,s) <- IM.assocs r2s ]+        s_nodes     = sum [ S.size s    | (l, r2s) <- IM.assocs sMap+                                        , (r, s)   <- IM.assocs r2s ] + m+        i_nodes     = sum [ S.size s    | (l, r2s) <- IM.assocs iMap+                                        , (r, s)   <- IM.assocs r2s ]+        p_nodes     = sum [ IS.size ks  | (l, r2j) <- IM.assocs pMap+                                        , (r, j2s) <- IM.assocs r2j+                                        , (j, s2k) <- IM.assocs j2s+                                        , (s, ks)  <- M.assocs s2k ]         sppf_edges  = sum [ S.size ts | (_, ts) <- M.assocs eMap ]-        gsssize     = 1 + sum [ length $ M.keys x2s| (l,x2s) <- IM.assocs gss] +        gss_nodes   = 1 + sum [ length $ M.keys x2s| (l,x2s) <- IM.assocs gss] +        gss_edges   = 1 + sum [ length s    | (l,x2s) <- IM.assocs gss+                                            , (x,s)   <- M.assocs x2s ]+        sppf@(sMap, iMap, pMap, eMap) = mut_sppf mutable+    in ParseResult sppf (mut_success mutable) usize s_nodes i_nodes p_nodes sppf_edges gss_nodes gss_edges (renderErrors inp flags (mut_mismatches mutable)) -instance Show ParseResult where-    show res = unlines $-        [   "Success: "     ++ show (success res)-        ,   "Descriptors: " ++ show (nr_descriptors res)-        ,   "SPPFEdges: "   ++ show (nr_sppf_edges res)-        ,   "GSSNodes: "    ++ show (nr_gss_nodes res)-        ]+renderErrors :: Show t => Input t -> Flags -> MisMatches t -> String+renderErrors inp flags mm = render doc + where  n       = max_errors flags+        locs    = reverse (IM.assocs mm)+        doc     = text ("Unsuccessful parse, showing "++ show n ++ " furthest matches") $+$+                    foldr (\loc -> (ppLoc loc $+$)) PP.empty locs +        ppLoc (k, ts) = text ("did not match at position " ++ show k ++ ":") $+$+                            nest 4 (text (show token)) $+$+                            nest 4 (text "expected:") $+$+                                nest 8 (vcat (map ppExp (S.toList ts)))+         where  token = inp A.! k+        ppExp = text . show++instance Show (ParseResult t) where+    show res | res_success res =  unlines $+                [   "Descriptors:        "  ++ show (nr_descriptors res)+                ,   "Symbol nodes:       "  ++ show (nr_symbol_nodes res)+                ,   "Intermediate nodes: "  ++ show (nr_intermediate_nodes res)+                ,   "Packed nodes:       "  ++ show (nr_packed_nodes res)+                ,   "SPPF edges:         "  ++ show (nr_sppf_edges res)+                ,   "GSS nodes:          "  ++ show (nr_gss_nodes res)+                ,   "GSS edges:          "  ++ show (nr_gss_edges res)+                ]+             | otherwise = error_message res
src/GLL/Types/Abstract.hs view
@@ -1,41 +1,117 @@+{-# LANGUAGE StandaloneDeriving #-}   -- UUAGC 0.9.52.1 (src/GLL/Types/Abstract.ag) module GLL.Types.Abstract where {-# LINE 1 "src/GLL/Types/Abstract.ag" #-} -import qualified    Data.Map as M-import qualified    Data.Set as S -import              Data.List (delete, (\\), elemIndices, findIndices) {-# LINE 12 "dist/build/GLL/Types/Abstract.hs" #-} --- | Identifier for non-terminals+-- | Identifier for nonterminals. type Nt  = String--- Alt ----------------------------------------------------------data Alt = Alt (Nt) (Symbols)--- Alts ---------------------------------------------------------type Alts = [Alt]+-- Prod ---------------------------------------------------------++-- | +-- A production binds a nonterminal identifier (left-hand side) to a list of symbols +--(the right-hand side of the production).+data Prod t = Prod (Nt) (Symbols t)+-- Prods --------------------------------------------------------+-- | A list of 'Prod's.+type Prods t = [Prod t] -- Grammar ------------------------------------------------------data Grammar = Grammar (Nt) (([(String,String)])) (Rules)--- Rule ---------------------------------------------------------data Rule = Rule (Nt) (Alts)--- Rules --------------------------------------------------------type Rules = [Rule]+-- |+-- A grammar is a start symbol and a list of productions. +type Grammar t = (Nt, Prods t) -- Slot ---------------------------------------------------------data Slot = Slot (Nt) (([Symbol])) (([Symbol]))+-- | +-- A grammar slot acts as a label to identify progress of matching a production.+-- As such, a slot is a "Prod" with its right-hand side split in two: +-- a part before and a part after 'the dot'.+-- The dot indicates which part of the right-hand side has been processed thus far.+data Slot t = Slot (Nt) (([Symbol t])) (([Symbol t])) -- Symbol -------------------------------------------------------data Symbol = Nt (String)-            | Term (Token)-            | Error (Token) (Token)++-- | +-- A 'Symbol' is either a nonterminal or a terminal,+-- where a terminal contains some arbitrary token.+data Symbol t   = Nt Nt+                | Term t+--                | Error (Token) (Token) -- Symbols ------------------------------------------------------type Symbols = [Symbol]++-- | +-- A list of 'Symbol's+type Symbols t = [Symbol t] -- Token --------------------------------------------------------data Token = Char (Char)++-- |+-- A datatype for representing tokens with some builtins +-- and an aribitrary Token constructor.+-- This datatype stores (optional) lexemes.+data Token = Char       Char+           | Keyword    String            | EOS            | Epsilon-           | Int (((Maybe Int)))-           | Bool (((Maybe Bool)))-           | String (((Maybe String)))-           | Token (String) (((Maybe String)))+           | IntLit     (Maybe Int)+           | BoolLit    (Maybe Bool)+           | StringLit  (Maybe String)+           | IDLit      (Maybe String)+           | Token String (Maybe String) -- Tokens ------------------------------------------------------+-- | +-- A list of 'Token's type Tokens = [Token]++-- | Class that captures elements of an input string (tokens).+-- +-- * 'eos' is the end-of-string symbol  +-- * 'eps' is the empty-string symbol+--+-- Both 'eos' and 'eps' must be distinct from eachother and from all +-- tokens in the input string.+-- The show instance is required to throw error messages.+class (Ord a, Eq a, Show a) => Parseable a where+    eos :: a+    eps :: a ++    -- | This function is used for matching grammar tokens and input tokens.+    -- Override this method if, for example, your input tokens store lexemes+    -- while the grammar tokens do not+    matches :: a -> a -> Bool+    matches = (==)++deriving instance Ord Token+deriving instance Eq Token++instance Show Token where+    show (Char c)             = "char('" ++ [c] ++ "')"+    show (Keyword s)          = "keyword(\"" ++ s ++ "\")"+    show (EOS)                = "<end-of-string>"+    show (Epsilon)            = "<epsilon>"+    show (IntLit (Just i))    = "int(" ++  show i ++ ")"+    show (IntLit _)           = "<int>"+    show (BoolLit (Just b))   = "bool(" ++  show b ++ ")"+    show (BoolLit _)          = "<bool>"+    show (StringLit (Just s)) = "string(\"" ++ s ++ "\")"+    show (StringLit _)        = "<string>"+    show (IDLit  (Just id))   = "id(\"" ++ id ++ "\")"+    show (IDLit Nothing)      = "<id>"+    show (Token nm (Just s))  = nm ++ "(\"" ++ s ++ "\")"+    show (Token nm _)         = "<" ++ nm ++ ">"+    +instance Parseable Token where+    eos = EOS+    eps = Epsilon++    Token k _   `matches` Token k' _   = k' == k+    Char c      `matches` Char c'      = c' == c+    Keyword k   `matches` Keyword k'   = k' == k+    EOS         `matches` EOS          = True+    Epsilon     `matches` Epsilon      = True+    StringLit _ `matches` StringLit _  = True+    IntLit _    `matches` IntLit _     = True+    BoolLit _   `matches` BoolLit _    = True+    IDLit _     `matches` IDLit _      = True+    _           `matches` _            = False++
src/GLL/Types/Grammar.hs view
@@ -6,59 +6,79 @@ import qualified    Data.IntMap as IM import qualified    Data.Set as S  import qualified    Data.IntSet as IS -import              Data.List (delete, (\\), elemIndices, findIndices)+import              Data.List (elemIndices, findIndices) import GLL.Types.Abstract -token_length :: Token -> Int-token_length (Char _) = 1-token_length (EOS)    = 1-token_length (Epsilon)= 0-token_length (Int _)  = error "find out nr of digits in int"-token_length (Bool b) = maybe (error "no length for bool tokens") -                            (\b -> if b then 4 else 5) b-- supposing "True" and "False"-token_length (String s) = maybe (error "no length for string tokens") length s-token_length (Token _ str) = maybe (error "no length of tokens") length str- -- make sure that tokens are equal independent of their character level value-type SlotL      = (Slot, Int)                   -- slot with left extent-type PrL        = (Alt, Int)                     -- Production rule with left extent+type SlotL t    = (Slot t, Int)                   -- slot with left extent+type PrL t      = (Prod t, Int)                     -- Production rule with left extent type NtL        = (Nt, Int)                     -- Nonterminal with left extent  -- SPPF-type SPPF       =   (SymbMap, ImdMap, PackMap, EdgeMap, IDMap)-type PackMap    =   IM.IntMap (IM.IntMap (IM.IntMap (M.Map Alt IS.IntSet)))-type SymbMap    =   IM.IntMap (IM.IntMap (S.Set Symbol))-type ImdMap     =   IM.IntMap (IM.IntMap (S.Set Slot))-type EdgeMap    =   M.Map SPPFNode (S.Set SPPFNode)-type IDMap      =   (IDFMap,IDTMap)-type IDFMap     =   IM.IntMap SPPFNode-type IDTMap     =   M.Map SPPFNode Int-data SPPFNode   =   SNode (Symbol, Int, Int) -                |   INode (Slot, Int, Int)-                |   PNode (Slot, Int, Int, Int)++-- | +-- An 'SPPF' contains symbol nodes, intermediate nodes, packed nodes and edges between them.+-- See Scott and Johnstone (2013) for an explanation of the 'SPPF'.+type SPPF t     =   (SymbMap t, ImdMap t, PackMap t, EdgeMap t)++-- | +-- Stores packed nodes using nested "Data.IntMap"s, nesting is as follows:+--+-- * left extent+-- * right extent+-- * dot position (from left to right)+-- * mapping from productions to set of pivots+type PackMap t  =   IM.IntMap (IM.IntMap (IM.IntMap (M.Map (Prod t) IS.IntSet)))++-- | +-- Stores symbol nodes using nested "Data.IntMap"s, nesting is as follows:+--+-- * left extent+-- * right extent+-- * set of symbols+type SymbMap t  =   IM.IntMap (IM.IntMap (S.Set (Symbol t)))++-- | +-- Stores intermediate nodes using nested "Data.IntMap"s, nesting is as follows:+--+-- * left extent+-- * right extent+-- * set of slots +type ImdMap t   =   IM.IntMap (IM.IntMap (S.Set (Slot t)))++-- | +-- Stores edges, potentially costly.+type EdgeMap t  =   M.Map (SPPFNode t) (S.Set (SPPFNode t))++-- | +-- An "SPPFNode" is either a symbol node, an intermediate node, a packed node or a dummy.+data SPPFNode t =   SNode (Symbol t, Int, Int) +                |   INode (Slot t, Int, Int)+                |   PNode (Slot t, Int, Int, Int)                 |   Dummy     deriving (Ord, Eq)-type SNode      = (Symbol, Int, Int)-type PNode      = (Alt, [Int])-type SEdge      = M.Map SNode (S.Set PNode)-type PEdge      = M.Map PNode (S.Set SNode) -emptySPPF :: SPPF-emptySPPF = (IM.empty, IM.empty, IM.empty, M.empty, (IM.empty, M.empty))+type SNode t    = (Symbol t, Int, Int)+type PNode t    = (Prod t, [Int])+type SEdge t    = M.Map (SNode t)(S.Set (PNode t))+type PEdge t    = M.Map (PNode t) (S.Set (SNode t)) -pNodeLookup :: SPPF -> ((Alt, Int), Int, Int) -> Maybe [Int]-pNodeLookup (_,_,pMap,_,_) ((alt,j),l,r) = maybe Nothing inner $ IM.lookup l pMap+emptySPPF :: (Ord t) => SPPF t+emptySPPF = (IM.empty, IM.empty, IM.empty, M.empty)++pNodeLookup :: (Ord t) => SPPF t -> ((Prod t, Int), Int, Int) -> Maybe [Int]+pNodeLookup (_,_,pMap,_) ((alt,j),l,r) = maybe Nothing inner $ IM.lookup l pMap     where   inner   = maybe Nothing inner2 . IM.lookup r             inner2  = maybe Nothing inner3 . IM.lookup j             inner3  = maybe Nothing (Just . IS.toList) . M.lookup alt -pMapInsert :: SPPFNode -> SPPFNode -> SPPF -> SPPF-pMapInsert f t (sMap,iMap,pMap,eMap,idMap) =  +pMapInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t+pMapInsert f t (sMap,iMap,pMap,eMap) =       let pMap' = case f of                      PNode ((Slot x alpha beta), l, k, r) ->   -                        add (Alt x (alpha++beta)) (length alpha) l r k+                        add (Prod x (alpha++beta)) (length alpha) l r k                     _   -> pMap-    in (sMap,iMap,pMap',eMap,idMap)+    in (sMap,iMap,pMap',eMap)  where add alt j l r k = IM.alter addInnerL l pMap         where addInnerL mm = case mm of                               Nothing -> Just singleRJAK@@ -75,16 +95,16 @@               singleK   = IS.singleton k  -sNodeLookup :: SPPF -> (Symbol, Int, Int) -> Bool -sNodeLookup (sm,_,_,_,_) (s,l,r) = maybe False inner $ IM.lookup l sm+sNodeLookup :: (Ord t) => SPPF t -> (Symbol t, Int, Int) -> Bool +sNodeLookup (sm,_,_,_) (s,l,r) = maybe False inner $ IM.lookup l sm     where   inner   = maybe False (S.member s) . IM.lookup r -sNodeInsert :: SPPFNode -> SPPFNode -> SPPF -> SPPF-sNodeInsert f t (sMap,iMap,pMap,eMap,idMap) = +sNodeInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t+sNodeInsert f t (sMap,iMap,pMap,eMap) =      let sMap' = case f of                 SNode (s, l, r) -> newt (add s l r sMap)                 _               -> newt sMap-    in (sMap',iMap,pMap,eMap,idMap)+    in (sMap',iMap,pMap,eMap)  where newt sMap = case t of                     (SNode (s, l, r)) -> add s l r sMap                    _                 -> sMap@@ -95,21 +115,21 @@               singleRS     = IM.fromList [(r, singleS)]               singleS      = S.singleton s  -sNodeRemove :: SPPF -> (Symbol, Int, Int) -> SPPF -sNodeRemove (sm,iMap,pMap,eMap,idMap) (s,l,r) = -    (IM.adjust inner l sm, iMap,pMap,eMap,idMap)+sNodeRemove :: (Ord t) => SPPF t -> (Symbol t, Int, Int) -> SPPF t+sNodeRemove (sm,iMap,pMap,eMap) (s,l,r) = +    (IM.adjust inner l sm, iMap,pMap,eMap)     where   inner   = IM.adjust ((s `S.delete`)) r -iNodeLookup :: SPPF -> (Slot, Int, Int) -> Bool -iNodeLookup (_,iMap,_,_,_) (s,l,r) = maybe False inner $ IM.lookup l iMap+iNodeLookup :: (Ord t) => SPPF t -> (Slot t, Int, Int) -> Bool +iNodeLookup (_,iMap,_,_) (s,l,r) = maybe False inner $ IM.lookup l iMap     where   inner   = maybe False (S.member s) . IM.lookup r -iNodeInsert :: SPPFNode -> SPPFNode -> SPPF -> SPPF-iNodeInsert f t (sMap,iMap,pMap,eMap,idMap) = +iNodeInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t+iNodeInsert f t (sMap,iMap,pMap,eMap) =      let iMap' = case f of                 INode (s, l, r) -> newt (add s l r iMap)                 _               -> newt iMap-    in (sMap,iMap',pMap,eMap,idMap)+    in (sMap,iMap',pMap,eMap)  where newt iMap = case t of                     (INode (s, l, r)) -> add s l r iMap                    _                 -> iMap@@ -120,26 +140,15 @@               singleRS     = IM.fromList [(r, singleS)]               singleS      = S.singleton s  -iNodeRemove :: SPPF -> (Slot, Int, Int) -> SPPF -iNodeRemove (sMap,iMap,pMap,eMap,idMap) (s,l,r) = -    (sMap,IM.adjust inner l iMap,pMap,eMap,idMap)+iNodeRemove :: (Ord t) => SPPF t -> (Slot t, Int, Int) -> SPPF t+iNodeRemove (sMap,iMap,pMap,eMap) (s,l,r) = +    (sMap,IM.adjust inner l iMap,pMap,eMap)     where   inner   = IM.adjust ((s `S.delete`)) r -eMapInsert :: SPPFNode -> SPPFNode -> SPPF -> SPPF-eMapInsert f t (sMap,iMap,pMap,eMap,idMap) = -    (sMap,iMap,pMap,M.insertWith (S.union) f (S.singleton t) eMap,idMap)+eMapInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t+eMapInsert f t (sMap,iMap,pMap,eMap) =  +    (sMap,iMap,pMap,M.insertWith (S.union) f (S.singleton t) eMap) -idMapInsert :: SPPFNode -> SPPFNode -> SPPF -> (SPPF, Int, Int)-idMapInsert f t (sMap,iMap,pMap,eMap,(idfMap,idtMap)) =-    ((sMap,iMap,pMap,eMap,(idfMap'',idtMap'')),fkey,tkey)- where  idx     | IM.null idfMap = 0-                | otherwise      = fst (IM.findMax idfMap)-        (fkey,idfMap',idtMap')   = newKey f (idx+1) idfMap  idtMap-        (tkey,idfMap'',idtMap'') = newKey t (idx+2) idfMap' idtMap'-        newKey :: SPPFNode -> Int -> IDFMap -> IDTMap -> (Int,IDFMap,IDTMap)-        newKey n i mf mt = case M.lookup n mt of-                            Nothing -> (i,IM.insert i n mf,M.insert n i mt)-                            Just j  -> (j,mf,mt) -- helpers for Ucal inU (slot,l,i) u = maybe False inner $ IM.lookup l u          where inner = maybe False (S.member slot) . IM.lookup i@@ -160,52 +169,43 @@ showS sMap = unlines [ show (l,r) ++ " --> " ++ show (sset)                             | (l,r2s) <- IM.assocs sMap, (r,sset) <- IM.assocs r2s] -- TODO change to Map-showSPPF :: ([(SNode,PNode)],[(PNode,SNode)]) -> String+showSPPF :: (Show t) => ([(SNode t,PNode t)],[(PNode t,SNode t)]) -> String showSPPF (se,pe) = "\n"++ (unlines $ map ppPn $ pe) ++ "\n" ++                           (unlines $ map ppSn $ se)-     where ppPn ((Alt x alpha, rs), sn) = ppRhs (x,alpha,rs) ++ " --> " ++ show sn-           ppSn (sn, (Alt x alpha, rs)) = show sn ++ " --> " ++ ppRhs (x,alpha,rs)+     where ppPn ((Prod x alpha, rs), sn) = ppRhs (x,alpha,rs) ++ " --> " ++ show sn+           ppSn (sn, (Prod x alpha, rs)) = show sn ++ " --> " ++ ppRhs (x,alpha,rs)            ppRhs (x, alpha, rs) =  "(" ++ x ++ " ::= "++ (foldr ((++) . ppS) "" alpha) ++                                     foldr (\i -> (("," ++ show i) ++)) "" rs ++ ")"            ppS (Nt s)           = s-           ppS (Term Epsilon)   = "''"-           ppS (Term (Char c))  = [c]-           ppS (Term (Token t _)) = t-           ppS (Term (Int i))     = maybe "Int" show i-           ppS (Term (Bool b))    = maybe "Bool" show b-           ppS (Term (String s))  = maybe "String" id s+           ppS (Term t)         = show t   -- smart constructors-tokenT :: Token -> Symbol-tokenT t = Term $ t-charT c = Term $ Char c nT    x = Nt x-charS   = map Char -epsilon = [Term Epsilon]+epsilon = [] -type ProdMap   = M.Map Nt [Alt]-type PrefixMap = M.Map (Alt,Int) ([Token], Maybe Nt)-type SelectMap = M.Map (Nt, [Symbol]) (S.Set Token)-type FirstMap  = M.Map Nt (S.Set Token)-type FollowMap = M.Map Nt (S.Set Token)+type ProdMap t   = M.Map Nt [Prod t]+type PrefixMap t = M.Map (Prod t,Int) ([t], Maybe Nt)+type SelectMap t = M.Map (Nt, [Symbol t]) (S.Set t)+type FirstMap  t = M.Map Nt (S.Set t)+type FollowMap t = M.Map Nt (S.Set t) -fixedMaps :: Nt -> [Alt] -> (ProdMap, PrefixMap, FirstMap, FollowMap, SelectMap) +fixedMaps :: (Eq t, Ord t, Parseable t) => Nt -> [Prod t] -> +                (ProdMap t, PrefixMap t, FirstMap t, FollowMap t, SelectMap t)  fixedMaps s prs = let f = (prodMap, prefixMap, firstMap, followMap, selectMap)-                    in f `seq` f+                  in f `seq` f  where-    prodMap = M.fromListWith (++) [ (x,[pr]) | pr@(Alt x _) <- prs ]+    prodMap = M.fromListWith (++) [ (x,[pr]) | pr@(Prod x _) <- prs ] -    prefixMap :: PrefixMap      prefixMap = M.fromList -        [ ((pr,j), (tokens,msymb)) | pr@(Alt x alpha) <- prs+        [ ((pr,j), (tokens,msymb)) | pr@(Prod x alpha) <- prs                                    , (j,tokens,msymb) <- prefix x alpha ]      where         prefix x alpha = map rangePrefix ranges          where  js          = (map ((+) 1) (findIndices isNt alpha))                 ranges      = zip (0:js) (js ++ [length alpha])                 rangePrefix (a,z) | a >= z = (a,[],Nothing)-                                  | a <  z = +                rangePrefix (a,z) =                      let init = map ((\(Term t) -> t) . (alpha !!)) [a .. (z-2)]                         last = alpha !! (z-1)                      in case last of    @@ -214,11 +214,9 @@      firstMap = M.fromList [ (x, first_x [] x) | x <- M.keys prodMap ] -    first_x :: [Nt] -> Nt -> (S.Set Token) -- filter prevents self-calls-    first_x ys x           = S.unions [ first_alpha (x:ys) rhs | Alt _ rhs <- prodMap M.! x ]+    first_x ys x           = S.unions [ first_alpha (x:ys) rhs | Prod _ rhs <- prodMap M.! x ]  -    selectMap :: SelectMap -    selectMap = M.fromList [ ((x,alpha), select alpha x) | Alt x rhs <- prs+    selectMap = M.fromList [ ((x,alpha), select alpha x) | Prod x rhs <- prs                            , alpha <- split rhs ]      where         split rhs = foldr op [] js@@ -226,43 +224,38 @@                js           = 0 : findIndices isNt rhs          -- TODO store intermediate results-        select :: [Symbol] -> Nt -> (S.Set Token)         select alpha x      = res                  where   firsts  = first_alpha [] alpha-                        res     | Epsilon `S.member` firsts     = S.delete Epsilon firsts `S.union` (followMap M.! x)+                        res     | eps `S.member` firsts     = S.delete eps firsts `S.union` (followMap M.! x)                                 | otherwise                 = firsts      -- list of symbols to get firsts from + non-terminal to ignore     -- TODO store in map-    first_alpha :: [Nt] -> [Symbol] -> (S.Set Token)-    first_alpha ys []      = S.singleton Epsilon+    first_alpha ys []      = S.singleton eps      first_alpha ys (x:xs)  =           case x of-          Term Epsilon    -> first_alpha ys xs-          Term tau        -> S.singleton tau+          Term tau        -> if tau == eps then first_alpha ys xs+                                           else S.singleton tau           Nt x            ->               let fs | x `elem` ys       = S.empty                     | otherwise        = first_x (x:ys) x               in  if x `S.member` nullableSet-                        then (S.delete Epsilon fs) `S.union` first_alpha (x:ys) xs +                        then S.delete eps fs `S.union` first_alpha (x:ys) xs                         else fs -    followMap :: M.Map Nt (S.Set Token)     followMap = M.fromList [ (x, follow [] x) | x <- M.keys prodMap ]   -    follow :: [Nt] -> Nt -> (S.Set Token)     follow ys x = S.unions (map fw (maybe [] id $ M.lookup x localMap))-                            `S.union` (if x == s then S.singleton EOS else S.empty)+                            `S.union` (if x == s then S.singleton eos else S.empty)              where fw (y,ss) = -                        let ts  = S.delete Epsilon (first_alpha [] ss)+                        let ts  = S.delete eps (first_alpha [] ss)                             fs  = follow (x:ys) y                           in if nullable_alpha [] ss && not (x `elem` (y:ys))                                then ts `S.union` fs                                 else ts -     localMap = M.fromListWith (++)-                [ (x,[(y,tail)]) | x <- M.keys prodMap, (Alt y rhs) <- prs+                [ (x,[(y,tail)]) | x <- M.keys prodMap, (Prod y rhs) <- prs                                  , tail <- tails x rhs ]      where         tails x symbs = [ drop (index + 1) symbs | index <- indices ]@@ -274,17 +267,16 @@     -- a nonterminal is nullable if any of its alternatives is empty      nullable_x :: [Nt] -> Nt -> Bool     nullable_x ys x      = or [ nullable_alpha (x:ys) rhs -                              | (Alt _ rhs) <- prodMap M.! x ] +                              | (Prod _ rhs) <- prodMap M.! x ]       -- TODO store in map-    nullable_alpha :: [Nt] -> [Symbol] -> Bool+    nullable_alpha :: [Nt] -> [Symbol t] -> Bool     nullable_alpha ys [] = True     nullable_alpha ys (s:ss) =              case s of             Nt nt      -> if nt `elem` ys                              then False --nullable only if some other alternative is nullable                             else nullable_x ys nt && nullable_alpha (nt:ys) ss-            Term Epsilon -> True             otherwise  -> False  -- some helpers@@ -297,16 +289,13 @@ isChar (Char _) = True isChar _        = False  -deriving instance Show Grammar -deriving instance Ord Slot-deriving instance Eq Slot-deriving instance Show Rule-deriving instance Show Alt-deriving instance Ord Alt-deriving instance Eq Alt-deriving instance Eq Symbol-deriving instance Ord Symbol-+deriving instance (Ord t) => Ord (Slot t)+deriving instance (Eq t) => Eq (Slot t)+deriving instance (Show t) => Show (Prod t)+deriving instance (Ord t) => Ord (Prod t)+deriving instance (Eq t) => Eq (Prod t)+deriving instance (Eq t) => Eq (Symbol t)+deriving instance (Ord t) => Ord (Symbol t) {- instance Show Symbol where     show (Nt nt) = "Nt " ++ show nt@@ -328,53 +317,13 @@     (Error t1 t2) `compare` (Error t1' t2') = (t1,t2) `compare` (t1',t2') -} -instance Eq Token where-    Token k _   == Token k' _   = k' == k-    Char c      == Char c'      = c' == c-    EOS         == EOS          = True-    Epsilon     == Epsilon      = True-    String _    == String _     = True-    Int _       == Int _        = True-    Bool _      == Bool _       = True-    _           == _            = False--instance Ord Token where-    EOS         `compare` EOS           = EQ -    EOS         `compare` _             = LT-    _           `compare` EOS           = GT-    Epsilon     `compare` Epsilon       = EQ-    Epsilon     `compare` _             = LT-    _           `compare` Epsilon       = GT-    String _    `compare` String _      = EQ-    String _    `compare` _             = LT-    _           `compare` String _      = GT-    Int _       `compare` Int _         = EQ-    Int _       `compare` _             = LT-    _           `compare` Int _         = GT-    Bool _      `compare` Bool _        = EQ-    Bool _      `compare` _             = LT-    _           `compare` Bool _        = GT-    Char c      `compare` Char c2       = c `compare` c2-    Char _      `compare` _             = LT-    _           `compare` Char c        = GT-    Token k _   `compare` Token k2 _    = k `compare` k2--instance Show Token where-    show (Char c) = ['\'',c,'\'']-    show (EOS)    = "$"-    show Epsilon  = "#"-    show (Int mi) = "int" -    show (Bool mb)= "bool"-    show (String ms) = "string"-    show (Token t ms) = t --instance Show Slot where+instance (Show t) => Show (Slot t) where     show (Slot x alpha beta) = x ++ " ::= " ++ showRhs alpha ++ "." ++ showRhs beta          where  showRhs [] = ""             showRhs ((Term t):rhs) = show t ++ showRhs rhs             showRhs ((Nt x):rhs)   = x ++ showRhs rhs -instance Show Symbol where+instance (Show t) => Show (Symbol t) where     show (Nt s)         = s     show (Term t)       = show t-    show (Error e _)    = error ("show Error symbol")+