packages feed

gll 0.1.0.1 → 0.2.0.0

raw patch · 11 files changed

+1356/−560 lines, 11 filesdep +TypeComposesetup-changed

Dependencies added: TypeCompose

Files

Setup.hs view
@@ -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)
gll.cabal view
@@ -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
− src/GLL/Combinators/Combinators.hs 
@@ -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 ,\_ _ _ _ _ -> [()])
+ src/GLL/Combinators/Interface.hs view
@@ -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))+
+ src/GLL/Combinators/MemInterface.hs view
@@ -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))+
+ src/GLL/Combinators/Options.hs view
@@ -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 }++
− src/GLL/Machines/RGLL.lhs 
@@ -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
+ src/GLL/Parser.hs view
@@ -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)+        ]++
src/GLL/Types/Grammar.hs view
@@ -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")
+ tests/interface/MemTests.hs view
@@ -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"]
+ tests/interface/UnitTests.hs view
@@ -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"]