diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,6 @@ -import Distribution.Simple -main = defaultMain + +import Distribution.Simple (defaultMainWithHooks) +import Distribution.Simple.UUAGC (uuagcLibUserHook) +import UU.UUAGC (uuagc) + +main = defaultMainWithHooks (uuagcLibUserHook uuagc) 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.1.0.1 +version: 0.2.0.0 synopsis: GLL parser with simple combinator interface license: BSD3 license-file: LICENSE @@ -12,17 +12,50 @@ category: Compilers build-type: Simple cabal-version: >=1.8 -tested-with: GHC == 7.10.1 +tested-with: GHC == 7.6.3 +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 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 with the <$> combinator. + + 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). + + 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. + + 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. + + See UnitTests and MemTests for examples of using both version of + the library. + library - hs-source-dirs : src + hs-source-dirs : src,tests/interface build-depends : base >=4.5 && <= 4.8.0.0 , containers >= 0.4 , array - exposed-modules : GLL.Combinators.Combinators + , TypeCompose + exposed-modules : GLL.Combinators.Interface + , GLL.Combinators.MemInterface + , GLL.Combinators.Options + , UnitTests + , MemTests other-modules : GLL.Types.Abstract , GLL.Types.Grammar - , GLL.Machines.RGLL + , GLL.Parser , GLL.Common + extensions : TypeOperators, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances diff --git a/src/GLL/Combinators/Combinators.hs b/src/GLL/Combinators/Combinators.hs deleted file mode 100644 --- a/src/GLL/Combinators/Combinators.hs +++ /dev/null @@ -1,147 +0,0 @@ -module GLL.Combinators.Combinators ( - parse, - parseString, - char, - epsilon, - (<$>), - (<$), - (<*>), - (<*), - (<::=>) - ) where - -import Prelude hiding ((<*>),(<*),(<$>),(<$)) - -import GLL.Common -import GLL.Types.Grammar hiding (epsilon) -import GLL.Types.Abstract -import GLL.Machines.RGLL (gllSPPF, pNodeLookup) - -import Control.Monad -import qualified Data.IntMap as IM -import qualified Data.Map as M -import qualified Data.Set as S - -type SymbVisit1 b = Symbol -type SymbVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt] -type SymbVisit3 b = Int -> ParseContext -> SPPF -> Int -> Int -> [b] - -type IMVisit1 b = [Symbol] -type IMVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt] -type IMVisit3 b = Int -> ParseContext -> SPPF -> (Alt,Int) -> Int -> Int -> [b] - -type ParseContext = IM.IntMap (IM.IntMap (S.Set Nt)) - -type SymbParser b = (SymbVisit1 b,SymbVisit2 b, SymbVisit3 b) -type IMParser b = (IMVisit1 b, IMVisit2 b, IMVisit3 b) - -parseString :: (Show a) => SymbParser a -> String -> [a] -parseString p = parse p . map Char - -parse :: (Show a) => SymbParser a -> [Token] -> [a] -parse (vpa1,vpa2,vpa3) input = - let snode = (start, 0, m) - m = length input - start = vpa1 - rules = vpa2 M.empty - as = vpa3 (length input) IM.empty sppf 0 m - grammar = case start of - Nt x -> Grammar x [] [ Rule x alts [] | (x, alts) <- M.assocs rules ] - Term t -> Grammar "S" [] [Rule "S" [Alt "S" [start]] []] - Error _ _ -> error "can not parse error" - sppf = gllSPPF grammar input - in as - -inParseContext :: ParseContext -> (Symbol, Int, Int) -> Bool -inParseContext ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx - where inner = maybe False (S.member x) . IM.lookup r - -toParseContext :: ParseContext -> (Nt, Int, Int) -> ParseContext -toParseContext ctx (x, l, r) = IM.alter inner l ctx - where inner mm = case mm of - Nothing -> Just $ singleRX - Just m -> Just $ IM.insertWith (S.union) r singleX m - singleRX = IM.singleton r singleX - singleX = S.singleton x - --- TODO take ParseContext into account while memoising? -memoParser :: SymbParser a -> SymbParser a -memoParser (v1,v2,v3) = (v1,v2,v3') - where v3' m pctx sppf l r = (table IM.! l) IM.! r - where table = IM.fromAscList - [ (l', rMap) | l' <- [0..m] - , let rMap = IM.fromAscList [ (r',v) | r' <- [0..m] - , let v = v3 m pctx sppf l' r' ]] - -mkParser :: String -> [IMParser a] -> SymbParser a -mkParser x altPs = - let vas1 = [ va1 | va1 <- map (\(f,_,_) -> f) altPs ] - alts = map (Alt x) vas1 - in (Nt x - ,\rules -> - if x `M.member` rules - then rules - else foldr ($) (M.insert x alts rules) $ (map (\(_,s,_) -> s) altPs) - ,\m ctx sppf l r -> - let ctx' = ctx `toParseContext` (x,l,r) - vas2 = [ va3 m ctx' sppf (alt,length rhs) l r - | (alt@(Alt _ rhs), va3) <- zip alts (map (\(_,_,t) -> t) altPs) ] - in if ctx `inParseContext` (Nt x, l, r) - then [] - else concat vas2 - ) -infix 5 <::=> -(<::=>) = mkParser - -infixl 4 <*> -(<*>) :: IMParser (a -> b) -> SymbParser a -> IMParser b -(vimp1,vimp2,vimp3) <*> (vpa1,vpa2,vpa3) = - (vimp1++[vpa1] - ,\rules -> - let rules1 = vpa2 rules - rules2 = vimp2 rules1 - in rules2 - ,\m ctx sppf (alt@(Alt x rhs),j) l r -> - let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r) - in [ a2b a | k <- ks, a <- vpa3 m ctx sppf k r, a2b <- vimp3 m ctx sppf (alt,j-1) l k ] - ) - -infixl 4 <* -(<*) :: IMParser b -> SymbParser a -> IMParser b -(vimp1,vimp2,vimp3) <* (vpa1,vpa2,vpa3) = - (vimp1++[vpa1] - ,\rules -> - let rules1 = vpa2 rules - rules2 = vimp2 rules1 - in rules2 - ,\m ctx sppf (alt@(Alt x rhs),j) l r -> - let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r) - in [ b | k <- ks, a <- vpa3 m ctx sppf k r, b <- vimp3 m ctx sppf (alt,j-1) l k ] - ) - -infixl 4 <$> -(<$>) :: (a -> b) -> SymbParser a -> IMParser b -f <$> (vpa1,vpa2,vpa3) = - ([vpa1] - ,\rules -> - vpa2 rules - ,\m ctx sppf (alt,j) l r -> - let a = vpa3 m ctx sppf l r - in maybe [] (const (map f a)) $ sppf `pNodeLookup` ((alt,1),l,r) - ) -infixl 4 <$ -(<$) :: b -> SymbParser a -> IMParser b -f <$ (vpa1,vpa2,vpa3) = - ([vpa1] - ,\rules -> - vpa2 rules - ,\m ctx sppf (alt,j) l r -> - let a = vpa3 m ctx sppf l r - in maybe [] (const (map (const f) a)) $ sppf `pNodeLookup` ((alt,1),l,r) - ) - -char :: Char -> SymbParser Char -char c = (charT c, id,\_ _ _ _ _ -> [c]) - -epsilon :: SymbParser () -epsilon = (Term Epsilon, id ,\_ _ _ _ _ -> [()]) diff --git a/src/GLL/Combinators/Interface.hs b/src/GLL/Combinators/Interface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Interface.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE TypeOperators, FlexibleInstances #-} + +module GLL.Combinators.Interface ( + SymbParser(..), IMParser(..), SPPF, + parse, parseString, grammar, sppf, + 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.Monad +import Data.List (unfoldr,intersperse) +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Set as S + +type SymbVisit1 b = Symbol +type SymbVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt] +type SymbVisit3 b = PCOptions -> ParseContext -> SPPF -> Int -> Int -> [b] + +type IMVisit1 b = [Symbol] +type IMVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt] +type IMVisit3 b = PCOptions -> (Alt,Int) -> ParseContext -> SPPF -> Int -> Int -> [b] + +type ParseContext = IM.IntMap (IM.IntMap (S.Set Nt)) + +data SymbParser b = SymbParser (SymbVisit1 b,SymbVisit2 b, SymbVisit3 b) +data IMParser b = IMParser (IMVisit1 b, IMVisit2 b, IMVisit3 b) + +parse' :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> (Grammar, ParseResult, [a]) +parse' opts p' input' = + let input = input' ++ [Char 'z'] + SymbParser (Nt start,vpa2,vpa3) = toSymb (id <$> p' <* char 'z') + snode = (start, 0, m) + m = length input + rules = vpa2 M.empty + as = vpa3 opts IM.empty sppf 0 m + grammar = Grammar start [] [ Rule x alts [] | (x, alts) <- M.assocs rules ] + parse_res = gllSPPF grammar input + sppf = sppf_result parse_res + in (grammar, parse_res, as) + +-- | The grammar of a given parser +grammar :: (IsSymbParser s) => s a -> Grammar +grammar p = (\(f,_,_) -> f) (parse' defaultOptions p []) + +-- | The semantic results of a parser, given a string of Tokens +parse :: (IsSymbParser s) => s a -> [Token] -> [a] +parse = parseWithOptions defaultOptions + +-- | Change the behaviour of the parse using GLL.Combinators.Options +parseWithOptions :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> [a] +parseWithOptions opts p = (\(_,_,t) -> t) . parse' opts p + +-- | Parse a string of characters +parseString :: (IsSymbParser s) => s a -> String -> [a] +parseString = parseStringWithOptions defaultOptions + +-- | Parse a string of characters using options +parseStringWithOptions :: (IsSymbParser s) => PCOptions -> s a -> String -> [a] +parseStringWithOptions opts p = parseWithOptions opts p . map Char + +-- | Get the SPPF produced by parsing the given input with the given parser +sppf :: (IsSymbParser s) => s a -> [Token] -> ParseResult +sppf p str = (\(_,s,_) -> s) $ parse' defaultOptions p str + +inParseContext :: ParseContext -> (Symbol, Int, Int) -> Bool +inParseContext ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx + where inner = maybe False (S.member x) . IM.lookup r + +toParseContext :: ParseContext -> (Nt, Int, Int) -> ParseContext +toParseContext ctx (x, l, r) = IM.alter inner l ctx + where inner mm = case mm of + Nothing -> Just $ singleRX + Just m -> Just $ IM.insertWith (S.union) r singleX m + singleRX = IM.singleton r singleX + singleX = S.singleton x + +infixl 2 <::=> +-- | Use this combinator on all combinators that might have an infinite +-- number of derivations for some input string. A non-terminal has +-- this property if and only if it is left-recursive and would be +-- left-recursive if all the right-hand sides of the productions of the +-- grammar are reversed. +(<::=>) :: (HasAlts b) => String -> b a -> SymbParser a +x <::=> altPs' = + let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ] + alts = map (Alt x) vas1 + altPs = unO $ altsOf altPs' in SymbParser + (Nt x + ,\rules -> + if x `M.member` rules + then rules + else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs) + ,\opts ctx sppf l r -> + let ctx' = ctx `toParseContext` (x,l,r) + vas2 = [ va3 opts (alt,length rhs) ctx' sppf l r + | (alt@(Alt _ rhs), va3) <- zip alts (map (\(IMParser (_,_,t)) -> t) altPs) ] + in if ctx `inParseContext` (Nt x, l, r) + then [] + else concatChoice opts vas2 + ) + +infixl 2 <:=> +-- | Use this combinator on all recursive non-terminals +(<:=>) :: (HasAlts b) => String -> b a -> SymbParser a +x <:=> altPs' = + let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ] + alts = map (Alt x) vas1 + altPs = unO $ altsOf altPs' in SymbParser + (Nt x + ,\rules -> + if x `M.member` rules + then rules + else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs) + ,\opts ctx sppf l r -> + let vas2 = [ va3 opts (alt,length rhs) ctx sppf l r + | (alt@(Alt _ rhs), va3) <- zip alts (map (\(IMParser (_,_,t)) -> t) altPs) ] + in concatChoice opts vas2 + ) + +concatChoice :: PCOptions -> [[a]] -> [a] +concatChoice opts ress = if left_biased_choice opts + then firstRes ress + else concat ress + where firstRes [] = [] + firstRes ([]:ress) = firstRes ress + firstRes (res:_) = res + +infixl 4 <*> +(<*>) :: (IsIMParser i, IsSymbParser s) => i (a -> b) -> s a -> IMParser b +pl' <*> pr' = + let IMParser (vimp1,vimp2,vimp3) = toImp pl' + SymbParser (vpa1,vpa2,vpa3) = toSymb pr' in IMParser + (vimp1++[vpa1] + ,\rules -> let rules1 = vpa2 rules + rules2 = vimp2 rules1 in rules2 + ,\opts (alt@(Alt x rhs),j) ctx sppf l r -> + let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r) + filter = maybe id id $ pivot_select opts + in [ a2b a | k <- (filter ks) , a <- vpa3 opts ctx sppf k r + , a2b <- vimp3 opts(alt,j-1) ctx sppf l k ] + ) + + +infixl 4 <* +(<*) :: (IsIMParser i, IsSymbParser s) => i b -> s a -> IMParser b + +pl' <* pr' = + let IMParser (vimp1,vimp2,vimp3) = toImp pl' + SymbParser (vpa1,vpa2,vpa3) = toSymb pr' in IMParser + (vimp1++[vpa1] + ,\rules -> + let rules1 = vpa2 rules + rules2 = vimp2 rules1 + in rules2 + ,\opts (alt@(Alt x rhs),j) ctx sppf l r -> + let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r) + filter = maybe id id $ pivot_select opts + in [ b | k <- (filter ks) , a <- vpa3 opts ctx sppf k r + , b <- vimp3 opts (alt,j-1) ctx sppf l k ] + ) + +infixl 4 <$> +(<$>) :: (IsSymbParser s) => (a -> b) -> s a -> IMParser b +f <$> p' = + let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser + ([vpa1] + ,\rules -> + vpa2 rules + ,\opts (alt,j) ctx sppf l r -> + let a = vpa3 opts ctx sppf l r + in maybe [] (const (map f a)) $ sppf `pNodeLookup` ((alt,1),l,r) + ) + +infixl 4 <$ +(<$) :: (IsSymbParser s) => b -> s a -> IMParser b +f <$ p' = + let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser + ([vpa1] + ,\rules -> + vpa2 rules + ,\opts (alt,j) ctx sppf l r -> + let a = vpa3 opts ctx sppf l r + in maybe [] (const (map (const f) a)) $ sppf `pNodeLookup` ((alt,1),l,r) + ) + +infixr 3 <|> +(<|>) :: (IsIMParser i, HasAlts b) => i a -> b a -> ([] :. IMParser) a +l' <|> r' = let l = toImp l' + r = altsOf r' + in O (l : unO r) + +raw_parser :: Token -> (Token -> a) -> SymbParser a +raw_parser t f = SymbParser (Term t, id,\_ _ _ _ _ -> [f t]) + +token :: Token -> SymbParser Token +token t = raw_parser t id + +char :: Char -> SymbParser Char +char c = raw_parser (Char c) (\(Char c) -> c) + +epsilon :: SymbParser () +epsilon = raw_parser (Epsilon) (\_ -> ()) + +satisfy :: a -> IMParser a +satisfy a = a <$ epsilon + +many :: SymbParser a -> SymbParser [a] +many p = SymbParser f + where SymbParser (myx,_,_) = p + SymbParser f = many_ ("(" ++ show myx ++ ")^") p + +many_ x p = x <:=> (:) <$> p <*> many_ x p <|> [] <$ epsilon + +some :: SymbParser a -> SymbParser [a] +some p = SymbParser f + where SymbParser (myx,_, _) = p + SymbParser f = some_ ("(" ++ show myx ++ ")+") p + +some_ x p = x <:=> (:) <$> p <*> some_ x p <|> (:[]) <$> p + +optional :: SymbParser a -> SymbParser (Maybe a) +optional p = SymbParser f + where SymbParser (myx, _, _) = p + SymbParser f = optional_ ("(" ++ show myx ++ ")?") p + +optional_ x p = x <:=> Just <$> p <|> (Nothing <$ epsilon) + +class HasAlts a where + altsOf :: a b -> ([] :. IMParser) b + +instance HasAlts IMParser where + altsOf = O . (:[]) + +instance HasAlts SymbParser where + altsOf = altsOf . toImp + +instance HasAlts ([] :. IMParser) where + altsOf = id + +class IsIMParser a where + toImp :: a b -> IMParser b + +instance IsIMParser IMParser where + toImp = id + +instance IsIMParser SymbParser where + toImp p = id <$> p + +instance IsIMParser ([] :. IMParser) where + toImp = toImp . toSymb + +class IsSymbParser a where + toSymb :: a b -> SymbParser b + +instance IsSymbParser IMParser where + toSymb = toSymb . O . (:[]) + +instance IsSymbParser SymbParser where + toSymb = id + +instance IsSymbParser ([] :. IMParser) where + toSymb a = mkName <:=> a + where mkName = "_" ++ concat (intersperse "|" (map op (unO a))) + where op (IMParser (rhs,_,_)) = concat (intersperse "*" (map show rhs)) + diff --git a/src/GLL/Combinators/MemInterface.hs b/src/GLL/Combinators/MemInterface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/MemInterface.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE TypeOperators, FlexibleInstances #-} + +module GLL.Combinators.MemInterface ( + SymbParser(..), IMParser(..), SPPF, + parse, parseString, grammar, sppf, + char, token, Token(..), + epsilon, satisfy, + many, some, optional, + (<$>), + (<$), + (<*>), + (<*), + (<::=>),(<:=>), + (<|>), + memo, newMemoTable + ) 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(..)) + +import Control.Compose +import Control.Monad +import Data.List (unfoldr,intersperse) +import Data.IORef +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Set as S + +type SymbVisit1 b = Symbol +type SymbVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt] +type SymbVisit3 b = PCOptions -> ParseContext -> SPPF -> Int -> Int -> IO [b] + +type IMVisit1 b = [Symbol] +type IMVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt] +type IMVisit3 b = PCOptions -> (Alt,Int) -> ParseContext -> SPPF -> Int -> Int -> IO [b] + +type ParseContext = IM.IntMap (IM.IntMap (S.Set Nt)) + +data SymbParser b = SymbParser (SymbVisit1 b,SymbVisit2 b, SymbVisit3 b) +data IMParser b = IMParser (IMVisit1 b, IMVisit2 b, IMVisit3 b) + +parse' :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> (Grammar, ParseResult, IO [a]) +parse' opts p' input' = + let input = input' ++ [Char 'z'] + SymbParser (Nt start,vpa2,vpa3) = toSymb (id <$> p' <* char 'z') + snode = (start, 0, m) + m = length input + rules = vpa2 M.empty + as = vpa3 opts IM.empty sppf 0 m + grammar = Grammar start [] [ Rule x alts [] | (x, alts) <- M.assocs rules ] + parse_res = gllSPPF grammar input + sppf = sppf_result parse_res + in (grammar, parse_res, as) + +-- | The grammar of a given parser +grammar :: (IsSymbParser s) => s a -> Grammar +grammar p = (\(f,_,_) -> f) (parse' defaultOptions p []) + +-- | The semantic results of a parser, given a string of Tokens +parse :: (IsSymbParser s) => s a -> [Token] -> IO [a] +parse = parseWithOptions defaultOptions + +-- | Change the behaviour of the parse using GLL.Combinators.Options +parseWithOptions :: (IsSymbParser s) => PCOptions -> s a -> [Token] -> IO [a] +parseWithOptions opts p = (\(_,_,t) -> t) . parse' opts p + +-- | Parse a string of characters +parseString :: (IsSymbParser s) => s a -> String -> IO [a] +parseString = parseStringWithOptions defaultOptions + +-- | Parse a string of characters using options +parseStringWithOptions :: (IsSymbParser s) => PCOptions -> s a -> String -> IO [a] +parseStringWithOptions opts p = parseWithOptions opts p . map Char + +-- | Get the SPPF produced by parsing the given input with the given parser +sppf :: (IsSymbParser s) => s a -> [Token] -> ParseResult +sppf p str = (\(_,s,_) -> s) $ parse' defaultOptions p str + +inParseContext :: ParseContext -> (Symbol, Int, Int) -> Bool +inParseContext ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx + where inner = maybe False (S.member x) . IM.lookup r + +toParseContext :: ParseContext -> (Nt, Int, Int) -> ParseContext +toParseContext ctx (x, l, r) = IM.alter inner l ctx + where inner mm = case mm of + Nothing -> Just $ singleRX + Just m -> Just $ IM.insertWith (S.union) r singleX m + singleRX = IM.singleton r singleX + singleX = S.singleton x + +infixl 2 <::=> +-- | Use this combinator on all combinators that might have an infinite +-- number of derivations for some input string. A non-terminal has +-- this property if and only if it is left-recursive and would be +-- left-recursive if all the right-hand sides of the productions of the +-- grammar are reversed. +(<::=>) :: (HasAlts b) => String -> b a -> SymbParser a +x <::=> altPs' = + let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ] + alts = map (Alt x) vas1 + altPs = unO $ altsOf altPs' in SymbParser + (Nt x + ,\rules -> + if x `M.member` rules + then rules + else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs) + ,\opts ctx sppf l r -> + let ctx' = ctx `toParseContext` (x,l,r) + sems = zip alts (map (\(IMParser (_,_,t)) -> t) altPs) + seq (alt@(Alt _ rhs), va3) = va3 opts (alt,length rhs) ctx' sppf l r + in if ctx `inParseContext` (Nt x, l, r) + then return [] + else do ass <- forM sems seq + return (concatChoice opts ass) + ) + +infixl 2 <:=> +-- | Use this combinator on all recursive non-terminals +(<:=>) :: (HasAlts b) => String -> b a -> SymbParser a +x <:=> altPs' = + let vas1 = [ va1 | va1 <- map (\(IMParser (f,_,_)) -> f) altPs ] + alts = map (Alt x) vas1 + altPs = unO $ altsOf altPs' in SymbParser + (Nt x + ,\rules -> + if x `M.member` rules + then rules + else foldr ($) (M.insert x alts rules) $ (map (\(IMParser (_,s,_)) -> s) altPs) + ,\opts ctx sppf l r -> + let sems = zip alts (map (\(IMParser (_,_,t)) -> t) altPs) + seq (alt@(Alt _ rhs), va3) = va3 opts (alt,length rhs) ctx sppf l r + in do ass <- forM sems seq + return (concatChoice opts ass) + ) + +concatChoice :: PCOptions -> [[a]] -> [a] +concatChoice opts ress = if left_biased_choice opts + then firstRes ress + else concat ress + where firstRes [] = [] + firstRes ([]:ress) = firstRes ress + firstRes (res:_) = res + +infixl 4 <*> +(<*>) :: (IsIMParser i, IsSymbParser s) => i (a -> b) -> s a -> IMParser b +pl' <*> pr' = + let IMParser (vimp1,vimp2,vimp3) = toImp pl' + SymbParser (vpa1,vpa2,vpa3) = toSymb pr' in IMParser + (vimp1++[vpa1] + ,\rules -> let rules1 = vpa2 rules + rules2 = vimp2 rules1 in rules2 + ,\opts (alt@(Alt x rhs),j) ctx sppf l r -> + let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r) + filter = maybe id id $ pivot_select opts + seq k = do as <- vpa3 opts ctx sppf k r + a2bs <- vimp3 opts(alt,j-1) ctx sppf l k + return [ a2b a | a2b <- a2bs, a <- as ] + in do ass <- forM (filter ks) seq + return (concat ass) + ) + + +infixl 4 <* +(<*) :: (IsIMParser i, IsSymbParser s) => i b -> s a -> IMParser b + +pl' <* pr' = + let IMParser (vimp1,vimp2,vimp3) = toImp pl' + SymbParser (vpa1,vpa2,vpa3) = toSymb pr' in IMParser + (vimp1++[vpa1] + ,\rules -> + let rules1 = vpa2 rules + rules2 = vimp2 rules1 + in rules2 + ,\opts (alt@(Alt x rhs),j) ctx sppf l r -> + let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r) + filter = maybe id id $ pivot_select opts + seq k = do as <- vpa3 opts ctx sppf k r + bs <- vimp3 opts (alt,j-1) ctx sppf l k + return [ b | b <- bs, a <- as ] + in do ass <- forM (filter ks) seq + return (concat ass) + ) + +infixl 4 <$> +(<$>) :: (IsSymbParser s) => (a -> b) -> s a -> IMParser b +f <$> p' = + let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser + ([vpa1] + ,\rules -> + vpa2 rules + ,\opts (alt,j) ctx sppf l r -> + let a = vpa3 opts ctx sppf l r + ks = maybe [] id $ sppf `pNodeLookup` ((alt,1),l,r) + in if null ks then return [] else do res <- a + return (map f res) + ) + +infixl 4 <$ +(<$) :: (IsSymbParser s) => b -> s a -> IMParser b +f <$ p' = + let SymbParser (vpa1,vpa2,vpa3) = toSymb p' in IMParser + ([vpa1] + ,\rules -> + vpa2 rules + ,\opts (alt,j) ctx sppf l r -> + let a = vpa3 opts ctx sppf l r + ks = maybe [] id $ sppf `pNodeLookup` ((alt,1),l,r) + in if null ks then return [] else do res <- a + return (map (const f) res) + ) + +infixr 3 <|> +(<|>) :: (IsIMParser i, HasAlts b) => i a -> b a -> ([] :. IMParser) a +l' <|> r' = let l = toImp l' + r = altsOf r' + in O (l : unO r) + +memo :: (IsSymbParser s) => MemoRef [a] -> s a -> SymbParser a +memo ref p' = let SymbParser (sym,rules,sem) = toSymb p' + lhs_sem opts ctx sppf l r = do + tab <- readIORef ref + case memLookup (l,r) tab of + Just as -> return as + Nothing -> do as <- sem opts ctx sppf l r + modifyIORef ref (memInsert (l,r) as) + return as + in SymbParser (sym, rules, lhs_sem) + +raw_parser :: Token -> (Token -> a) -> SymbParser a +raw_parser t f = SymbParser (Term t, id,\_ _ _ _ _ -> return [f t]) + +token :: Token -> SymbParser Token +token t = raw_parser t id + +char :: Char -> SymbParser Char +char c = raw_parser (Char c) (\(Char c) -> c) + +epsilon :: SymbParser () +epsilon = raw_parser (Epsilon) (\_ -> ()) + +satisfy :: a -> IMParser a +satisfy a = a <$ epsilon + +many :: SymbParser a -> SymbParser [a] +many p = SymbParser f + where SymbParser (myx,_,_) = p + SymbParser f = many_ ("(" ++ show myx ++ ")^") p + +many_ x p = x <:=> (:) <$> p <*> many_ x p <|> [] <$ epsilon + +some :: SymbParser a -> SymbParser [a] +some p = SymbParser f + where SymbParser (myx,_, _) = p + SymbParser f = some_ ("(" ++ show myx ++ ")+") p + +some_ x p = x <:=> (:) <$> p <*> some_ x p <|> (:[]) <$> p + +optional :: SymbParser a -> SymbParser (Maybe a) +optional p = SymbParser f + where SymbParser (myx, _, _) = p + SymbParser f = optional_ ("(" ++ show myx ++ ")?") p + +optional_ x p = x <:=> Just <$> p <|> (Nothing <$ epsilon) + +class HasAlts a where + altsOf :: a b -> ([] :. IMParser) b + +instance HasAlts IMParser where + altsOf = O . (:[]) + +instance HasAlts SymbParser where + altsOf = altsOf . toImp + +instance HasAlts ([] :. IMParser) where + altsOf = id + +class IsIMParser a where + toImp :: a b -> IMParser b + +instance IsIMParser IMParser where + toImp = id + +instance IsIMParser SymbParser where + toImp p = id <$> p + +instance IsIMParser ([] :. IMParser) where + toImp = toImp . toSymb + +class IsSymbParser a where + toSymb :: a b -> SymbParser b + +instance IsSymbParser IMParser where + toSymb = toSymb . O . (:[]) + +instance IsSymbParser SymbParser where + toSymb = id + +instance IsSymbParser ([] :. IMParser) where + toSymb a = mkName <:=> a + where mkName = "_" ++ concat (intersperse "|" (map op (unO a))) + where op (IMParser (rhs,_,_)) = concat (intersperse "*" (map show rhs)) + diff --git a/src/GLL/Combinators/Options.hs b/src/GLL/Combinators/Options.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Options.hs @@ -0,0 +1,26 @@ +module GLL.Combinators.Options where + +-- | Options datatype +-- * left_biased_choice: see function leftBiased +-- * pivot_select: provide a filtering function on `pivots' +data PCOptions = PCOptions { left_biased_choice :: Bool + , pivot_select :: Maybe ([Int] -> [Int]) + } + +-- | The default options: no disambiguation +defaultOptions :: PCOptions +defaultOptions = PCOptions False Nothing + +-- | Perform a disambiguation similar to 'longest-match' +maximumPivot :: PCOptions -> PCOptions +maximumPivot opts = opts {pivot_select = Just op} + where op [] = [] + op xs = (:[]) $ maximum xs + +-- | Make the <|> combinator left-biased such that it +-- only returns results of the right child if the left +-- child does not has any results. +leftBiased :: PCOptions +leftBiased = defaultOptions { left_biased_choice = True } + + diff --git a/src/GLL/Machines/RGLL.lhs b/src/GLL/Machines/RGLL.lhs deleted file mode 100644 --- a/src/GLL/Machines/RGLL.lhs +++ /dev/null @@ -1,382 +0,0 @@ - -%if false -\begin{code} -module GLL.Machines.RGLL ( - Slot(..) - , Alt(..) - , Symbol(..) - , PrL - , NtL - , parse - , gllSPPF - , charS - , charT - , nT - , epsilon - , pNodeLookup - ) where - -import Data.Foldable hiding (forM_, toList) -import Prelude hiding (lookup, foldr, fmap, foldl, elem, sum) -import Control.Monad -import Control.Applicative hiding (empty) -import Data.Map (Map(..), empty, insertWith, (!), toList, lookup) -import Data.Set (member, Set(..)) -import qualified Data.IntMap as IM -import qualified Data.Map as M -import qualified Data.Array as Array -import qualified Data.Set as S -import qualified Data.IntSet as IS - -import GLL.Common -import GLL.Types.Abstract -import GLL.Types.Grammar - -\end{code} -%endif - -\begin{code} -type LhsState = (Nt, Int) -type RhsState = (Slot, Int, Int) -\end{code} -%if false -\begin{code} -type Context = (SPPF, Rcal, Ucal, GSS, Pcal) -\end{code} -%endif -\begin{spec} -data Alt = Alt Nt [Symbol] -data Slot = Slot Nt [Symbol] [Symbol] -\end{spec} -\begin{code} -type Rcal = [(RhsState, SPPFNode)] -type Rcal' = Set (Int,Int,Slot,SPPFNode) -type Ucal = IM.IntMap (IM.IntMap (S.Set Slot)) -type GSS = IM.IntMap (M.Map Nt [GSSEdge]) -- can be set? TODO -type Pcal = IM.IntMap (M.Map Nt [Int]) -- can be set? TODO - -type GSSEdge = (SlotL, SPPFNode) -type GSSNode = (Nt, Int) -data GSlot = GSlot Slot - | U0 - deriving (Ord, Eq) - -data ASM a = ASM (Context -> (a, Context)) - -\end{code} - -\begin{code} -addState :: SPPFNode -> RhsState -> ASM () -getState :: ASM (Maybe (RhsState,SPPFNode)) -addSPPFEdge :: SPPFNode -> SPPFNode -> ASM () -popGSS :: GSSNode -> (Int) -> ASM [GSSEdge] -addGSSEdge :: GSSNode -> GSSEdge -> ASM () -getPops :: GSSNode -> ASM [Int] -joinSPPFs :: Slot -> SPPFNode -> Int -> Int -> Int - -> ASM SPPFNode -\end{code} - -\begin{code} -runASM :: ASM a -> Context -> Context -runASM (ASM f) p = snd $ f p -\end{code} - -%if false -\begin{code} -addSPPFEdge f t = ASM $ \((dv,pMap),r,u,gss,p) -> - ((), (( --- dv - insertWith (++) f [t] dv - , - pMapInsert f t pMap --- pMap - ) - ,r,u,gss,p)) - -hasState :: RhsState -> ASM Bool -hasState alt = ASM $ \ctx@(_,_,u,_,_) -> (alt `inU` u,ctx) - -newState :: SPPFNode -> RhsState -> ASM () -newState sppf alt = ASM $ \(dv,r,u,gss,p) -> - ((), (dv, (alt,sppf):r, alt `toU` u, gss , p)) - -addState sppf alt@(slot,l,i) = ASM $ \(dv,r,u,gss,p) -> - let new = not (alt `inU` u) - in if new then ((), (dv, (alt,sppf):r, alt `toU` u, gss , p)) - else ((), (dv, r, u, gss, p)) - -getState = ASM $ \(dv,r,u,gss,p) -> - case r of - [] -> (Nothing, (dv,r,u,gss,p)) - (next:rest) -> - (Just next, (dv,rest,u,gss,p)) -{- case S.size r of - 0 -> (Nothing, (dv,r,u,gss,p)) - _ -> - let ((l,i,slot,sppf),rest) = S.deleteFindMin r - in (Just ((slot,l,i),sppf), (dv,rest,u,gss,p))-} - -popGSS gn i = ASM $ \(dv,r,u,gss,p) -> - let res = gssLookup gn gss - in (res, (dv,r,u,gss,pInsert gn i p)) - where pInsert (x,l) i p = IM.alter inner l p - where inner mm = case mm of - Nothing -> Just $ M.singleton x [i] - Just m -> Just $ M.insertWith (++) x [i] m - gssLookup (x,l) gss = maybe [] inner $ IM.lookup l gss - where inner = maybe [] id . M.lookup x - -addGSSEdge (x,l) t = ASM $ \(dv,r,u,gss,p) -> - ((), (dv,r,u,gssInsert x l t gss,p)) - where gssInsert x l t gss = IM.alter inner l gss - where inner mm = case mm of - Nothing -> Just $ M.singleton x [t] - Just m -> Just $ M.insertWith (++) x [t] m - -getPops (x,i) = ASM $ \ctx@(dv,r,u,gss,p) -> (pLookup (x,i) p, ctx) - where pLookup (x,i) p = maybe [] (maybe [] id . M.lookup x) $ IM.lookup i p - -logMisMatch tau token i= ASM $ \(dv,r,u,gss,p) -> - ((), (dv,r,u,gss,p)) -\end{code} -%endif - -%if false -\begin{code} -instance Show GSlot where - show (U0) = "u0" - show (GSlot gn) = show gn - -instance Show SPPFNode where - show (SNode (s, l, r)) = "(s: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")" - show (INode (s, l, r)) = "(i: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")" - show (PNode (p, l, k, r)) = "(p: " ++ show p ++ ", " ++ show l ++ ", " ++ show k ++ ", " ++ show r ++ ")" - show Dummy = "$" - -instance Applicative ASM where - (<*>) = ap - pure = return -instance Functor ASM where - fmap = liftM -instance Monad ASM where - return a = ASM $ \p -> (a, p) - (ASM m) >>= f = ASM $ \p -> let (a, p') = m p - (ASM m') = f a - in m' p' -\end{code} -%endif - -%if false -\begin{code} - -parse ::Bool -> Grammar -> [Token] -> IO () -parse debug grammar@(Grammar start _ _) input' =do - let (resContext,prs,selects,follows) = gll debug grammar input' - when (debug) $ do - writeFile "/tmp/alts.txt" (unlines $ map show prs) - writeFile "/tmp/sets.txt" (show selects ++ "\n\n" ++ show follows) - proceed debug start (length input') resContext - - -gllSPPF :: Grammar -> [Token] -> SPPF -gllSPPF grammar input = let ((sppf,_,_,_,_),_,_,_) = gll False grammar input - in sppf - -gll :: Bool -> Grammar -> [Token] -> (Context, [Alt], SelectMap, FollowMap) -gll debug (Grammar start _ rules) input' = - (runASM (pLhs (start, 0) >> pCont) context, prs, selects, follows) - where - prs = [ alt | Rule _ alts _ <- rules, alt <- (reverse alts) ] - context = ((M.empty,IM.empty), [], IM.empty, IM.empty, IM.empty) - input = Array.array (0,m) $ zip [0..] $ input' ++ [EOS] - m = length input' -\end{code} -%endif - -\begin{code} - pCont :: ASM () - pLhs :: LhsState -> ASM () - pRhs :: RhsState -> SPPFNode -> ASM () -\end{code} - -Function |pCont| acts as the code-block starting with |L0| in a generated -GLL parser. -It takes care of the continuation of the algorithm. - -Function |pLhs| acts as the code-block starting with the label $L_{X}$, -if |pLhs| is applied to |X|. - -Function |pRhs| executes the other instructions of a generated GLL parser -(including labels of the form $L_{S_1}$ and $R_{X_1}$ and instructions -that aren't labelled). -Using pattern-matching the different cases for the different symbols -in the right-hand side are given -separate definitions. -As such, each call to |pRhs| `carries -the dot' of the slot in the current state `over' the next symbol. -There is also a case for when there is no symbol for the dot to be carried over, -at which the pop and return action needs to take place. - -Note that an |SPPFNode| is given as a separate argument to |pRhs| and no -|SPPFNode| is stored in the descriptors (|RhsState|). - -\subsection{Main parse function} -The whole procedure is started from within the function |parse| -which receives a start-sybmol, a list of productions and an -input string (of tokens) as arguments. - -\begin{spec} -parse :: Nt -> [Pr] -> [Token] -> IO () -- i/o monad -parse start prs input' = do - proceed (runASM (pLhs (start, 0, (U0,0))) context) - where - context = (empty, [], S.empty, empty, empty) - input = input' ++ [EOS] - m = length input' -\end{spec} - -In its |where|-clause are the input string appended with the end-of-string -symbol |EOS| and the integer |m| which matches the number of tokens in -the (original) input string. Because the functions |pCont|, |pRhs| and -|pLhs| are defined in the same |where|-clause, this information is availaible -to all these functions. - -Function |proceed| receives the context after running the entire algorithm -(running the computation represented by the |ASM| monad with |runASM|), -which is achieved by calling |pLhs| for the start symbol of the grammar -with current index |0| and initial |GSSNode| |(U0,0)|. The function -|runASM| also receives as argument the initial (empty) context. - -\subsection{Continuation} -\begin{code} - pCont = do - mnext <- getState - case mnext of - Nothing -> return () -- no continuation - Just (next,sppf) -> do f <- pRhs next sppf - f `seq` pCont -\end{code} - -The function |getSPPF| does the clerical work of finding the right -|SPPFNode| corresponding to the slot of the next descriptor. - -\subsection{Left-hand side} -Get the alternatives for which the select-test succeeds and add them to -the descriptor set |Rcal| and |Ucal|. The implementation of |addState| -ensures that no duplicates are added. - -\begin{code} - pLhs (bigx, i) = do - let alts = [ (Slot bigx [] beta, i, i) | (Alt bigx beta) <- altsOf bigx - , select (input Array.! i) beta bigx ] - forM_ alts (addState Dummy) -\end{code} - -The code |forM_ alts addState| is equivalent to \\|forM_ alts (\r -> addState r)| -and |forM_ alts (\r -> ...)| can be read as $(\forall r \in \mathit{alts}.\;\ldots)$. -Double dash are the characters to start a single line comment (|-- comment|). - -\subsection{Right-hand side} -\subsubsection{$\epsilon$-rule} -\begin{code} - pRhs (Slot bigx [] [Term Epsilon], l, i) _ = do - root <- joinSPPFs slot Dummy l i i - pRhs (slot, l, i) root - where slot = Slot bigx [Term Epsilon] [] -\end{code} - -\subsubsection{Terminal-case} - -\begin{code} - pRhs (Slot bigx alpha ((Term tau):beta), l, i) sppf = - when (input Array.! i == tau) $ do -- token test - root <- joinSPPFs slot sppf l i (i+1) - pRhs (slot, l, i+1) root - where slot = Slot bigx (alpha++[Term tau]) beta -\end{code} - -\begin{code} - pRhs (Slot bigx alpha ((Nt bigy):beta), l, i) sppf = do - when (select (input Array.! i) ((Nt bigy):beta) bigx) $ do - addGSSEdge (bigy,i) ((slot,l), sppf) - rs <- getPops (bigy, i) -- has ret been popped? - forM_ rs $ \r -> do -- yes, use given extents - root <- joinSPPFs slot sppf l i r - addState root (slot, l, r) - pLhs (bigy, i) - where slot = Slot bigx (alpha++[Nt bigy]) beta -\end{code} - -\begin{code} --- pRhs (Slot bigy alpha [], 0, i) sppf _ = return () -\end{code} -\begin{code} - pRhs (Slot bigy alpha [], l, i) ynode = do - returns <- popGSS (bigy,l) i -- pop @&@ get child GSSNodes - forM_ returns $ \((slot',l'),sppf) -> do - root <- joinSPPFs slot' sppf l' l i -- create SPPF for lhs - addState root (slot', l', i) -- add new descriptors -\end{code} - -%if false -\begin{code} - (prodMap,_,_,follows,selects) = fixedMaps start prs - follow x = follows ! x - select t rhs x = t `member` (selects ! (x,rhs)) - altsOf x = prodMap ! x - toReturnContext (x,l,r) = IM.alter inner r - where inner mm = case mm of - Nothing -> Just $ singleLS - Just m -> Just $ IM.insertWith (S.union) l singleS m - singleLS = IM.fromList [(l,singleS)] - singleS = S.singleton x - merge m1 m2 = IM.unionWith inner m1 m2 - where inner = IM.unionWith S.union -\end{code} -%endif - -\begin{code} -joinSPPFs (Slot bigx alpha beta) sppf l k r = - case (sppf, beta) of --- (Dummy, _:_) -> return snode - (Dummy, []) -> do addSPPFEdge xnode pnode - addSPPFEdge pnode snode - return xnode - (_, []) -> do addSPPFEdge xnode pnode - addSPPFEdge pnode sppf - addSPPFEdge pnode snode - return xnode - _ -> do addSPPFEdge inode pnode - addSPPFEdge pnode sppf - addSPPFEdge pnode snode - return inode - where x = last alpha -- symbol before the dot - snode = SNode (x, k, r) - xnode = SNode (Nt bigx, l, r) - inode = INode ((Slot bigx alpha beta), l, r) - pnode = PNode ((Slot bigx alpha beta), l, k, r) -\end{code} -%if false -\begin{code} - inReturnContext (SNode (Nt x,l,r)) = maybe False inner . IM.lookup r - where inner = maybe False ((x `S.member`)) . IM.lookup l -\end{code} -%endif - -%if false -\begin{code} -proceed :: Bool -> Nt -> Int -> Context -> IO () -proceed debug start m ((dv,pMap), r, u, gss, p) = do - when debug $ do - writeFile "/tmp/sppf.txt" (showD dv ++ "\n" ++ showP pMap) - let success = maybe False (const True) $ lookup (SNode (Nt start,0,m)) dv - unless success $ do - putStrLn "no parse..." - when (success) $ do - putStrLn ("Descriptors: " ++ show (usize)) - putStrLn ("SPPFNodes: " ++ show (length (M.keys dv) + m)) - putStrLn ("GSSNodes: " ++ show gsssize) - where usize = sum [ S.size s | (l, r2s) <- IM.assocs u, (r,s) <- IM.assocs r2s ] - gsssize = 1 + sum [ length $ M.keys x2s | (l,x2s) <- IM.assocs gss ] -\end{code} -%endif diff --git a/src/GLL/Parser.hs b/src/GLL/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Parser.hs @@ -0,0 +1,250 @@ +module GLL.Parser ( + gllSPPF -- run the parser + , charS, charT, nT, epsilon -- create terminals + , pNodeLookup, ParseResult(..) + ) where + +import Data.Foldable hiding (forM_, toList, sum) +import Prelude hiding (lookup, foldr, fmap, foldl, elem) +import Control.Monad +import Control.Applicative hiding (empty) +import Data.Map (Map(..), empty, insertWith, (!), toList, lookup) +import Data.Set (member, Set(..)) +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Array as A +import qualified Data.Set as S +import qualified Data.IntSet as IS + +import GLL.Common +import GLL.Types.Abstract +import GLL.Types.Grammar + +-- | Representation of the input string +type Input = A.Array Int Token + +-- | Types for +type LhsParams = (Nt , Int , GSSNode) +type RhsParams = (Slot , Int , GSSNode) + +-- | The worklist and descriptor set +type Rcal = [(RhsParams,SPPFNode)] +type Ucal = IM.IntMap (IM.IntMap (S.Set (Slot, GSlot))) + +-- | GSS representation +type GSS = IM.IntMap (M.Map GSlot [GSSEdge]) +type GSSEdge = (GSSNode, SPPFNode) +type GSSNode = (GSlot, Int) +data GSlot = GSlot Slot + | U0 + deriving (Ord, Eq) + +-- | Pop-set +type Pcal = IM.IntMap (Map GSlot [Int]) + +-- | Connecting it all +type Mutable = (SPPF,Rcal, Ucal, GSS, Pcal) + +-- | Monad for implicitly passing around 'context' +data GLL a = GLL (Mutable -> (a, Mutable)) + +addDescr :: SPPFNode -> RhsParams -> GLL () +getDescr :: GLL (Maybe (RhsParams,SPPFNode)) +addSPPFEdge :: SPPFNode -> SPPFNode -> GLL () +addPop :: GSSNode -> Int -> GLL () +getChildren :: GSSNode -> GLL [GSSEdge] +addGSSEdge :: GSSNode -> GSSEdge -> GLL () +getPops :: GSSNode -> GLL [Int] +joinSPPFs :: Slot -> SPPFNode -> Int -> Int -> Int + -> GLL SPPFNode +runGLL :: GLL a -> Mutable -> Mutable +runGLL (GLL f) p = snd $ f p +addSPPFEdge f t = GLL $ \(sppf,r,u,gss,p) -> + ((), + ( + pMapInsert f t $ + sppf + ,r,u,gss,p)) + +addDescr sppf alt@(slot,i,(gs,l)) = GLL $ \(dv,r,u,gss,p) -> + let new = maybe True inner $ IM.lookup i u + where inner m = maybe True (not . ((slot,gs) `S.member`)) $ IM.lookup l m + newU = IM.alter inner i u + where inner mm = case mm of + Nothing -> Just $ IM.singleton l single + Just m -> Just $ IM.insertWith (S.union) l single m + single = S.singleton (slot,gs) + in if new then ((), (dv, (alt,sppf):r, newU, gss , p)) + else ((), (dv, r, u, gss, p)) + +getDescr = GLL $ \(dv,r,u,gss,p) -> + case r of + [] -> (Nothing, (dv,r,u,gss,p)) + (next@(alt,sppf):rest) -> + let res = (Just next, (dv,rest,u,gss,p)) + in res + +addPop (gs,l) i = GLL $ \(dv,r,u,gss,p) -> + let newP = IM.alter inner l p + where inner mm = case mm of + Nothing -> Just $ M.singleton gs [i] + Just m -> Just $ M.insertWith (++) gs [i] m + in ((), (dv,r,u,gss,newP)) + +getChildren (gs,l) = GLL $ \(dv,r,u,gss,p) -> + let res = maybe [] inner $ IM.lookup l gss + where inner m = maybe [] id $ M.lookup gs m + in (res, (dv,r,u,gss,p)) + +addGSSEdge f@(gs,i) t = GLL $ \(dv,r,u,gss,p) -> + let newGSS = IM.alter inner i gss + where inner mm = case mm of + Nothing -> Just $ M.singleton gs [t] + Just m -> Just $ M.insertWith (++) gs [t] m + in ((), (dv,r,u,newGSS,p)) + +getPops (gs,l) = GLL $ \ctx@(dv,r,u,gss,p) -> + let res = maybe [] inner $ IM.lookup l p + where inner = maybe [] id . M.lookup gs + in (res, ctx) + +instance Show GSlot where + show (U0) = "u0" + show (GSlot gn) = show gn + +instance Show SPPFNode where + show (SNode (s, l, r)) = "(s: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")" + show (INode (s, l, r)) = "(i: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")" + show (PNode (p, l, k, r)) = "(p: " ++ show p ++ ", " ++ show l ++ ", " ++ show k ++ ", " ++ show r ++ ")" + show Dummy = "$" + +instance Applicative GLL where + (<*>) = ap + pure = return +instance Functor GLL where + fmap = liftM +instance Monad GLL where + return a = GLL $ \p -> (a, p) + (GLL m) >>= f = GLL $ \p -> let (a, p') = m p + (GLL m') = f a + in m' p' +gllSPPF :: Grammar -> [Token] -> ParseResult +gllSPPF grammar@(Grammar start _ _ ) input = + let (mutable,_,_,_) = gll m False grammar input + m = length input + in resultFromMutable mutable (Nt start, 0, m) + +gll :: Int -> Bool -> Grammar -> [Token] -> (Mutable, [Alt], SelectMap, FollowMap) +gll m debug (Grammar start _ rules) input' = + (runGLL (pLhs (start, 0, (U0,0))) context, prs, selects, follows) + where + prs = [ alt | Rule _ alts _ <- rules, alt <- (reverse alts) ] + context = (emptySPPF, [], IM.empty, IM.empty, IM.empty) + input = A.array (0,m) $ zip [0..] $ input' ++ [EOS] + + dispatch :: GLL () + pLhs :: LhsParams -> GLL () + pRhs :: RhsParams -> SPPFNode -> GLL () + + dispatch = do + mnext <- getDescr + case mnext of + Nothing -> return () -- no continuation + Just (next,sppf) -> pRhs next sppf + pLhs (bigx, i, gn) = do + let alts = [ (Slot bigx [] beta, i, gn) | (Alt bigx beta) <- altsOf bigx + , select (input A.! i) beta bigx + ] + forM_ alts (addDescr Dummy) + dispatch + + pRhs (Slot bigx [] [Term Epsilon], i, (gs,l)) _ = do + root <- joinSPPFs slot Dummy l i i + pRhs (slot, i, (gs,l)) root + where slot = Slot bigx [Term Epsilon] [] + + pRhs (Slot bigx alpha ((Term tau):beta), i, (gs,l)) sppf = + if (input A.! i == tau) + then do -- token test + root <- joinSPPFs slot sppf l i (i+1) + pRhs (slot, i+1, (gs,l)) root + else + dispatch + where slot = Slot bigx (alpha++[Term tau]) beta + + pRhs (Slot bigx alpha ((Nt bigy):beta), i, (gs, l)) sppf = + if (select (input A.! i) ((Nt bigy):beta) bigx) + then do + addGSSEdge ret ((gs,l), sppf) + rs <- getPops ret -- has ret been popped? + forM_ rs $ \r -> do -- yes, use given extents + root <- joinSPPFs slot sppf l i r + addDescr root (slot, r, (gs,l)) + pLhs (bigy, i, ret) + else + dispatch + where ret = (GSlot slot, i) + slot = Slot bigx (alpha++[Nt bigy]) beta + + pRhs (Slot bigy alpha [], i, (U0,0)) sppf = dispatch + + pRhs (Slot bigy alpha [], i, gn@(GSlot slot,l)) ynode = do + addPop gn i + returns <- getChildren gn + forM_ returns $ \((gs',l'),sppf) -> do + root <- joinSPPFs slot sppf l' l i -- create SPPF for lhs + addDescr root (slot, i, (gs',l')) -- add new descriptors + dispatch + + (prodMap,_,_,follows,selects) = fixedMaps start prs + follow x = follows ! x + select t rhs x = t `member` (selects ! (x,rhs)) + altsOf x = prodMap ! x + merge m1 m2 = IM.unionWith inner m1 m2 + where inner = IM.unionWith S.union + +joinSPPFs (Slot bigx alpha beta) sppf l k r = + case (sppf, beta) of +-- (Dummy, _:_) -> return snode + (Dummy, []) -> do addSPPFEdge xnode pnode + addSPPFEdge pnode snode + return xnode + (_, []) -> do addSPPFEdge xnode pnode + addSPPFEdge pnode sppf + addSPPFEdge pnode snode + return xnode + _ -> do addSPPFEdge inode pnode + addSPPFEdge pnode sppf + addSPPFEdge pnode snode + return inode + where x = last alpha -- symbol before the dot + snode = SNode (x, k, r) + xnode = SNode (Nt bigx, l, r) + inode = INode ((Slot bigx alpha beta), l, r) + pnode = PNode ((Slot bigx alpha beta), l, k, r) + +data ParseResult = ParseResult { sppf_result :: SPPF + , success :: Bool + , nr_descriptors :: Int + , nr_sppf_edges :: Int + , nr_gss_nodes :: Int + } + +resultFromMutable :: Mutable -> SNode -> ParseResult +resultFromMutable (sppf@(_,_,_,eMap,_),_,u,gss,_) s_node = + ParseResult sppf success usize sppf_edges gsssize + where success = sppf `sNodeLookup` s_node + usize = sum [ S.size s | (l, r2s) <- IM.assocs u + , (r,s) <- IM.assocs r2s ] + sppf_edges = sum [ S.size ts | (_, ts) <- M.assocs eMap ] + gsssize = 1 + sum [ length $ M.keys x2s| (l,x2s) <- IM.assocs gss] + +instance Show ParseResult where + show res = unlines $ + [ "Success: " ++ show (success res) + , "Descriptors: " ++ show (nr_descriptors res) + , "SPPFEdges: " ++ show (nr_sppf_edges res) + , "GSSNodes: " ++ show (nr_gss_nodes res) + ] + + 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 @@ -26,9 +26,14 @@ type NtL = (Nt, Int) -- Nonterminal with left extent -- SPPF +type SPPF = (SymbMap, ImdMap, PackMap, EdgeMap, IDMap) type PackMap = IM.IntMap (IM.IntMap (IM.IntMap (M.Map Alt IS.IntSet))) type SymbMap = IM.IntMap (IM.IntMap (S.Set Symbol)) -type SPPF = (M.Map SPPFNode ([SPPFNode]), PackMap) +type ImdMap = IM.IntMap (IM.IntMap (S.Set Slot)) +type EdgeMap = M.Map SPPFNode (S.Set SPPFNode) +type IDMap = (IDFMap,IDTMap) +type IDFMap = IM.IntMap SPPFNode +type IDTMap = M.Map SPPFNode Int data SPPFNode = SNode (Symbol, Int, Int) | INode (Slot, Int, Int) | PNode (Slot, Int, Int, Int) @@ -39,19 +44,22 @@ type SEdge = M.Map SNode (S.Set PNode) type PEdge = M.Map PNode (S.Set SNode) +emptySPPF :: SPPF +emptySPPF = (IM.empty, IM.empty, IM.empty, M.empty, (IM.empty, M.empty)) pNodeLookup :: SPPF -> ((Alt, Int), Int, Int) -> Maybe [Int] -pNodeLookup (_,pMap) ((alt,j),l,r) = maybe Nothing inner $ IM.lookup l pMap +pNodeLookup (_,_,pMap,_,_) ((alt,j),l,r) = maybe Nothing inner $ IM.lookup l pMap where inner = maybe Nothing inner2 . IM.lookup r inner2 = maybe Nothing inner3 . IM.lookup j inner3 = maybe Nothing (Just . IS.toList) . M.lookup alt -pMapInsert :: SPPFNode -> SPPFNode -> PackMap -> PackMap -pMapInsert f t pMap = - case f of - PNode (Slot x alpha beta, l, k, r) -> - add (Alt x (alpha++beta)) (length alpha) l r k - _ -> pMap +pMapInsert :: SPPFNode -> SPPFNode -> SPPF -> SPPF +pMapInsert f t (sMap,iMap,pMap,eMap,idMap) = + let pMap' = case f of + PNode ((Slot x alpha beta), l, k, r) -> + add (Alt x (alpha++beta)) (length alpha) l r k + _ -> pMap + in (sMap,iMap,pMap',eMap,idMap) where add alt j l r k = IM.alter addInnerL l pMap where addInnerL mm = case mm of Nothing -> Just singleRJAK @@ -68,14 +76,16 @@ singleK = IS.singleton k -sNodeLookup :: SymbMap -> (Symbol, Int, Int) -> Bool -sNodeLookup sm (s,l,r) = maybe False inner $ IM.lookup l sm +sNodeLookup :: SPPF -> (Symbol, Int, Int) -> Bool +sNodeLookup (sm,_,_,_,_) (s,l,r) = maybe False inner $ IM.lookup l sm where inner = maybe False (S.member s) . IM.lookup r -sNodeInsert f t sMap = - case f of - SNode (s, l, r) -> newt (add s l r sMap) - _ -> newt sMap +sNodeInsert :: SPPFNode -> SPPFNode -> SPPF -> SPPF +sNodeInsert f t (sMap,iMap,pMap,eMap,idMap) = + let sMap' = case f of + SNode (s, l, r) -> newt (add s l r sMap) + _ -> newt sMap + in (sMap',iMap,pMap,eMap,idMap) where newt sMap = case t of (SNode (s, l, r)) -> add s l r sMap _ -> sMap @@ -86,10 +96,51 @@ singleRS = IM.fromList [(r, singleS)] singleS = S.singleton s -sNodeRemove :: SymbMap -> (Symbol, Int, Int) -> SymbMap -sNodeRemove sm (s,l,r) = IM.adjust inner l sm +sNodeRemove :: SPPF -> (Symbol, Int, Int) -> SPPF +sNodeRemove (sm,iMap,pMap,eMap,idMap) (s,l,r) = + (IM.adjust inner l sm, iMap,pMap,eMap,idMap) where inner = IM.adjust ((s `S.delete`)) r +iNodeLookup :: SPPF -> (Slot, Int, Int) -> Bool +iNodeLookup (_,iMap,_,_,_) (s,l,r) = maybe False inner $ IM.lookup l iMap + where inner = maybe False (S.member s) . IM.lookup r + +iNodeInsert :: SPPFNode -> SPPFNode -> SPPF -> SPPF +iNodeInsert f t (sMap,iMap,pMap,eMap,idMap) = + let iMap' = case f of + INode (s, l, r) -> newt (add s l r iMap) + _ -> newt iMap + in (sMap,iMap',pMap,eMap,idMap) + where newt iMap = case t of + (INode (s, l, r)) -> add s l r iMap + _ -> iMap + add s l r iMap = IM.alter addInnerL l iMap + where addInnerL mm = case mm of + Nothing -> Just singleRS + Just m -> Just $ IM.insertWith (S.union) r singleS m + singleRS = IM.fromList [(r, singleS)] + singleS = S.singleton s + +iNodeRemove :: SPPF -> (Slot, Int, Int) -> SPPF +iNodeRemove (sMap,iMap,pMap,eMap,idMap) (s,l,r) = + (sMap,IM.adjust inner l iMap,pMap,eMap,idMap) + where inner = IM.adjust ((s `S.delete`)) r + +eMapInsert :: SPPFNode -> SPPFNode -> SPPF -> SPPF +eMapInsert f t (sMap,iMap,pMap,eMap,idMap) = + (sMap,iMap,pMap,M.insertWith (S.union) f (S.singleton t) eMap,idMap) + +idMapInsert :: SPPFNode -> SPPFNode -> SPPF -> (SPPF, Int, Int) +idMapInsert f t (sMap,iMap,pMap,eMap,(idfMap,idtMap)) = + ((sMap,iMap,pMap,eMap,(idfMap'',idtMap'')),fkey,tkey) + where idx | IM.null idfMap = 0 + | otherwise = fst (IM.findMax idfMap) + (fkey,idfMap',idtMap') = newKey f (idx+1) idfMap idtMap + (tkey,idfMap'',idtMap'') = newKey t (idx+2) idfMap' idtMap' + newKey :: SPPFNode -> Int -> IDFMap -> IDTMap -> (Int,IDFMap,IDTMap) + newKey n i mf mt = case M.lookup n mt of + Nothing -> (i,IM.insert i n mf,M.insert n i mt) + Just j -> (j,mf,mt) -- helpers for Ucal inU (slot,l,i) u = maybe False inner $ IM.lookup l u where inner = maybe False (S.member slot) . IM.lookup i @@ -205,8 +256,9 @@ `S.union` (if x == s then S.singleton EOS else S.empty) where fw (y,ss) = let ts = S.delete Epsilon (first_alpha [] ss) + fs = follow (x:ys) y in if nullable_alpha [] ss && not (x `elem` (y:ys)) - then ts `S.union` follow (y:ys) y + then ts `S.union` fs else ts @@ -253,7 +305,6 @@ deriving instance Show Alt deriving instance Ord Alt deriving instance Eq Alt -deriving instance Show Symbol deriving instance Eq Symbol deriving instance Ord Symbol @@ -310,14 +361,13 @@ Token k _ `compare` Token k2 _ = k `compare` k2 instance Show Token where - show (Char c) = "Char(" ++ show [c] ++ ")" + show (Char c) = ['\'',c,'\''] show (EOS) = "$" show Epsilon = "#" - show (Int mi) = "Int(" ++ maybe "_" show mi ++ ")" - show (Bool mb)= "Bool(" ++ maybe "_" show mb ++ ")" - show (String ms) = "String("++ maybe "_" show ms ++ ")" - show (Token t ms) = t ++ "(" ++ maybe "_" show ms ++ ")" - + show (Int mi) = "int" + show (Bool mb)= "bool" + show (String ms) = "string" + show (Token t ms) = t instance Show Slot where show (Slot x alpha beta) = x ++ " ::= " ++ showRhs alpha ++ "." ++ showRhs beta @@ -325,3 +375,7 @@ showRhs ((Term t):rhs) = show t ++ showRhs rhs showRhs ((Nt x):rhs) = x ++ showRhs rhs +instance Show Symbol where + show (Nt s) = s + show (Term t) = show t + show (Error e _) = error ("show Error symbol") diff --git a/tests/interface/MemTests.hs b/tests/interface/MemTests.hs new file mode 100644 --- /dev/null +++ b/tests/interface/MemTests.hs @@ -0,0 +1,188 @@ + +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 new file mode 100644 --- /dev/null +++ b/tests/interface/UnitTests.hs @@ -0,0 +1,180 @@ + +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"]