diff --git a/gll.cabal b/gll.cabal --- a/gll.cabal +++ b/gll.cabal @@ -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 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 diff --git a/src/GLL/Combinators.hs b/src/GLL/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators.hs @@ -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 diff --git a/src/GLL/Combinators/BinInterface.hs b/src/GLL/Combinators/BinInterface.hs deleted file mode 100644 --- a/src/GLL/Combinators/BinInterface.hs +++ /dev/null @@ -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 - diff --git a/src/GLL/Combinators/Interface.hs b/src/GLL/Combinators/Interface.hs --- a/src/GLL/Combinators/Interface.hs +++ b/src/GLL/Combinators/Interface.hs @@ -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 diff --git a/src/GLL/Combinators/MemBinInterface.hs b/src/GLL/Combinators/MemBinInterface.hs deleted file mode 100644 --- a/src/GLL/Combinators/MemBinInterface.hs +++ /dev/null @@ -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 - diff --git a/src/GLL/Combinators/MemInterface.hs b/src/GLL/Combinators/MemInterface.hs deleted file mode 100644 --- a/src/GLL/Combinators/MemInterface.hs +++ /dev/null @@ -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)) - diff --git a/src/GLL/Combinators/Memoisation.hs b/src/GLL/Combinators/Memoisation.hs --- a/src/GLL/Combinators/Memoisation.hs +++ b/src/GLL/Combinators/Memoisation.hs @@ -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 diff --git a/src/GLL/Combinators/Options.hs b/src/GLL/Combinators/Options.hs --- a/src/GLL/Combinators/Options.hs +++ b/src/GLL/Combinators/Options.hs @@ -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) diff --git a/src/GLL/Combinators/Test/BinInterface.hs b/src/GLL/Combinators/Test/BinInterface.hs deleted file mode 100644 --- a/src/GLL/Combinators/Test/BinInterface.hs +++ /dev/null @@ -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"] diff --git a/src/GLL/Combinators/Test/Interface.hs b/src/GLL/Combinators/Test/Interface.hs --- a/src/GLL/Combinators/Test/Interface.hs +++ b/src/GLL/Combinators/Test/Interface.hs @@ -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 = '#' diff --git a/src/GLL/Combinators/Test/MemBinInterface.hs b/src/GLL/Combinators/Test/MemBinInterface.hs deleted file mode 100644 --- a/src/GLL/Combinators/Test/MemBinInterface.hs +++ /dev/null @@ -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"] diff --git a/src/GLL/Combinators/Test/MemInterface.hs b/src/GLL/Combinators/Test/MemInterface.hs deleted file mode 100644 --- a/src/GLL/Combinators/Test/MemInterface.hs +++ /dev/null @@ -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"] diff --git a/src/GLL/Combinators/Visit/Grammar.hs b/src/GLL/Combinators/Visit/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Visit/Grammar.hs @@ -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 + diff --git a/src/GLL/Combinators/Visit/Sem.hs b/src/GLL/Combinators/Visit/Sem.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Visit/Sem.hs @@ -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 + + diff --git a/src/GLL/Parser.hs b/src/GLL/Parser.hs --- a/src/GLL/Parser.hs +++ b/src/GLL/Parser.hs @@ -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 diff --git a/src/GLL/Types/Abstract.hs b/src/GLL/Types/Abstract.hs --- a/src/GLL/Types/Abstract.hs +++ b/src/GLL/Types/Abstract.hs @@ -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) = "" + show (Epsilon) = "" + show (IntLit (Just i)) = "int(" ++ show i ++ ")" + show (IntLit _) = "" + show (BoolLit (Just b)) = "bool(" ++ show b ++ ")" + show (BoolLit _) = "" + show (StringLit (Just s)) = "string(\"" ++ s ++ "\")" + show (StringLit _) = "" + show (IDLit (Just id)) = "id(\"" ++ id ++ "\")" + show (IDLit Nothing) = "" + 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 + + diff --git a/src/GLL/Types/Grammar.hs b/src/GLL/Types/Grammar.hs --- a/src/GLL/Types/Grammar.hs +++ b/src/GLL/Types/Grammar.hs @@ -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") +