diff --git a/gll.cabal b/gll.cabal --- a/gll.cabal +++ b/gll.cabal @@ -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 diff --git a/src/GLL/Combinators/BinInterface.hs b/src/GLL/Combinators/BinInterface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/BinInterface.hs @@ -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 + 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,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) diff --git a/src/GLL/Combinators/MemBinInterface.hs b/src/GLL/Combinators/MemBinInterface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/MemBinInterface.hs @@ -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 + diff --git a/src/GLL/Combinators/MemInterface.hs b/src/GLL/Combinators/MemInterface.hs --- a/src/GLL/Combinators/MemInterface.hs +++ b/src/GLL/Combinators/MemInterface.hs @@ -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) diff --git a/src/GLL/Combinators/Test/BinInterface.hs b/src/GLL/Combinators/Test/BinInterface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Test/BinInterface.hs @@ -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"] diff --git a/src/GLL/Combinators/Test/Interface.hs b/src/GLL/Combinators/Test/Interface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Test/Interface.hs @@ -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"] diff --git a/src/GLL/Combinators/Test/MemBinInterface.hs b/src/GLL/Combinators/Test/MemBinInterface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Test/MemBinInterface.hs @@ -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"] diff --git a/src/GLL/Combinators/Test/MemInterface.hs b/src/GLL/Combinators/Test/MemInterface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Test/MemInterface.hs @@ -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"] diff --git a/src/GLL/Common.hs b/src/GLL/Common.hs deleted file mode 100644 --- a/src/GLL/Common.hs +++ /dev/null @@ -1,4 +0,0 @@ -module GLL.Common where - -type Nt = String -type Pid = String diff --git a/src/GLL/Parser.hs b/src/GLL/Parser.hs --- a/src/GLL/Parser.hs +++ b/src/GLL/Parser.hs @@ -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] 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 @@ -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 -------------------------------------------------------- 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 @@ -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 diff --git a/tests/interface/MemTests.hs b/tests/interface/MemTests.hs deleted file mode 100644 --- a/tests/interface/MemTests.hs +++ /dev/null @@ -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"] diff --git a/tests/interface/UnitTests.hs b/tests/interface/UnitTests.hs deleted file mode 100644 --- a/tests/interface/UnitTests.hs +++ /dev/null @@ -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"]