Earley 0.8.0 → 0.8.1
raw patch · 10 files changed
+684/−26 lines, 10 filesdep +Earleydep +criteriondep +deepseqdep ~ListLikedep ~basedep ~containersnew-component:exe:earley-englishnew-component:exe:earley-exprnew-component:exe:earley-expr2new-component:exe:earley-mixfixnew-component:exe:earley-very-ambiguousnew-component:exe:earley-wordsPVP ok
version bump matches the API change (PVP)
Dependencies added: Earley, criterion, deepseq, parsec, tasty, tasty-hunit, tasty-quickcheck, unordered-containers
Dependency ranges changed: ListLike, base, containers
API changes (from Hackage documentation)
+ Text.Earley.Parser: instance (Eq e, Eq i) => Eq (Report e i)
+ Text.Earley.Parser: instance (Ord e, Ord i) => Ord (Report e i)
+ Text.Earley.Parser: instance (Read e, Read i) => Read (Report e i)
Files
- Earley.cabal +79/−1
- Text/Earley/Parser.hs +27/−25
- bench/BenchAll.hs +141/−0
- examples/English.hs +45/−0
- examples/Expr.hs +31/−0
- examples/Expr2.hs +45/−0
- examples/Mixfix.hs +86/−0
- examples/VeryAmbiguous.hs +17/−0
- examples/Words.hs +26/−0
- tests/Tests.hs +187/−0
Earley.cabal view
@@ -1,5 +1,5 @@ name: Earley-version: 0.8.0+version: 0.8.1 synopsis: Parsing all context-free grammars using Earley's algorithm. description: See <https://www.github.com/ollef/Earley> for more information and@@ -14,6 +14,10 @@ build-type: Simple cabal-version: >=1.10 +Flag Examples+ Description: "Build examples"+ Default: False+ source-repository head type: git location: https://github.com/ollef/Earley.git@@ -25,3 +29,77 @@ -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -funbox-strict-fields++executable earley-english+ if !flag(examples)+ buildable: False+ main-is: English.hs+ ghc-options: -Wall+ hs-source-dirs: examples+ default-language: Haskell2010+ build-depends: base, Earley, unordered-containers >=0.2++executable earley-expr+ if !flag(examples)+ buildable: False+ main-is: Expr.hs+ ghc-options: -Wall+ hs-source-dirs: examples+ default-language: Haskell2010+ build-depends: base, Earley++executable earley-expr2+ if !flag(examples)+ buildable: False+ main-is: Expr2.hs+ ghc-options: -Wall+ hs-source-dirs: examples+ default-language: Haskell2010+ build-depends: base, Earley++executable earley-mixfix+ if !flag(examples)+ buildable: False+ main-is: Mixfix.hs+ ghc-options: -Wall+ hs-source-dirs: examples+ default-language: Haskell2010+ build-depends: base, Earley, containers++executable earley-very-ambiguous+ if !flag(examples)+ buildable: False+ main-is: VeryAmbiguous.hs+ ghc-options: -Wall+ hs-source-dirs: examples+ default-language: Haskell2010+ build-depends: base, Earley++executable earley-words+ if !flag(examples)+ buildable: False+ main-is: Words.hs+ ghc-options: -Wall+ hs-source-dirs: examples+ default-language: Haskell2010+ build-depends: base, Earley++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs: . bench+ main-is: BenchAll.hs+ build-depends: base, deepseq, criterion >=1.1, parsec >=3.1, ListLike+ default-language: Haskell2010+ ghc-options: -Wall+ -O2+ -fmax-simplifier-iterations=10+ -fdicts-cheap+ -fspec-constr-count=6++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ ghc-options: -Wall+ hs-source-dirs: tests+ default-language: Haskell2010+ build-depends: base, Earley, tasty >=0.10, tasty-quickcheck >=0.8, tasty-hunit >= 0.9
Text/Earley/Parser.hs view
@@ -12,10 +12,10 @@ import Control.Arrow import Control.Monad import Control.Monad.Fix-import Control.Monad.ST.Lazy+import Control.Monad.ST import Data.ListLike(ListLike) import qualified Data.ListLike as ListLike-import Data.STRef.Lazy+import Data.STRef import Text.Earley.Grammar #if !MIN_VERSION_base(4,8,0) import Data.Monoid@@ -169,7 +169,7 @@ -- position. , unconsumed :: i -- ^ The part of the input string that was not consumed, -- which may be empty.- } deriving Show+ } deriving (Eq, Ord, Read, Show) -- | The result of a parse. data Result s e i a@@ -184,17 +184,17 @@ -- continuation. deriving Functor -{-# INLINE uncons #-}-uncons :: ListLike i t => i -> Maybe (t, i)-uncons i- | ListLike.null i = Nothing- | otherwise = Just (ListLike.head i, ListLike.tail i)+{-# INLINE safeHead #-}+safeHead :: ListLike i t => i -> Maybe t+safeHead ts+ | ListLike.null ts = Nothing+ | otherwise = Just $ ListLike.head ts {-# INLINE safeTail #-} safeTail :: ListLike i t => i -> i-safeTail ts'- | ListLike.null ts' = ts'- | otherwise = ListLike.tail ts'+safeTail ts+ | ListLike.null ts = ts+ | otherwise = ListLike.tail ts {-# SPECIALISE parse :: [State s a e t a] -> [ST s [a]]@@ -214,23 +214,23 @@ -> Pos -- ^ The current position in the input string -> i -- ^ The input string -> ST s (Result s e i a)-parse [] [] [] !reset names !pos !ts = do+parse [] [] [] reset names !pos ts = do reset return $ Ended Report {position = pos, expected = names, unconsumed = ts}-parse [] [] !next !reset _ !pos !ts = do+parse [] [] next reset _ !pos ts = do reset parse next [] [] (return ()) [] (pos + 1) $ safeTail ts-parse [] !results !next !reset names !pos !ts = do+parse [] results next reset names !pos ts = do reset return $ Parsed (concat <$> sequence results) pos ts $ parse [] [] next (return ()) names pos ts-parse (st:ss) !results !next !reset names !pos !ts = case st of+parse (st:ss) results next reset names !pos ts = case st of Final f args -> parse ss (args f : results) next reset names pos ts State spos pr args scont -> case pr of- Terminal f p -> case uncons ts of- Just (t, _) | f t ->+ Terminal f p -> case safeHead ts of+ Just t | f t -> parse ss results (State spos p (pureArg t args) scont : next) reset names pos ts- _ -> parse ss results next reset names pos ts+ _ -> parse ss results next reset names pos ts NonTerminal r p -> do rkref <- readSTRef $ ruleConts r ks <- readSTRef rkref@@ -270,17 +270,19 @@ | otherwise -> parse ss results next reset names pos ts Alts as (Pure f) -> do let args' = funArg f `composeArgs` args- sts = [State pos a args' scont | a <- as]+ sts = [State spos a args' scont | a <- as] parse (sts ++ ss) results next reset names pos ts Alts as p -> do scont' <- newConts =<< newSTRef [Cont spos noArgs p args scont]- let sts = [State pos a noArgs scont' | a <- as]+ -- State is (-1) so that nullable alts are expanded correctly+ let sts = [State (-1) a noArgs scont' | a <- as] parse (sts ++ ss) results next reset names pos ts Many p q -> do- scont' <- newConts =<< newSTRef [Cont spos noArgs (Many p ((\f as a -> f (a : as)) <$> q)) args scont]- let st' = State pos p noArgs scont'- nst = State spos q (pureArg [] args) scont- parse (st' : nst : ss) results next reset names pos ts+ c <- newSTRef =<< newSTRef mempty+ nr <- newSTRef Nothing+ let r = Rule (pure [] <|> (:) <$> p <*> NonTerminal r (Pure id)) nr c+ st' = State spos (NonTerminal r q) args scont+ parse (st' : ss) results next reset names pos ts Named pr' n -> parse (State spos pr' args scont : ss) results next reset (n : names) pos ts {-# INLINE parser #-}@@ -301,7 +303,7 @@ where go :: Result s e i a -> ST s ([(a, Int)], Report e i) go r = case r of- Ended rep -> return ([], rep)+ Ended rep -> return ([], rep) Parsed mas pos _ k -> do as <- mas fmap (first (zip as (repeat pos) ++)) $ go =<< k
+ bench/BenchAll.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE RecursiveDo, FlexibleContexts #-}+module Main where++import Control.Applicative+import Control.Exception+import Control.DeepSeq+import Criterion.Main+import Data.Char+import Data.Maybe+import Text.Earley+import qualified Text.Parsec as Parsec+import qualified Text.Parsec.Pos as Parsec++data Expr+ = Add Expr Expr+ | Mul Expr Expr+ | Var String+ deriving (Eq, Ord, Show)++instance NFData Expr where+ rnf (Add a b) = rnf a `seq` rnf b+ rnf (Mul a b) = rnf a `seq` rnf b+ rnf (Var s) = rnf s++type Token = String++tokenParens :: Bool -> [Token] -> [Token]+tokenParens True s = ["("] ++ s ++ [")"]+tokenParens False s = s++tokenExpr :: Int -> Expr -> [Token]+tokenExpr _ (Var s) = [s]+tokenExpr d (Add a b) = tokenParens (d > 0) $ tokenExpr 0 a ++ ["+"] ++ tokenExpr 1 b+tokenExpr d (Mul a b) = tokenParens (d > 1) $ tokenExpr 1 a ++ ["*"] ++ tokenExpr 2 b++linearSum :: Int -> Expr+linearSum 1 = Var "x"+linearSum n = Add (linearSum $ n - 1) (Var "x")++treeSum :: Int -> Expr+treeSum 1 = Var "x"+treeSum n = let a = n `div` 2 -- will be at least 1+ b = n - a+ in Add (treeSum a) (treeSum b)++-- Earley parser++expr :: Grammar r String (Prod r String Token Expr)+expr = mdo+ x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2+ <|> x2+ <?> "sum"+ x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x3+ <|> x3+ <?> "product"+ x3 <- rule $ Var <$> (satisfy isIdent <?> "identifier")+ <|> namedSymbol "(" *> x1 <* namedSymbol ")"+ return x1++isIdent :: String -> Bool+isIdent (x:_) = isAlpha x+isIdent _ = False++sepBy1 :: Prod r e t a -> Prod r e t op -> Grammar r e (Prod r e t [a])+sepBy1 p op = mdo+ ops <- rule $ pure [] <|> (:) <$ op <*> p <*> ops+ rule $ (:) <$> p <*> ops++expr' :: Grammar r String (Prod r String Token Expr)+expr' = mdo+ let var = Var <$> satisfy isIdent <|> symbol "(" *> mul <* symbol ")"+ mul <- fmap (foldl1 Mul) <$> add `sepBy1` symbol "*"+ add <- fmap (foldl1 Add) <$> var `sepBy1` symbol "+"+ return mul++parseEarley :: [Token] -> Maybe Expr+parseEarley input = listToMaybe (fst (fullParses (parser expr input)))++parseEarley' :: [Token] -> Maybe Expr+parseEarley' input = listToMaybe (fst (fullParses (parser expr' input)))++-- Parsec parsec++type Parsec = Parsec.Parsec [Token] ()++parsecExpr :: Parsec Expr+parsecExpr = mul+ where mul = foldl1 Mul <$> add `Parsec.sepBy1` t "*"+ add = foldl1 Add <$> var `Parsec.sepBy1` t "+"+ ident = Parsec.token id pos $ \y -> if isIdent y then Just (Var y) else Nothing+ var = ident <|> (t "(" *> mul <* t ")")+ t x = Parsec.token id pos $ \y -> if x == y then Just x else Nothing+ pos = const (Parsec.initialPos "")++parseParsec :: [Token] -> Maybe Expr+parseParsec = either (const Nothing) Just . Parsec.parse parsecExpr ""++-- Our benchmark harness.++linearInput :: Int -> (String, [Token])+linearInput size = (show size, tokenExpr 0 $ linearSum size)++treeInput :: Int -> (String, [Token])+treeInput size = (show size, tokenExpr 0 $ treeSum size)++inputBench :: (String, [Token]) -> Benchmark+inputBench (name, input) = bench name $ nf id input++earleyBench :: (String, [Token]) -> Benchmark+earleyBench (name, input) = bench name $ nf parseEarley input++earley'Bench :: (String, [Token]) -> Benchmark+earley'Bench (name, input) = bench name $ nf parseEarley' input++parsecBench :: (String, [Token]) -> Benchmark+parsecBench (name, input) = bench name $ nf parseParsec input++benchSizes :: [Int]+benchSizes = [100, 200] -- [51, 101, 151, 201]++linearInputs :: [(String, [Token])]+linearInputs = map linearInput benchSizes++treeInputs :: [(String, [Token])]+treeInputs = map treeInput benchSizes++main :: IO ()+main = do+ evaluate (rnf linearInputs)+ evaluate (rnf treeInputs)+ defaultMain+ [ -- bgroup "inputs" $ map inputBench linearInputs + bgroup "earley" $ map earleyBench linearInputs+ , bgroup "earley'" $ map earley'Bench linearInputs+ , bgroup "parsec" $ map parsecBench linearInputs+ -- , bgroup "inputsTree" $ map inputBench treeInputs+ , bgroup "earleyTree" $ map earleyBench treeInputs+ , bgroup "earley'Tree" $ map earley'Bench treeInputs+ , bgroup "parsecTree" $ map parsecBench treeInputs+ ]+
+ examples/English.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RecursiveDo #-}+import Control.Applicative+import Text.Earley+import qualified Data.HashSet as HS++type Noun = String+type Verb = String+type Adjective = String++nouns, verbs, adjectives :: HS.HashSet String+nouns = HS.fromList ["parsers", "sentences", "grammars"]+verbs = HS.fromList ["parse", "munch", "annihilate", "confuse", "use"]+adjectives = HS.fromList ["many", "great", "long", "confusing"]+++data Sentence = Sentence NounPhrase VerbPhrase+ deriving Show+data NounPhrase = NounPhrase Adjective NounPhrase+ | Noun Noun+ deriving Show+data VerbPhrase = VerbPhrase Verb NounPhrase+ | Verb Verb+ deriving Show++sentence :: Grammar r String (Prod r String String Sentence)+sentence = mdo+ noun <- rule $ satisfy (`HS.member` nouns) <?> "noun"+ verb <- rule $ satisfy (`HS.member` verbs) <?> "verb"+ adjective <- rule $ satisfy (`HS.member` adjectives) <?> "adjective"+ nounPhrase <- rule $ NounPhrase <$> adjective <*> nounPhrase+ <|> Noun <$> noun+ <?> "noun phrase"+ verbPhrase <- rule $ VerbPhrase <$> verb <*> nounPhrase+ <|> Verb <$> verb+ <?> "verb phrase"+ return $ Sentence <$> nounPhrase <*> verbPhrase <?> "sentence"++main :: IO ()+main = do+ let p = parser sentence . words+ print $ fullParses $ p "parsers use grammars"+ print $ fullParses $ p "parsers munch long sentences"+ print $ fullParses $ p "many great sentences confuse parsers"+ print $ fullParses $ p "parsers use use"+ print $ fullParses $ p "grammars many great confusing"
+ examples/Expr.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE RecursiveDo #-}+import Control.Applicative+import Data.Char+import System.Environment+import Text.Earley++data Expr+ = Add Expr Expr+ | Mul Expr Expr+ | Var String+ deriving (Eq, Ord, Show)++expr :: Grammar r String (Prod r String String Expr)+expr = mdo+ x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2+ <|> x2+ <?> "sum"+ x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x3+ <|> x3+ <?> "product"+ x3 <- rule $ Var <$> (satisfy ident <?> "identifier")+ <|> namedSymbol "(" *> x1 <* namedSymbol ")"+ return x1+ where+ ident (x:_) = isAlpha x+ ident _ = False++main :: IO ()+main = do+ x:_ <- getArgs+ print $ fullParses $ parser expr $ words x
+ examples/Expr2.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE ScopedTypeVariables, RecursiveDo #-}+import Data.Char+import System.Environment+import Control.Applicative+import Text.Earley++data Expr+ = Expr :+: Expr+ | Expr :*: Expr+ | Var String+ | Lit Int+ deriving (Show)++grammar :: forall r. Grammar r String (Prod r String Char Expr)+grammar = mdo++ whitespace <- rule $ many $ satisfy isSpace++ let token :: Prod r String Char a -> Prod r String Char a+ token p = whitespace *> p++ sym x = token $ symbol x <?> [x]++ ident = token $ (:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum) <?> "identifier"+ num = token $ some (satisfy isDigit) <?> "number"++ expr0 <- rule+ $ (Lit . read) <$> num+ <|> Var <$> ident+ <|> sym '(' *> expr2 <* sym ')'++ expr1 <- rule+ $ (:*:) <$> expr1 <* sym '*' <*> expr0+ <|> expr0++ expr2 <- rule+ $ (:+:) <$> expr2 <* sym '+' <*> expr1+ <|> expr1++ return $ expr2 <* whitespace++main :: IO ()+main = do+ x:_ <- getArgs+ print $ fullParses $ parser grammar x
+ examples/Mixfix.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE RecursiveDo #-}+import Control.Applicative+import Control.Arrow(first)+import Data.Foldable(asum, foldrM)+import System.Environment+import Text.Earley+import qualified Data.Set as S++type Ident = String++data IdentPart = Ident Ident | Hole+ deriving Show++type HoleyIdent = [IdentPart]++holey :: Ident -> HoleyIdent+holey "" = []+holey ('_':xs) = Hole : holey xs+holey xs = Ident i : holey rest+ where (i, rest) = span (/= '_') xs ++data Assoc = LeftAssoc | RightAssoc | NonAssoc+ deriving (Eq, Show)++data Expr = V HoleyIdent | App Expr [Expr]+ deriving Show++grammar :: [[(HoleyIdent, Assoc)]] -> Grammar r String (Prod r String String Expr)+grammar table = mdo+ let ident = (V . (:[]) . Ident) <$> satisfy (`S.notMember` mixfixParts)+ expr <- foldrM ($) ident (normalApp expr : levels expr)+ return expr+ where+ mixfixParts = S.fromList [s | xs <- table, (ys, _) <- xs, Ident s <- ys]+ normalApp expr next = rule $ App <$> expr <*> some next+ <|> next+ levels expr = map (level expr) table+ level expr idents next = mdo+ same <- rule $ asum $ next : map (mixfixIdent same) idents+ return same+ where+ mixfixIdent same (ps, a) = App (V ps) <$> go ps+ where+ go ps' = case ps' of+ [Ident s] -> [] <$ namedSymbol s+ Hole:rest -> (:) <$> (if a == RightAssoc then next else same) <*> go rest+ [Ident s, Hole] -> (:[]) <$ namedSymbol s <*> (if a == LeftAssoc then next else same)+ Ident s:Hole:rest -> (:) <$ namedSymbol s <*> expr <*> go rest+ _ -> error "invalid identifier"++identTable :: [[(HoleyIdent, Assoc)]]+identTable = (map . map) (first holey)+ [ [("_->_", RightAssoc)]+ , [("_,_", NonAssoc)]+ , [("if_then_else_", RightAssoc)]+ , [("_|-_:_", NonAssoc)]+ , [("_+_", LeftAssoc)]+ , [("_*_", LeftAssoc)]+ , [("(_)", NonAssoc)+ ,("[_]", NonAssoc)+ ,("<_>", NonAssoc)+ ]+ ]++pretty :: Expr -> String+pretty (V ps) = concatMap go ps+ where+ go Hole = "_"+ go (Ident s) = s+pretty (App e es) = "(" ++ pretty e ++ " " ++ unwords (map pretty es) ++ ")"++tokenize :: String -> [Ident]+tokenize "" = []+tokenize (' ':xs) = tokenize xs+tokenize ('\n':xs) = tokenize xs+tokenize (x:xs)+ | x `S.member` special = [x] : tokenize xs+ | otherwise = (x:as) : tokenize bs+ where+ (as, bs) = span (`S.notMember` special) xs+ special = S.fromList "()[], \n"++main :: IO ()+main = do+ x:_ <- getArgs+ print $ first (map pretty) $ fullParses $ parser (grammar identTable) (tokenize x)
+ examples/VeryAmbiguous.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE RecursiveDo #-}+import Control.Applicative+import System.Environment+import Text.Earley++g :: Grammar r Char (Prod r Char Char ())+g = mdo+ s <- rule $ () <$ symbol 'b'+ <|> () <$ s <* s+ <|> () <$ s <* s <* s+ <?> 's'+ return s++main :: IO ()+main = do+ xs:_ <- getArgs+ print $ report $ parser g xs
+ examples/Words.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE RecursiveDo #-}+import Data.Char+import Control.Applicative+import System.Environment++import Text.Earley++grammar :: Grammar r String (Prod r String Char [String])+grammar = mdo+ whitespace <- rule $ () <$ many (satisfy isSpace)+ whitespace1 <- rule $ () <$ satisfy isSpace <* whitespace <?> "whitespace"++ ident <- rule + $ (:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum)+ <?> "identifier"++ expr <- rule+ $ (:) <$> ident <* whitespace1 <*> expr+ <|> (:[]) <$> ident <* whitespace++ return expr++main :: IO ()+main = do+ x:_ <- getArgs+ print $ fullParses $ parser grammar x
+ tests/Tests.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}+import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit as HU++import Data.Char+import Control.Applicative+import Text.Earley++main :: IO ()+main = defaultMain tests -- -putStrLn . prettyExpr 0 $ Add (Add (Var "a") (Var "b")) (Add (Var "c") (Var "d")) -- defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [qcProps, unitTests]++qcProps :: TestTree+qcProps = testGroup "QuickCheck Properties"+ [ QC.testProperty "Expr: parse . pretty = id" $+ \e -> [e] === parseExpr (prettyExpr 0 e)+ , QC.testProperty "Ambiguous Expr: parse . pretty ≈ id" $+ \e -> e `elem` parseAmbiguousExpr (prettyExpr 0 e)+ , QC.testProperty "The empty parser doesn't parse anything" $+ \(input :: String) ->+ allParses (parser (return empty :: forall r. Grammar r () (Prod r () Char ())) input)+ == (,) [] Report { position = 0+ , expected = []+ , unconsumed = input+ }+ , QC.testProperty "Many empty parsers parse very little" $+ \(input :: String) ->+ allParses (parser (return $ many empty <* pure "blah" :: forall r. Grammar r () (Prod r () Char [()])) input)+ == (,) [([], 0)] Report { position = 0+ , expected = []+ , unconsumed = input+ }+ ]++unitTests :: TestTree+unitTests = testGroup "Unit Tests"+ [ HU.testCase "VeryAmbiguous gives the right number of results" $+ length (fst $ fullParses $ parser veryAmbiguous $ replicate 8 'b') @?= 2871+ , HU.testCase "VeryAmbiguous gives the correct report" $+ report (parser veryAmbiguous $ replicate 3 'b') @?=+ Report {position = 3, expected = "s", unconsumed = ""}+ , HU.testCase "Inline alternatives work" $+ let input = "ababbbaaabaa" in+ allParses (parser inlineAlts input) @?= allParses (parser nonInlineAlts input)+ , HU.testCase "Some reversed words" $+ let input = "wordwordstop"+ l = length input in+ allParses (parser someWords input)+ @?= (,) [(["stop", "drow", "drow"], l)] Report { position = l+ , expected = []+ , unconsumed = []+ }+ , HU.testCase "Optional Nothing" $+ fullParses (parser (return optional_) "b")+ @?= (,) [(Nothing, 'b')] Report {position = 1, expected = "", unconsumed = ""}+ , HU.testCase "Optional Just" $+ fullParses (parser (return optional_) "ab")+ @?= (,) [(Just 'a', 'b')] Report {position = 2, expected = "", unconsumed = ""}+ , HU.testCase "Optional using rules Nothing" $+ fullParses (parser optionalRule "b")+ @?= (,) [(Nothing, 'b')] Report {position = 1, expected = "", unconsumed = ""}+ , HU.testCase "Optional using rules Just" $+ fullParses (parser optionalRule "ab")+ @?= (,) [(Just 'a', 'b')] Report {position = 2, expected = "", unconsumed = ""}+ , HU.testCase "Optional without continuation Nothing" $+ fullParses (parser (return $ optional $ namedSymbol 'a') "")+ @?= (,) [Nothing] Report {position = 0, expected = "a", unconsumed = ""}+ , HU.testCase "Optional without continuation Just" $+ fullParses (parser (return $ optional $ namedSymbol 'a') "a")+ @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}+ , HU.testCase "Optional using rules without continuation Nothing" $+ fullParses (parser (rule $ optional $ namedSymbol 'a') "")+ @?= (,) [Nothing] Report {position = 0, expected = "a", unconsumed = ""}+ , HU.testCase "Optional using rules without continuation Just" $+ fullParses (parser (rule $ optional $ namedSymbol 'a') "a")+ @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}+ ]++optional_ :: Prod r Char Char (Maybe Char, Char)+optional_ = (,) <$> optional (namedSymbol 'a') <*> namedSymbol 'b'++optionalRule :: Grammar r Char (Prod r Char Char (Maybe Char, Char))+optionalRule = mdo+ test <- rule $ (,) <$> optional (namedSymbol 'a') <*> namedSymbol 'b'+ return test++inlineAlts :: Grammar r Char (Prod r Char Char String)+inlineAlts = mdo+ p <- rule $ pure []+ <|> (:) <$> (namedSymbol 'a' <|> namedSymbol 'b') <*> p+ return p++nonInlineAlts :: Grammar r Char (Prod r Char Char String)+nonInlineAlts = mdo+ ab <- rule $ namedSymbol 'a' <|> namedSymbol 'b'+ p <- rule $ pure [] <|> (:) <$> ab <*> p+ return p++someWords :: Grammar r () (Prod r () Char [String])+someWords = return $ flip (:) <$> (map reverse <$> some (word "word")) <*> word "stop"++veryAmbiguous :: Grammar r Char (Prod r Char Char ())+veryAmbiguous = mdo+ s <- rule $ () <$ symbol 'b'+ <|> () <$ s <* s+ <|> () <$ s <* s <* s+ <?> 's'+ return s++parseExpr :: String -> [Expr]+parseExpr input = fst (fullParses (parser expr (lexExpr input))) -- We need to annotate types for point-free version++parseAmbiguousExpr :: String -> [Expr]+parseAmbiguousExpr input = fst (fullParses (parser ambiguousExpr (lexExpr input)))++data Expr+ = Add Expr Expr+ | Mul Expr Expr+ | Var String+ deriving (Eq, Ord, Show)++instance Arbitrary Expr where+ arbitrary = sized arbExpr+ where arbIdent = Var <$> elements ["a", "b", "c", "x", "y", "z"]+ arbExpr n | n > 0 = oneof [ arbIdent+ , Add <$> arbExpr1 <*> arbExpr1+ , Mul <$> arbExpr1 <*> arbExpr1+ ]+ where arbExpr1 = arbExpr (n `div` 2)+ arbExpr _ = arbIdent++ shrink (Var _) = []+ shrink (Add a b) = a : b : [ Add a' b | a' <- shrink a ] ++ [ Add a b' | b' <- shrink b ]+ shrink (Mul a b) = a : b : [ Mul a' b | a' <- shrink a ] ++ [ Mul a b' | b' <- shrink b ]++expr :: Grammar r String (Prod r String String Expr)+expr = mdo+ x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2+ <|> x2+ <?> "sum"+ x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x3+ <|> x3+ <?> "product"+ x3 <- rule $ Var <$> (satisfy ident <?> "identifier")+ <|> namedSymbol "(" *> x1 <* namedSymbol ")"+ return x1+ where+ ident (x:_) = isAlpha x+ ident _ = False++ambiguousExpr :: Grammar r String (Prod r String String Expr)+ambiguousExpr = mdo+ x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x1+ <|> x2+ <?> "sum"+ x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x2+ <|> x3+ <?> "product"+ x3 <- rule $ Var <$> (satisfy ident <?> "identifier")+ <|> namedSymbol "(" *> x1 <* namedSymbol ")"+ return x1+ where+ ident (x:_) = isAlpha x+ ident _ = False++prettyParens :: Bool -> String -> String+prettyParens True s = "(" ++ s ++ ")"+prettyParens False s = s++prettyExpr :: Int -> Expr -> String+prettyExpr _ (Var s) = s+prettyExpr d (Add a b) = prettyParens (d > 0) $ prettyExpr 0 a ++ " + " ++ prettyExpr 1 b+prettyExpr d (Mul a b) = prettyParens (d > 1) $ prettyExpr 1 a ++ " * " ++ prettyExpr 2 b++-- @words@ like lexer, but consider parentheses as separate tokens+lexExpr :: String -> [String]+lexExpr "" = []+lexExpr ('(' : s) = "(" : lexExpr s+lexExpr (')' : s) = ")" : lexExpr s+lexExpr (c : s)+ | isSpace c = lexExpr s+ | otherwise = let (tok, rest) = span p (c : s)+ in tok : lexExpr rest+ where p x = not (x == '(' || x == ')' || isSpace x)