gll 0.2.0.2 → 0.2.0.3
raw patch · 15 files changed
+1336/−419 lines, 15 files
Files
- gll.cabal +33/−26
- src/GLL/Combinators/BinInterface.hs +239/−0
- src/GLL/Combinators/Interface.hs +17/−10
- src/GLL/Combinators/MemBinInterface.hs +264/−0
- src/GLL/Combinators/MemInterface.hs +7/−6
- src/GLL/Combinators/Test/BinInterface.hs +187/−0
- src/GLL/Combinators/Test/Interface.hs +192/−0
- src/GLL/Combinators/Test/MemBinInterface.hs +196/−0
- src/GLL/Combinators/Test/MemInterface.hs +196/−0
- src/GLL/Common.hs +0/−4
- src/GLL/Parser.hs +1/−2
- src/GLL/Types/Abstract.hs +4/−2
- src/GLL/Types/Grammar.hs +0/−1
- tests/interface/MemTests.hs +0/−188
- tests/interface/UnitTests.hs +0/−180
gll.cabal view
@@ -3,7 +3,7 @@ -- The name of the package. name: gll-version: 0.2.0.2+version: 0.2.0.3 synopsis: GLL parser with simple combinator interface license: BSD3 license-file: LICENSE@@ -16,47 +16,54 @@ description: GLL is a parser combinator library for writing generalised parsers.- The parsers can correspond to arbitrary context-free grammar, accepting - both non-determinism and (left-) recursion.+ 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 (although no- instance of Applicative is given). - Users can add arbitrary semantic to the parser. - .- There are 4 top-level functions: parse, parseString, parseWithOptions- and parseStringWithOptions. They all return a list of semantic results,- one for each derivation. In the case that infinite derivations are possible- only 'good parse trees' are accepted (Ridge 2014).+ The library provides an interface in 'Control.Applicative' style: + it uses the combinators '<*>', '<|>', '<$>' and derivations. + With '<$>' arbitrary semantic actions are added to the parser. .- Function parse relies on a builtin Token datatype. User-defined token-types - are currently not supported. parseString enables parsing character strings.- The user is granted GLL.Combinators.Options to specify certain disambiguation- rules.+ 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. .- GLL.Combinators.MemInterface is a memoised version of the library.- Parsers are no longer pure functions and must be built inside the IO monad,- providing fresh memo-tables to each memo'ed non-terminal.+ '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. .- See UnitTests and MemTests for examples of using both version of- the library.+ Examples can be found in the 'GLL.Combinators.Test' directory. library- hs-source-dirs : src,tests/interface+ hs-source-dirs : src build-depends : base >=4.5 && <= 4.8.0.0 , containers >= 0.4 , array , TypeCompose exposed-modules : GLL.Combinators.Interface , GLL.Combinators.MemInterface- , GLL.Combinators.Options- , GLL.Combinators.Memoisation- , UnitTests- , MemTests+ , 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.Parser- , GLL.Common+ , GLL.Combinators.Memoisation+ , GLL.Combinators.Options extensions : TypeOperators, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances
+ src/GLL/Combinators/BinInterface.hs view
@@ -0,0 +1,239 @@+module GLL.Combinators.BinInterface (+ Parser,+ parse, parseString,+ char, token, Token(..),+ epsilon, satisfy,+ many,some,optional,+ (<::=>),(<:=>),+ (<$>),+ (<$),+ (<*>),+ (*>),+ (<*),+ (<|>),+) where++import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))++import GLL.Combinators.Options+import GLL.Types.Abstract+import GLL.Types.Grammar hiding (epsilon)+import GLL.Parser (gllSPPF,ParseResult(..))++import qualified Data.Array as A+import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Data.Set as S++type Visit1 = Symbol +type Visit2 = M.Map Nt [Alt] -> M.Map Nt [Alt]+type Visit3 a = PCOptions -> A.Array Int Token -> ParseContext -> SPPF + -> Int -> Int -> Int -> S.Set a++type Parser a = (Visit1, Visit2, Visit3 a)++type ParseContext = IM.IntMap (IM.IntMap Nt)++-- | Given a parser and a string of tokens, return:+-- * The grammar (GLL.Types.Abstract)+-- * a list of results, which are all semantic evaluations of 'good derivations'+-- - semantic evaluations are specified by using <$> and satisfy+-- - 'good derivations' as defined by by Tom Ridge+parse' :: PCOptions -> Parser a -> [Token] -> (Grammar, ParseResult, [a])+parse' opts (Nt start,rules,sem) str = + let cfg = Grammar start [] [ Rule x alts + | (x, alts) <- M.assocs (rules M.empty) ]+ parse_r = gllSPPF cfg str+ sppf = sppf_result parse_r+ as = sem opts arr IM.empty sppf 0 m m+ m = length str+ arr = A.array (0,m) (zip [0..] str)+ in (cfg,parse_r,S.toList as)++-- | The grammar of a given parser+grammar :: Parser a -> Grammar+grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])++-- | The semantic results of a parser, given a token string+parse :: Parser a -> [Token] -> [a]+parse = parseWithOptions defaultOptions ++-- | The semantic results of a parser, given a token string +-- and GLL.Combinator.Options+parseWithOptions :: PCOptions -> Parser a -> [Token] -> [a]+parseWithOptions opts p str = (\(_,_,t) -> t) (parse' opts p str)++-- | Get the SPPF produced by parsing the given input with the given parser+sppf :: Parser a -> [Token] -> ParseResult+sppf p str = (\(_,s,_) -> s) (parse' defaultOptions p str)++-- | Parse a given string of characters +parseString :: Parser a -> [Char] -> [a]+parseString p = parse p . charS++-- | Parse a given string of characters and options +parseStringWithOptions :: PCOptions -> Parser a -> [Char] -> [a]+parseStringWithOptions opts p = parseWithOptions opts p . charS+infixl 3 <::=>+-- | use <::=> to enforce using parse context (to handle left-recursion)+(<::=>) :: String -> Parser a -> Parser a+x <::=> _r = let (sym,_r_rules,_r_sem) = _r+ alt = Alt x [sym] -- TODO indirection (extra alt)+ rules m = case M.lookup x m of+ Nothing -> _r_rules (M.insert x [alt] m)+ Just _ -> m++ sem opts arr ctx sppf l r m+ | (l,r,x) `inContext` ctx = S.empty+ | otherwise = let ctx' = (l,r,x) `toContext` ctx+ in _r_sem opts arr ctx' sppf l r m+ in (Nt x,rules,sem)++-- | useful for non-recursive definitions (only internally)+infixl 3 <:=>+(<:=>) :: String -> Parser a -> Parser a+x <:=> _r = let (sym,_r_rules,_r_sem) = _r+ alt = Alt x [sym] -- TODO indirection (extra alt)+ rules m = case M.lookup x m of+ Nothing -> _r_rules (M.insert x [alt] m)+ Just _ -> m+ in (Nt x,rules,_r_sem)++infixl 5 <$>+-- | Application of a semantic action. +(<$>) :: (Ord b, Ord a) => (a -> b) -> Parser a -> Parser b+f <$> _r = let (sym,rules,_r_sem) = _r+ sem opts arr ctx sppf l r m = S.map f (_r_sem opts arr ctx sppf l r m)+ in (sym,rules,sem)++infixl 6 <*>+-- | Sequence two parsers, the results of the two parsers are tupled.+(<*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser (a,b)+_l <*> _r = (Nt lhs_id,rules,sem)+ where l_id = id_ _l+ r_id = id_ _r+ lhs_id = concat [l_id, "*", r_id]+ + -- ** one can bind this parser and recurse on it + other duplicate work+ alt = Alt lhs_id [sym_ _l, sym_ _r]+ rules m = case M.lookup lhs_id m of -- necessary? **+ Nothing -> rules_ _r (rules_ _l (M.insert lhs_id [alt] m))+ Just _ -> m+ + sem opts arr ctx sppf l r m = + let filter = maybe id id $ pivot_select opts in S.fromList+ [ (a,b) | k <- filter ks+ , a <- S.toList (sem_ _l opts arr ctx sppf l k m)+ , b <- S.toList (sem_ _r opts arr ctx sppf k r m) ]+ where ks = maybe [] id $ sppf `pNodeLookup` ((alt,2), l, r)++infixl 4 <|>+-- | A choice between two parsers, results of the two are concatenated+(<|>) :: (Ord a) => Parser a -> Parser a -> Parser a+_l <|> _r = (Nt lhs_id,rules,sem)+ where l_id = id_ _l+ r_id = id_ _r+ lhs_id = concat [l_id, "|", r_id]++ alts = [Alt lhs_id [sym_ _l], Alt lhs_id [sym_ _r]]+ rules m = case M.lookup lhs_id m of+ Nothing -> rules_ _r (rules_ _l (M.insert lhs_id alts m))+ Just _ -> m++ sem opts arr ctx sppf l r m = + concatChoice opts (sem_ _l opts arr ctx sppf l r m)+ (sem_ _r opts arr ctx sppf l r m)++-- derived combinators+infixl 6 <*+-- | Sequencing, ignoring the result to the right+(<*) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser a+_l <* _r = (\(x,y) -> x) <$> _l <*> _r++infixl 6 *>+-- | Sequencing, ignoring the result to the left +(*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser b+_l *> _r = (\(x,y) -> y) <$> _l <*> _r++infixl 5 <$+-- | Ignore all results and just return the given value+(<$) :: (Ord a, Ord b) => a -> Parser b -> Parser a+f <$ _r = const f <$> _r ++-- elementary parsers+raw_parser :: String -> Token -> (Token -> a) -> Parser a+raw_parser str t f = (Nt str, rules, sem)+ where alt = Alt str [Term t]+ rules = M.insert str [alt] + sem _ arr ctx sppf l r m + | l + 1 == r && l < m && arr A.! l == t = S.singleton (f t)+ | otherwise = S.empty++-- | A parser that recognises a given character+char :: Char -> Parser Char+char c = raw_parser ([c]) (Char c) (\(Char c) -> c)++-- | A parser that recognises a given token+token :: Token -> Parser Token+token t = raw_parser (show t) t id++-- | A parser that always succeeds (and returns unit)+epsilon :: Parser ()+epsilon = (Nt x, rules, sem)+ where x = "__eps"+ alt = Alt x [Term Epsilon]+ rules = M.insert x [alt]+ sem _ arr ctx sppf l r m | l == r = S.singleton ()+ | otherwise = S.empty++-- | A parser that always succeeds and returns a given value+satisfy :: (Ord a) => a -> Parser a+satisfy a = a <$ epsilon++-- helpers+sym_ :: Parser a -> Symbol+sym_ (f,_,_) = f++id_ :: Parser a -> Nt +id_ (Nt x,_,_) = x++rules_ :: Parser a -> Visit2+rules_ (_,f,_) = f++sem_ :: Parser a -> Visit3 a+sem_ (_,_,f) = f++mkNt :: String -> Char -> Nt+mkNt x c = concat ["(",x,")",[c]]++inContext :: (Int, Int, Nt) -> ParseContext -> Bool+inContext (l,r,x) = maybe False inner . IM.lookup l + where inner = maybe False ((==) x) . IM.lookup r++toContext :: (Int, Int, Nt) -> ParseContext -> ParseContext+toContext (l,r,x) = IM.insertWith IM.union l (IM.singleton r x)++concatChoice :: (Ord a) => PCOptions -> S.Set a -> S.Set a -> S.Set a+concatChoice opts ls rs = if left_biased_choice opts+ then firstRes+ else ls `S.union` rs+ where firstRes | S.null ls = rs+ | otherwise = ls++-- higher level patterns++-- | Optionally use the given parser+optional :: (Ord a) => Parser a -> Parser (Maybe a)+optional p@(Nt x,_,_) = (mkNt x '?') <:=> satisfy Nothing <|> Just <$> p++-- | Apply the given parser many times, 0 or more times (Kleene closure)+many :: (Ord a) => Parser a -> Parser [a]+many p@(Nt x,_,_) = (mkNt x '^') <::=> satisfy [] + <|> uncurry (:) <$> p <*> many p++-- | Apply the given parser some times, 1 or more times (positive closure)+some :: (Ord a) => Parser a -> Parser [a]+some p@(Nt x,_,_) = let rec = (mkNt x '+') <::=> (:[]) <$> p+ <|> uncurry (:) <$> p <*> rec+ in rec+
src/GLL/Combinators/Interface.hs view
@@ -1,35 +1,44 @@ {-# LANGUAGE TypeOperators, FlexibleInstances #-} module GLL.Combinators.Interface (- SymbParser(..), IMParser(..), SPPF,- parse, parseString, grammar, sppf, - char, token, Token(..),+ SymbParser, IMParser, + HasAlts(..), IsSymbParser(..), IsIMParser(..),+ parse, parseString, + char, token,Token(..), epsilon, satisfy, many, some, optional,+ (<::=>),(<:=>), (<$>), (<$), (<*>), (<*),- (<::=>),(<:=>),- (<|>)+ (<|>),+ (:.) ) where import Prelude hiding ((<*>), (<*), (<$>), (<$)) import GLL.Combinators.Options-import GLL.Common import GLL.Types.Grammar hiding (epsilon) import GLL.Types.Abstract import GLL.Parser (gllSPPF, pNodeLookup, ParseResult(..)) -import Control.Compose+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 +-- | 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)++-- | 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] @@ -39,8 +48,6 @@ 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, [a]) parse' opts p' input' = @@ -50,7 +57,7 @@ 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 ]+ 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)
+ src/GLL/Combinators/MemBinInterface.hs view
@@ -0,0 +1,264 @@++-- | Parser Combinators for GLL parsing inspired by Tom Ridge's P3 OCaml library+module GLL.Combinators.MemBinInterface (+ Parser,+ parse, parseString,+ (<::=>),(<:=>),+ (<$>),+ (<$),+ (<*>),+ (*>),+ (<*),+ (<|>),+ char, token, Token(..),+ epsilon,satisfy,+ optional, many, some,+ memo, newMemoTable, MemoRef, MemoTable+ ) where++import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))++import GLL.Combinators.Options+import GLL.Combinators.Memoisation+import GLL.Types.Abstract+import GLL.Types.Grammar hiding (epsilon)+import GLL.Parser (gllSPPF,ParseResult(..))++import Control.Monad+import qualified Data.Array as A+import qualified Data.Map as M+import Data.IORef+import qualified Data.IntMap as IM+import qualified Data.Set as S++type Visit1 = Symbol +type Visit2 = M.Map Nt [Alt] -> M.Map Nt [Alt]+type Visit3 a = PCOptions -> A.Array Int Token -> ParseContext -> SPPF + -> Int -> Int -> Int -> IO (S.Set a)++type Parser a = (Visit1, Visit2, Visit3 a)++type ParseContext = IM.IntMap (IM.IntMap Nt)++-- | Given a parser and a string of tokens, return:+-- * The grammar (GLL.Types.Abstract)+-- * a list of results, which are all semantic evaluations of 'good derivations'+-- - semantic evaluations are specified by using <$> and satisfy+-- - 'good derivations' as defined by by Tom Ridge+parse' :: PCOptions -> Parser a -> [Token] -> (Grammar, ParseResult, IO [a])+parse' opts (Nt start,rules,sem) str = + let cfg = Grammar start [] [ Rule x alts + | (x, alts) <- M.assocs (rules M.empty) ]+ parse_r = gllSPPF cfg str+ sppf = sppf_result parse_r+ as = sem opts arr IM.empty sppf 0 m m+ m = length str+ arr = A.array (0,m) (zip [0..] str)+ in (cfg,parse_r,as >>= return . S.toList)++-- | The grammar of a given parser+grammar :: Parser a -> Grammar+grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])++-- | The semantic results of a parser, given a token string+parse :: Parser a -> [Token] -> IO [a]+parse = parseWithOptions defaultOptions ++-- | The semantic results of a parser, given a token string +-- and GLL.Combinator.Options+parseWithOptions :: PCOptions -> Parser a -> [Token] -> IO [a]+parseWithOptions opts p str = (\(_,_,t) -> t) (parse' opts p str)++-- | Get the SPPF produced by parsing the given input with the given parser+sppf :: Parser a -> [Token] -> ParseResult+sppf p str = (\(_,s,_) -> s) (parse' defaultOptions p str)++-- | Parse a given string of characters +parseString :: Parser a -> [Char] -> IO [a]+parseString p = parse p . charS++-- | Parse a given string of characters and options +parseStringWithOptions :: PCOptions -> Parser a -> [Char] -> IO [a]+parseStringWithOptions opts p = parseWithOptions opts p . charS++infixl 3 <::=>+(<::=>) :: String -> Parser a -> Parser a+x <::=> _r = let (sym,_r_rules,_r_sem) = _r+ alt = Alt x [sym] -- TODO indirection (extra alt)+ rules m = case M.lookup x m of+ Nothing -> _r_rules (M.insert x [alt] m)+ Just _ -> m++ sem opts arr ctx sppf l r m+ | (l,r,x) `inContext` ctx = return S.empty+ | otherwise = let ctx' = (l,r,x) `toContext` ctx+ in _r_sem opts arr ctx' sppf l r m+ in (Nt x,rules,sem)++-- | useful for non-recursive definitions (only internally)+infixl 3 <:=>+(<:=>) :: String -> Parser a -> Parser a+x <:=> _r = let (sym,_r_rules,_r_sem) = _r+ alt = Alt x [sym] -- TODO indirection (extra alt)+ rules m = case M.lookup x m of+ Nothing -> _r_rules (M.insert x [alt] m)+ Just _ -> m+ in (Nt x,rules,_r_sem)++infixl 5 <$>+-- | Application of a semantic action. +(<$>) :: (Ord b, Ord a) => (a -> b) -> Parser a -> Parser b+f <$> _r = let (sym,rules,_r_sem) = _r+ sem opts arr ctx sppf l r m = + do as <- _r_sem opts arr ctx sppf l r m+ return (S.map f as)+ in (sym,rules,sem)++infixl 6 <*>+-- | Sequence two parsers, the results of the two parsers are tupled.+(<*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser (a,b)+_l <*> _r = (Nt lhs_id,rules,sem)+ where l_id = id_ _l+ r_id = id_ _r+ lhs_id = concat [l_id, "*", r_id]+ + -- ** one can bind this parser and recurse on it + other duplicate work+ alt = Alt lhs_id [sym_ _l, sym_ _r]+ rules m = case M.lookup lhs_id m of -- necessary? **+ Nothing -> rules_ _r (rules_ _l (M.insert lhs_id [alt] m))+ Just _ -> m+ + sem opts arr ctx sppf l r m = do ass <- forM (filter ks) seq+ return (S.unions ass)+ where ks = maybe [] id $ sppf `pNodeLookup` ((alt,2), l, r)+ filter = maybe id id $ pivot_select opts+ seq k = do as <- sem_ _l opts arr ctx sppf l k m+ bs <- sem_ _r opts arr ctx sppf k r m+ return $ S.fromList [ (a,b) | a <- S.toList as+ , b <- S.toList bs ]++infixl 4 <|>+-- | A choice between two parsers, results of the two are concatenated+(<|>) :: (Ord a) => Parser a -> Parser a -> Parser a+_l <|> _r = (Nt lhs_id,rules,sem)+ where l_id = id_ _l+ r_id = id_ _r+ lhs_id = concat [l_id, "|", r_id]++ alts = [Alt lhs_id [sym_ _l], Alt lhs_id [sym_ _r]]+ rules m = case M.lookup lhs_id m of+ Nothing -> rules_ _r (rules_ _l (M.insert lhs_id alts m))+ Just _ -> m++ sem opts arr ctx sppf l r m = + do as1 <- sem_ _l opts arr ctx sppf l r m+ as2 <- sem_ _r opts arr ctx sppf l r m + return (concatChoice opts as1 as2)++-- | Use this function on a parser to memoise the semantic phase of the parser+-- It is advised to only use 'memo' on a parser whose symbol occurs many times+-- in a highly ambiguous grammar+-- Every symbol on which 'memo' is used should have its own table.+memo :: MemoRef (S.Set a) -> Parser a -> Parser a+memo ref (sym@(Nt x),rules,sem) = (sym, rules, lhs_sem)+ where lhs_sem opts arr ctx sppf l r m = do + tab <- readIORef ref+ case memLookup (l,r) tab of+ Just as -> return as+ Nothing -> do as <- sem opts arr ctx sppf l r m+ modifyIORef ref (memInsert (l,r) as)+ return as+-- derived combinators+infixl 6 <*+-- | Sequencing, ignoring the result to the right+(<*) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser a+_l <* _r = (\(x,y) -> x) <$> _l <*> _r++infixl 6 *>+-- | Sequencing, ignoring the result to the left +(*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser b+_l *> _r = (\(x,y) -> y) <$> _l <*> _r++infixl 5 <$+-- | Ignore all results and just return the given value+(<$) :: (Ord a, Ord b) => a -> Parser b -> Parser a+f <$ _r = const f <$> _r ++-- elementary parsers+raw_parser :: String -> Token -> (Token -> a) -> Parser a+raw_parser str t f = (Nt str, rules, sem)+ where alt = Alt str [Term t]+ rules = M.insert str [alt] + sem _ arr ctx sppf l r m + | l + 1 == r && l < m && arr A.! l == t + = return $ S.singleton (f t)+ | otherwise = return $ S.empty++-- | A parser that recognises a given character+char :: Char -> Parser Char+char c = raw_parser ([c]) (Char c) (\(Char c) -> c)++-- | A parser that recognises a given token+token :: Token -> Parser Token+token t = raw_parser (show t) t id++-- | A parser that always succeeds (and returns unit)+epsilon :: Parser ()+epsilon = (Nt x, rules, sem)+ where x = "__eps"+ alt = Alt x [Term Epsilon]+ rules = M.insert x [alt]+ sem _ arr ctx sppf l r m | l == r = return $ S.singleton ()+ | otherwise = return $ S.empty++-- | A parser that always succeeds and returns a given value+satisfy :: (Ord a) => a -> Parser a+satisfy a = a <$ epsilon++-- helpers+sym_ :: Parser a -> Symbol+sym_ (f,_,_) = f++id_ :: Parser a -> Nt +id_ (Nt x,_,_) = x++rules_ :: Parser a -> Visit2+rules_ (_,f,_) = f++sem_ :: Parser a -> Visit3 a+sem_ (_,_,f) = f++mkNt :: String -> Char -> Nt+mkNt x c = concat ["(",x,")",[c]]++inContext :: (Int, Int, Nt) -> ParseContext -> Bool+inContext (l,r,x) = maybe False inner . IM.lookup l + where inner = maybe False ((==) x) . IM.lookup r++toContext :: (Int, Int, Nt) -> ParseContext -> ParseContext+toContext (l,r,x) = IM.insertWith IM.union l (IM.singleton r x)++concatChoice :: (Ord a) => PCOptions -> S.Set a -> S.Set a -> S.Set a+concatChoice opts ls rs = if left_biased_choice opts+ then firstRes+ else ls `S.union` rs+ where firstRes | S.null ls = rs+ | otherwise = ls++-- higher level patterns++-- | Optionally use the given parser+optional :: (Ord a) => Parser a -> Parser (Maybe a)+optional p@(Nt x,_,_) = (mkNt x '?') <:=> satisfy Nothing <|> Just <$> p++-- | Apply the given parser many times, 0 or more times (Kleene closure)+many :: (Ord a) => Parser a -> Parser [a]+many p@(Nt x,_,_) = (mkNt x '^') <::=> satisfy [] + <|> uncurry (:) <$> p <*> many p++-- | Apply the given parser some times, 1 or more times (positive closure)+some :: (Ord a) => Parser a -> Parser [a]+some p@(Nt x,_,_) = let rec = (mkNt x '+') <::=> (:[]) <$> p+ <|> uncurry (:) <$> p <*> rec+ in rec+
src/GLL/Combinators/MemInterface.hs view
@@ -1,25 +1,26 @@ {-# LANGUAGE TypeOperators, FlexibleInstances #-} module GLL.Combinators.MemInterface (- SymbParser(..), IMParser(..), SPPF,- parse, parseString, grammar, sppf, + SymbParser, IMParser,+ HasAlts(..), IsSymbParser(..), IsIMParser(..),+ parse, parseString, char, token, Token(..), epsilon, satisfy, many, some, optional,+ (<::=>),(<:=>), (<$>), (<$), (<*>), (<*),- (<::=>),(<:=>), (<|>),- memo, newMemoTable+ (:.),+ memo, newMemoTable, MemoRef, MemoTable ) where import Prelude hiding ((<*>), (<*), (<$>), (<$)) import GLL.Combinators.Options import GLL.Combinators.Memoisation-import GLL.Common import GLL.Types.Grammar hiding (epsilon) import GLL.Types.Abstract import GLL.Parser (gllSPPF, pNodeLookup, ParseResult(..))@@ -53,7 +54,7 @@ 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 ]+ 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)
+ src/GLL/Combinators/Test/BinInterface.hs view
@@ -0,0 +1,187 @@+{-| This model contains unit-tests for 'GLL.Combinators.BinInterface'++= Included examples++ * Elementary parsers+ * Sequencing+ * Alternatives+ * Simple binding+ * Binding with alternatives+ * Recursion (non-left)++ * Higher-order patterns:++ * Optional+ * Kleene-closure / positive closure+ * Seperator+ * Inline choice++ * Ambiguities:++ * "aaa"+ * longambig+ * aho_s+ * EEE++ * Left recursion+ * Hidden left-recursion+-}+module GLL.Combinators.Test.BinInterface where++import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))++import Control.Compose+import Control.Monad+import Data.Char (ord)+import Data.List (sort)+import Data.IORef+import qualified Data.Map as M++import GLL.Combinators.BinInterface++-- | Defines and executes some unit-tests +main = do+ count <- newIORef 1+ let test name p arg_pairs = do+ i <- readIORef count+ modifyIORef count succ+ subcount <- newIORef 'a'+ putStrLn (">> testing " ++ show i ++ " (" ++ name ++ ")")+ forM_ arg_pairs $ \(str,res) -> do+ j <- readIORef subcount+ modifyIORef subcount succ+ let parse_res = parseString p str+ norm = sort . take 100+ b = norm parse_res == norm res+ putStrLn (" >> " ++ [j,')',' '] ++ show b)+ unless b (putStrLn (" >> " ++ show parse_res))++ -- Elementary parsers+ test "eps1" (satisfy 0) [("", [0])]+ test "eps2" (0 <$ epsilon) [("", [0]), ("111", [])]+ test "single" (char 'a') [("a", ['a'])+ ,("abc", [])]+ test "semfun1" (1 <$ char 'a') [("a", [1])]++ -- Elementary combinators+ test "<*>" ((\b -> ['1',b]) <$> char 'a' *> char 'b')+ [("ab", ["1b"])+ ,("b", [])]+ + -- Alternation+ test "<|>" (ord <$> char 'a' *> char 'b' <|> ord <$> char 'c')+ [("a", []), ("ab", [98]), ("c", [99]), ("cab", [])]++ -- Simple binding+ let pX = "X" <::=> ord <$> char 'a' <* char 'b'+ test "<::=>" pX [("ab",[97]),("a",[])]++ let pX = "X" <::=> uncurry (flip (:)) <$> pY <*> char 'a'+ pY = "Y" <::=> uncurry (\x y -> [x,y]) <$> char 'b' <*> char 'c'+ test "<::=> 2" pX [("bca", ["abc"]), ("cba", [])]++ -- Binding with alternatives+ let pX = "X" <::=> pY <* char 'c'+ pY = "Y" <::=> char 'a' <|> char 'b'+ test "<::=> <|>" pX [("ac", "a"), ("bc", "b")]++ -- (Right) Recursion+ let pX = "X" <::=> (+1) <$> char 'a' *> pX <|> 0 <$ epsilon+ test "rec1" pX [("", [0]), ("aa",[2]), (replicate 42 'a', [42]), ("bbb", [])]++ -- EBNF+ let pX = "X" <::=> id <$> char 'a' *> char 'b' *> optional (char 'z')+ test "optional" pX [("abz", [Just 'z']), ("abab", []), ("ab", [Nothing])]++ let pX = "X" <::=> (char 'a' <|> char 'b')+ test "<|> optional" (pX <* optional (char 'z'))+ [("az", "a"), ("bz", "b"), ("z", []), ("b", "b"), ("a", "a")]++ let pX = "X" <::=> (1 <$ optional (char 'a') <|> 2 <$ optional (char 'b'))+ test "optional-ambig" (pX <* optional (char 'z'))+ [("az", [1]), ("bz", [2]), ("z", [1,2]), ("b", [2]), ("a", [1])]++ let pX = "X" <::=> id <$> char 'a' *> (char 'b' <|> char 'c')+ test "inline choice (1)" pX+ [("ab", "b"), ("ac", "c"), ("a", []), ("b", [])]++ let pX = "X" <::=> length <$> many (char '1')+ test "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])]++ let pX = "X" <::=> length <$> some (char '1')+ test "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])]++ let pX = "X" <::=> 1 <$ many (char 'a') <|> 2 <$ many (char 'b')+ test "(many <|> many) <*> optional" (pX <* optional (char 'z'))+ [("az", [1]), ("bz", [2]), ("z", [1,2])+ ,("", [1,2]), ("b", [2]), ("a", [1])]++ let pX = "X" <::=> pY <* optional (char 'z')+ where pY = "Y" <::=> length <$> many (char 'a')+ <|> length <$> some (char 'b') <* char 'e'+ test "many & some & optional" + pX [("aaaz", [3]), ("bbbez", [3]), ("ez", []), ("z", [0])+ ,("aa", [2]), ("bbe", [2]) + ]++ -- Simple ambiguities+ let pX = uncurry (++) <$> pA <*> pB+ pA = "a" <$ char 'a' <|> "aa" <$ char 'a' <* char 'a'+ pB = "b" <$ char 'a' <|> "bb" <$ char 'a' <* char 'a' + test "aaa" pX [("aaa", ["aab", "abb"])+ ,("aa", ["ab"])]++ let pX = (\(x,y) -> [x,y]) <$> char 'a' *> pL <*> pL <* char 'e'+ pL = 1 <$ char 'b'+ <|> 2 <$ char 'b' <* char 'c'+ <|> 3 <$ char 'c' <* char 'd'+ <|> 4 <$ char 'd'+ test "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])]++ let pX = "X" <::=> (1 <$ some (char 'a') <|> 2 <$ many (char 'b'))+ pY = "Y" <::=> uncurry (+) <$> pX <*> pY+ <|> satisfy 0+ test "some & many & recursion + ambiguities" pY+ [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])]++ let pX = "X" <::=> 1 <$ char 'a' <|> satisfy 0+ pY = "Y" <::=> uncurry (+) <$> pX <*> pY+ -- shouldn't this be 1 + infinite 0's?+ test "no parse infinite rec?" pY + [("a", [])]++ let pS = "S" <::=> ((\(x,y) -> x+y+1) <$> char '1' *> pS <*> pS) <|> satisfy 0 + test "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]+++ let pS = "S" <::=> ((\(x,y) -> '1':x++y) <$> char '1' *> pS <*> pS) <|> satisfy "0"+ test "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])+ ,(replicate 5 '1', aho_S_5)]++ let pE = "E" <::=> (\((x,y),z) -> x+y+z) <$> pE <*> pE <*> pE + <|> 1 <$ char '1'+ <|> satisfy 0+ test "EEE" pE [("", [0]), ("1", [1]), ("11", [2])+ ,(replicate 5 '1', [5]), ("112", [])]++ let pE = "E" <::=> (\((x,y),z) -> x++y++z) <$> pE <*> pE <*> pE + <|> "1" <$ char '1'+ <|> satisfy "0"+ test "EEE ambig" pE [("", ["0"]), ("1", ["1"])+ ,("11", ["110", "011", "101"]), ("111", _EEE_3)]++ let pX = "X" <::=> maybe 0 (const 1) <$> optional (char 'z') + <|> (+1) <$> pX <* char '1'+ test "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])+ ,(replicate 100 '1', [100])]++ let pX = "X" <::=> satisfy 0 + <|> (+1) <$> pB *> pX <* char '1'+ pB = maybe 0 (const 0) <$> optional (char 'z')+ test "hidden left-recursion" pX + [("", [0]), ("zz11", [2]), ("z11", [2]), ("11", [2])+ ,(replicate 100 '1', [100])]+ where+ aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"]++ _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"]
+ src/GLL/Combinators/Test/Interface.hs view
@@ -0,0 +1,192 @@+{-| This model contains unit-tests for 'GLL.Combinators.Interface'++= 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.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+ 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 = take 100 . sort . nub+ norm_p_res = norm parse_res+ b = norm_p_res == norm res+ putStrLn (" >> " ++ [j,')',' '] ++ show b)+ 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'])+ ,("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",[])]++ -- Simple binding+ let pX = "X" <::=> ord <$> char 'a' <* char 'b'+ test "<::=>" 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", [])]++ -- 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 = (++) <$> 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" <::=> (+) <$> 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" <::=> (+) <$> pX <*> pY+ -- shouldn't this be 1 + infinite 0's?+ test "no parse infinite rec?" pY + [("a", [])]++ let pS = "S" <::=> ((\x y -> x+y+1) <$ char '1' <*> pS <*> pS) <|> satisfy 0 + test "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]+++ let pS = "S" <::=> ((\x y -> '1':x++y) <$ char '1' <*> pS <*> pS) <|> satisfy "0"+ test "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])+ ,(replicate 5 '1', aho_S_5)]++ let pE = "E" <::=> (\x y z -> x+y+z) <$> pE <*> pE <*> pE + <|> 1 <$ char '1'+ <|> satisfy 0+ test "EEE" pE [("", [0]), ("1", [1]), ("11", [2])+ ,(replicate 5 '1', [5]), ("112", [])]++ let pE = "E" <::=> (\x y z -> x++y++z) <$> pE <*> pE <*> pE + <|> "1" <$ char '1'+ <|> satisfy "0"+ test "EEE ambig" pE [("", ["0"]), ("1", ["1"])+ ,("11", ["110", "011", "101"]), ("111", _EEE_3)]++ let pX = "X" <::=> maybe 0 (const 1) <$> optional (char 'z') + <|> (+1) <$> pX <* char '1'+ test "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])+ ,(replicate 100 '1', [100])]++ let pX = "X" <::=> satisfy 0 + <|> (+1) <$ pB <*> pX <* char '1'+ pB = maybe 0 (const 0) <$> optional (char 'z')+ test "hidden left-recursion" pX + [("", [0]), ("zz11", [2]), ("z11", [2]), ("11", [2])+ ,(replicate 100 '1', [100])]+ where+ aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"]++ _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"]
+ src/GLL/Combinators/Test/MemBinInterface.hs view
@@ -0,0 +1,196 @@+{-| This model contains unit-tests for 'GLL.Combinators.MemBinInterface'++= Included examples++ * Elementary parsers+ * Sequencing+ * Alternatives+ * Simple binding+ * Binding with alternatives+ * Recursion (non-left)++ * Higher-order patterns:++ * Optional+ * Kleene-closure / positive closure+ * Seperator+ * Inline choice++ * Ambiguities:++ * "aaa"+ * longambig+ * aho_s+ * EEE++ * Left recursion+ * Hidden left-recursion+-}+module GLL.Combinators.Test.MemBinInterface where++import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))++import Control.Compose+import Control.Monad+import Data.Char (ord)+import Data.List (sort)+import Data.IORef+import qualified Data.Map as M+import qualified Data.IntMap as IM++import GLL.Combinators.MemBinInterface++-- | Defines and executes some unit-tests +main = do+ count <- newIORef 1+ let test mref name p arg_pairs = do+ i <- readIORef count+ modifyIORef count succ+ subcount <- newIORef 'a'+ putStrLn (">> testing " ++ show i ++ " (" ++ name ++ ")")+ forM_ arg_pairs $ \(str,res) -> do+ case mref of -- empty memtable between parses+ Nothing -> return ()+ Just ref -> modifyIORef ref (const IM.empty)+ j <- readIORef subcount+ modifyIORef subcount succ+ parse_res <- parseString p str+ let norm = sort . take 100+ b = norm parse_res == norm res+ putStrLn (" >> " ++ [j,')',' '] ++ show b)+ unless b (putStrLn (" >> " ++ show parse_res))++ -- Elementary parsers+ test Nothing "eps1" (satisfy 0) [("", [0])]+ test Nothing "eps2" (0 <$ epsilon) [("", [0]), ("111", [])]+ test Nothing "single" (char 'a') [("a", ['a'])+ ,("abc", [])]+ test Nothing "semfun1" (1 <$ char 'a') [("a", [1])]++ -- Elementary combinators+ test Nothing "<*>" ((\b -> ['1',b]) <$> char 'a' *> char 'b')+ [("ab", ["1b"])+ ,("b", [])]+ + -- Alternation+ test Nothing "<|>" (ord <$> char 'a' *> char 'b' <|> ord <$> char 'c')+ [("a", []), ("ab", [98]), ("c", [99]), ("cab", [])]++ -- Simple binding+ let pX = "X" <::=> ord <$> char 'a' <* char 'b'+ test Nothing "<::=>" pX [("ab",[97]),("a",[])]++ let pX = "X" <::=> uncurry (flip (:)) <$> pY <*> char 'a'+ pY = "Y" <::=> uncurry (\x y -> [x,y]) <$> char 'b' <*> char 'c'+ test Nothing "<::=> 2" pX [("bca", ["abc"]), ("cba", [])]++ -- Binding with alternatives+ let pX = "X" <::=> pY <* char 'c'+ pY = "Y" <::=> char 'a' <|> char 'b'+ test Nothing "<::=> <|>" pX [("ac", "a"), ("bc", "b")]++ -- (Right) Recursion+ let pX = "X" <::=> (+1) <$> char 'a' *> pX <|> 0 <$ epsilon+ test Nothing "rec1" pX [("", [0]), ("aa",[2]), (replicate 42 'a', [42]), ("bbb", [])]++ -- EBNF+ let pX = "X" <::=> id <$> char 'a' *> char 'b' *> optional (char 'z')+ test Nothing "optional" pX [("abz", [Just 'z']), ("abab", []), ("ab", [Nothing])]++ let pX = "X" <::=> (char 'a' <|> char 'b')+ test Nothing "<|> optional" (pX <* optional (char 'z'))+ [("az", "a"), ("bz", "b"), ("z", []), ("b", "b"), ("a", "a")]++ let pX = "X" <::=> (1 <$ optional (char 'a') <|> 2 <$ optional (char 'b'))+ test Nothing "optional-ambig" (pX <* optional (char 'z'))+ [("az", [1]), ("bz", [2]), ("z", [1,2]), ("b", [2]), ("a", [1])]++ let pX = "X" <::=> id <$> char 'a' *> (char 'b' <|> char 'c')+ test Nothing "inline choice (1)" pX+ [("ab", "b"), ("ac", "c"), ("a", []), ("b", [])]++ let pX = "X" <::=> length <$> many (char '1')+ test Nothing "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])]++ let pX = "X" <::=> length <$> some (char '1')+ test Nothing "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])]++ let pX = "X" <::=> (1 <$ many (char 'a') <|> 2 <$ many (char 'b'))+ test Nothing "(many <|> many) <*> optional" (pX <* optional (char 'z'))+ [("az", [1]), ("bz", [2]), ("z", [1,2])+ ,("", [1,2]), ("b", [2]), ("a", [1])]++ let pX = "X" <::=> pY <* optional (char 'z')+ where pY = "Y" <::=> length <$> many (char 'a')+ <|> length <$> some (char 'b') <* char 'e'+ test Nothing "many & some & optional" + pX [("aaaz", [3]), ("bbbez", [3]), ("ez", []), ("z", [0])+ ,("aa", [2]), ("bbe", [2]) + ]++ -- Simple ambiguities+ let pX = uncurry (++) <$> pA <*> pB+ pA = "a" <$ char 'a' <|> "aa" <$ char 'a' <* char 'a'+ pB = "b" <$ char 'a' <|> "bb" <$ char 'a' <* char 'a' + test Nothing "aaa" pX [("aaa", ["aab", "abb"])+ ,("aa", ["ab"])]++ let pX = (\(x,y) -> [x,y]) <$> char 'a' *> pL <*> pL <* char 'e'+ pL = 1 <$ char 'b'+ <|> 2 <$ char 'b' <* char 'c'+ <|> 3 <$ char 'c' <* char 'd'+ <|> 4 <$ char 'd'+ test Nothing "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])]++ tab1 <- newMemoTable+ let pX = "X" <::=> (1 <$ some (char 'a') <|> 2 <$ many (char 'b'))+ pY = memo tab1 ("Y" <::=> uncurry (+) <$> pX <*> pY+ <|> satisfy 0)+ test (Just tab1) "some & many & recursion + ambiguities" pY+ [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])]++ tab <- newMemoTable+ let pX = "X" <::=> 1 <$ char 'a' <|> satisfy 0+ pY = memo tab ("Y" <::=> uncurry (+) <$> pX <*> pY)+ -- shouldn't this be 1 + infinite 0's?+ test (Just tab) "no parse infinite rec?" pY + [("a", [])]++ -- Higher ambiguities+ let pS = "S" <::=> ((\(x,y) -> x+y+1) <$> char '1' *> pS <*> pS) <|> satisfy 0 + test Nothing "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]+++ let pS = "S" <::=> ((\(x,y) -> '1':x++y) <$> char '1' *> pS <*> pS) <|> satisfy "0"+ test Nothing "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])+ ,(replicate 5 '1', aho_S_5)]+++ tab <- newMemoTable+ let pE = memo tab ("E" <::=> (\((x,y),z) -> x+y+z) <$> pE <*> pE <*> pE + <|> 1 <$ char '1'+ <|> satisfy 0)+ test (Just tab) "EEE" pE [("", [0]), ("1", [1]), ("11", [2])+ ,(replicate 5 '1', [5]), ("112", [])]++ let pE = "E" <::=> (\((x,y),z) -> x++y++z) <$> pE <*> pE <*> pE + <|> "1" <$ char '1'+ <|> satisfy "0"+ test Nothing "EEE ambig" pE [("", ["0"]), ("1", ["1"])+ ,("11", ["110", "011", "101"]), ("111", _EEE_3)]++ let pX = "X" <::=> maybe 0 (const 1) <$> optional (char 'z') + <|> (+1) <$> pX <* char '1'+ test Nothing "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])+ ,(replicate 100 '1', [100])]++ let pX = "X" <::=> satisfy 0 + <|> (+1) <$> pB *> pX <* char '1'+ pB = maybe 0 (const 0) <$> optional (char 'z')+ test Nothing "hidden left-recursion" pX + [("", [0]), ("zz11", [2]), ("z11", [2]), ("11", [2])+ ,(replicate 100 '1', [100])]+ where+ aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"]++ _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"]
+ src/GLL/Combinators/Test/MemInterface.hs view
@@ -0,0 +1,196 @@+{-| This model contains unit-tests for 'GLL.Combinators.MemInterface'++= Included examples++ * Elementary parsers+ * Sequencing+ * Alternatives+ * Simple binding+ * Binding with alternatives+ * Recursion (non-left)++ * Higher-order patterns:++ * Optional+ * Kleene-closure / positive closure+ * Seperator+ * Inline choice++ * Ambiguities:++ * "aaa"+ * longambig+ * aho_s+ * EEE++ * Left recursion+ * Hidden left-recursion+-}+module GLL.Combinators.Test.MemInterface where++import Prelude hiding ((<$>),(<*>),(<*),(<$))++import Control.Compose+import Control.Monad+import Data.Char (ord)+import Data.List (sort,nub)+import Data.IORef+import qualified Data.Map as M+import qualified Data.IntMap as IM++import GLL.Combinators.MemInterface++-- | Defines and executes some unit-tests +main = do+ count <- newIORef 1+ let test mref name p arg_pairs = do+ i <- readIORef count+ modifyIORef count succ+ subcount <- newIORef 'a'+ putStrLn (">> testing " ++ show i ++ " (" ++ name ++ ")")+ forM_ arg_pairs $ \(str,res) -> do+ case mref of -- empty memtable between parses+ Nothing -> return ()+ Just ref -> modifyIORef ref (const IM.empty)+ j <- readIORef subcount+ modifyIORef subcount succ+ parse_res <- parseString p str+ let norm = take 100 . sort . nub+ b = norm parse_res == norm res+ putStrLn (" >> " ++ [j,')',' '] ++ show b)+ unless b (putStrLn (" >> " ++ show parse_res))++ -- Elementary parsers+ test Nothing "eps1" (satisfy 0) [("", [0])]+ test Nothing "eps2" (0 <$ epsilon) [("", [0]), ("111", [])]+ test Nothing "single" (char 'a') [("a", ['a'])+ ,("abc", [])]+ test Nothing "semfun1" (1 <$ char 'a') [("a", [1])]++ -- Elementary combinators+ test Nothing "<*>" ((\b -> ['1',b]) <$ char 'a' <*> char 'b')+ [("ab", ["1b"])+ ,("b", [])]+ + -- Alternation+ test Nothing "<|>" (ord <$ char 'a' <*> char 'b' <|> ord <$> char 'c')+ [("a", []), ("ab", [98]), ("c", [99]), ("cab", [])]++ -- Simple binding+ let pX = "X" <::=> ord <$> char 'a' <* char 'b'+ test Nothing "<::=>" pX [("ab",[97]),("a",[])]++ let pX = "X" <::=> (flip (:)) <$> pY <*> char 'a'+ pY = "Y" <::=> (\x y -> [x,y]) <$> char 'b' <*> char 'c'+ test Nothing "<::=> 2" pX [("bca", ["abc"]), ("cba", [])]++ -- Binding with alternatives+ let pX = "X" <::=> pY <* char 'c'+ pY = "Y" <::=> char 'a' <|> char 'b'+ test Nothing "<::=> <|>" pX [("ac", "a"), ("bc", "b")]++ -- (Right) Recursion+ let pX = "X" <::=> (+1) <$ char 'a' <*> pX <|> 0 <$ epsilon+ test Nothing "rec1" pX [("", [0]), ("aa",[2]), (replicate 42 'a', [42]), ("bbb", [])]++ -- EBNF+ let pX = "X" <::=> id <$ char 'a' <* char 'b' <*> optional (char 'z')+ test Nothing "optional" pX [("abz", [Just 'z']), ("abab", []), ("ab", [Nothing])]++ let pX = "X" <::=> (char 'a' <|> char 'b')+ test Nothing "<|> optional" (pX <* optional (char 'z'))+ [("az", "a"), ("bz", "b"), ("z", []), ("b", "b"), ("a", "a")]++ let pX = "X" <::=> (1 <$ optional (char 'a') <|> 2 <$ optional (char 'b'))+ test Nothing "optional-ambig" (pX <* optional (char 'z'))+ [("az", [1]), ("bz", [2]), ("z", [1,2]), ("b", [2]), ("a", [1])]++ let pX = "X" <::=> id <$ char 'a' <*> (char 'b' <|> char 'c')+ test Nothing "inline choice (1)" pX+ [("ab", "b"), ("ac", "c"), ("a", []), ("b", [])]++ let pX = "X" <::=> length <$> many (char '1')+ test Nothing "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])]++ let pX = "X" <::=> length <$> some (char '1')+ test Nothing "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])]++ let pX = "X" <::=> (1 <$ many (char 'a') <|> 2 <$ many (char 'b'))+ test Nothing "(many <|> many) <*> optional" (pX <* optional (char 'z'))+ [("az", [1]), ("bz", [2]), ("z", [1,2])+ ,("", [1,2]), ("b", [2]), ("a", [1])]++ let pX = "X" <::=> pY <* optional (char 'z')+ where pY = "Y" <::=> length <$> many (char 'a')+ <|> length <$> some (char 'b') <* char 'e'+ test Nothing "many & some & optional" + pX [("aaaz", [3]), ("bbbez", [3]), ("ez", []), ("z", [0])+ ,("aa", [2]), ("bbe", [2]) + ]++ -- Simple ambiguities+ let pX = (++) <$> pA <*> pB+ pA = "a" <$ char 'a' <|> "aa" <$ char 'a' <* char 'a'+ pB = "b" <$ char 'a' <|> "bb" <$ char 'a' <* char 'a' + test Nothing "aaa" pX [("aaa", ["aab", "abb"])+ ,("aa", ["ab"])]++ let pX = (\x y -> [x,y]) <$ char 'a' <*> pL <*> pL <* char 'e'+ pL = 1 <$ char 'b'+ <|> 2 <$ char 'b' <* char 'c'+ <|> 3 <$ char 'c' <* char 'd'+ <|> 4 <$ char 'd'+ test Nothing "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])]++ tab1 <- newMemoTable+ let pX = "X" <::=> (1 <$ some (char 'a') <|> 2 <$ many (char 'b'))+ pY = memo tab1 ("Y" <::=> (+) <$> pX <*> pY+ <|> satisfy 0)+ test (Just tab1) "some & many & recursion + ambiguities" pY+ [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])]++ tab <- newMemoTable+ let pX = "X" <::=> 1 <$ char 'a' <|> satisfy 0+ pY = memo tab ("Y" <::=> (+) <$> pX <*> pY)+ -- shouldn't this be 1 + infinite 0's?+ test (Just tab) "no parse infinite rec?" pY + [("a", [])]++ -- Higher ambiguities+ let pS = "S" <::=> ((\x y -> x+y+1) <$ char '1' <*> pS <*> pS) <|> satisfy 0 + test Nothing "aho_S" pS [("", [0]), ("1", [1]), (replicate 5 '1', [5])]+++ let pS = "S" <::=> ((\x y -> '1':x++y) <$ char '1' <*> pS <*> pS) <|> satisfy "0"+ test Nothing "aho_S" pS [("", ["0"]), ("1", ["100"]), ("11", ["10100", "11000"])+ ,(replicate 5 '1', aho_S_5 )]+++ tab <- newMemoTable+ let pE = memo tab ("E" <::=> (\x y z -> x+y+z) <$> pE <*> pE <*> pE + <|> 1 <$ char '1'+ <|> satisfy 0)+ test (Just tab) "EEE" pE [("", [0]), ("1", [1]), ("11", [2])+ ,(replicate 5 '1', [5]), ("112", [])]++ let pE = "E" <::=> (\x y z -> x++y++z) <$> pE <*> pE <*> pE + <|> "1" <$ char '1'+ <|> satisfy "0"+ test Nothing "EEE ambig" pE [("", ["0"]), ("1", ["1"])+ ,("11", ["110", "011", "101"]), ("111", _EEE_3)]++ let pX = "X" <::=> maybe 0 (const 1) <$> optional (char 'z') + <|> (+1) <$> pX <* char '1'+ test Nothing "simple left-recursion" pX [("", [0]), ("z11", [3]), ("z", [1])+ ,(replicate 100 '1', [100])]++ let pX = "X" <::=> satisfy 0 + <|> (+1) <$ pB <*> pX <* char '1'+ pB = maybe 0 (const 0) <$> optional (char 'z')+ test Nothing "hidden left-recursion" pX + [("", [0]), ("zz11", [2]), ("z11", [2]), ("11", [2])+ ,(replicate 100 '1', [100])]+ where+ aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"]++ _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"]
− src/GLL/Common.hs
@@ -1,4 +0,0 @@-module GLL.Common where--type Nt = String-type Pid = String
src/GLL/Parser.hs view
@@ -16,7 +16,6 @@ import qualified Data.Set as S import qualified Data.IntSet as IS -import GLL.Common import GLL.Types.Abstract import GLL.Types.Grammar @@ -138,7 +137,7 @@ 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) ]+ 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]
src/GLL/Types/Abstract.hs view
@@ -7,8 +7,10 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.List (delete, (\\), elemIndices, findIndices)-import GLL.Common {-# LINE 12 "dist/build/GLL/Types/Abstract.hs" #-}++-- | Identifier for non-terminals+type Nt = String -- Alt --------------------------------------------------------- data Alt = Alt (Nt) (Symbols) -- Alts --------------------------------------------------------@@ -16,7 +18,7 @@ -- Grammar ----------------------------------------------------- data Grammar = Grammar (Nt) (([(String,String)])) (Rules) -- Rule ---------------------------------------------------------data Rule = Rule (Nt) (Alts) (([Pid]))+data Rule = Rule (Nt) (Alts) -- Rules ------------------------------------------------------- type Rules = [Rule] -- Slot --------------------------------------------------------
src/GLL/Types/Grammar.hs view
@@ -8,7 +8,6 @@ import qualified Data.IntSet as IS import Data.List (delete, (\\), elemIndices, findIndices) import GLL.Types.Abstract-import GLL.Common token_length :: Token -> Int token_length (Char _) = 1
− tests/interface/MemTests.hs
@@ -1,188 +0,0 @@--module MemTests 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---- | Needed examples--- * Elementary parsers--- * Sequencing--- * Alternatives--- * Simple binding--- * Binding with alternatives--- * Recursion (non-left)--- * Higher-order patterns:--- > Optional--- > Kleene-closure / positive closure--- > Seperator--- > Withing / Parentheses--- * Ambiguities:--- > "aaa"--- > longambig--- > aho_S--- > EEE--- * Left recursion--- * Hidden left-recursion--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])]--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"]
− tests/interface/UnitTests.hs
@@ -1,180 +0,0 @@--module UnitTests 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---- | Needed 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--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 = take 100 . sort . nub- norm_p_res = norm parse_res- b = norm_p_res == norm res- putStrLn (" >> " ++ [j,')',' '] ++ show b)- 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'])- ,("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" <::=> flip (:) <$> pY <*> char 'a'- pY = "Y" <::=> (\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 = (++) <$> 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" <::=> (+) <$> 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" <::=> (+) <$> 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])]--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"]