Earley 0.11.0.0 → 0.11.0.1
raw patch · 12 files changed
+429/−5 lines, 12 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- Earley.cabal +16/−2
- README.md +3/−3
- tests/Empty.hs +25/−0
- tests/Expr.hs +92/−0
- tests/InlineAlts.hs +26/−0
- tests/Issue11.hs +73/−0
- tests/Issue14.hs +49/−0
- tests/Mixfix.hs +53/−0
- tests/Optional.hs +43/−0
- tests/ReversedWords.hs +21/−0
- tests/VeryAmbiguous.hs +24/−0
CHANGELOG.md view
@@ -1,3 +1,7 @@+# 0.11.0.1++- Add missing modules to Cabal file+ # 0.11.0.0 - Add `IsString Prod` instance
Earley.cabal view
@@ -1,5 +1,5 @@ name: Earley-version: 0.11.0.0+version: 0.11.0.1 synopsis: Parsing all context-free grammars using Earley's algorithm. description: See <https://www.github.com/ollef/Earley> for more information and@@ -9,7 +9,7 @@ license-file: LICENSE author: Olle Fredriksson maintainer: fredriksson.olle@gmail.com-copyright: (c) 2014-2015 Olle Fredriksson+copyright: (c) 2014-2016 Olle Fredriksson category: Parsing build-type: Simple cabal-version: >=1.10@@ -111,6 +111,11 @@ build-depends: base, deepseq, criterion >=1.1, parsec >=3.1, ListLike default-language: Haskell2010 ghc-options: -Wall+ other-modules: Text.Earley,+ Text.Earley.Derived,+ Text.Earley.Grammar,+ Text.Earley.Internal,+ Text.Earley.Parser test-suite tests type: exitcode-stdio-1.0@@ -119,3 +124,12 @@ hs-source-dirs: tests default-language: Haskell2010 build-depends: base, Earley, tasty >=0.10, tasty-quickcheck >=0.8, tasty-hunit >= 0.9+ other-modules: Empty,+ Expr,+ InlineAlts,+ Issue11,+ Issue14,+ Mixfix,+ Optional,+ ReversedWords,+ VeryAmbiguous
README.md view
@@ -15,14 +15,14 @@ ```haskell expr :: Grammar r (Prod r String String Expr) expr = mdo- x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2+ x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x2 <|> x2 <?> "sum"- x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x3+ x2 <- rule $ Mul <$> x2 <* namedToken "*" <*> x3 <|> x3 <?> "product" x3 <- rule $ Var <$> (satisfy ident <?> "identifier")- <|> namedSymbol "(" *> x1 <* namedSymbol ")"+ <|> namedToken "(" *> x1 <* namedToken ")" return x1 where ident (x:_) = isAlpha x
+ tests/Empty.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Empty where+import Control.Applicative+import Test.Tasty+import Test.Tasty.QuickCheck as QC++import Text.Earley++tests :: TestTree+tests = testGroup "Empty productions"+ [ QC.testProperty "The empty production 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 productions 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+ }+ ]
+ tests/Expr.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE RecursiveDo #-}+module Expr where+import Control.Applicative+import Data.Char+import Test.Tasty+import Test.Tasty.QuickCheck as QC++import Text.Earley++tests :: TestTree+tests = testGroup "Expr"+ [ 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)+ ]++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 (Prod r String String Expr)+expr = mdo+ x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x2+ <|> x2+ <?> "sum"+ x2 <- rule $ Mul <$> x2 <* namedToken "*" <*> x3+ <|> x3+ <?> "product"+ x3 <- rule $ Var <$> (satisfy ident <?> "identifier")+ <|> namedToken "(" *> x1 <* namedToken ")"+ return x1+ where+ ident (x:_) = isAlpha x+ ident _ = False++ambiguousExpr :: Grammar r (Prod r String String Expr)+ambiguousExpr = mdo+ x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x1+ <|> x2+ <?> "sum"+ x2 <- rule $ Mul <$> x2 <* namedToken "*" <*> x2+ <|> x3+ <?> "product"+ x3 <- rule $ Var <$> (satisfy ident <?> "identifier")+ <|> namedToken "(" *> x1 <* namedToken ")"+ 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)
+ tests/InlineAlts.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}+module InlineAlts where+import Control.Applicative+import Test.Tasty+import Test.Tasty.HUnit as HU++import Text.Earley++tests :: TestTree+tests = testGroup "Inline alternatives"+ [ HU.testCase "They work" $+ let input = "ababbbaaabaa" in+ allParses (parser inlineAlts) input @?= allParses (parser nonInlineAlts) input+ ]++inlineAlts :: Grammar r (Prod r Char Char String)+inlineAlts = mdo+ p <- rule $ pure []+ <|> (:) <$> (namedToken 'a' <|> namedToken 'b') <*> p+ return p++nonInlineAlts :: Grammar r (Prod r Char Char String)+nonInlineAlts = mdo+ ab <- rule $ namedToken 'a' <|> namedToken 'b'+ p <- rule $ pure [] <|> (:) <$> ab <*> p+ return p
+ tests/Issue11.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE RecursiveDo #-}+module Issue11 where+import Control.Applicative+import Test.Tasty+import Test.Tasty.HUnit as HU++import Text.Earley+import Text.Earley.Mixfix++tests :: TestTree+tests = testGroup "Issue 11"+ [ let x = words "+ + 5 6 7" in+ HU.testCase "1" $+ fullParses (parser $ grammar LeftAssoc) x+ @?= (,) [] Report {position = 1, expected = [], unconsumed = drop 1 x}+ , let x = words "+ 5 + 6 7" in+ HU.testCase "2" $+ fullParses (parser $ grammar LeftAssoc) x+ @?= (,) [] Report {position = 2, expected = [], unconsumed = drop 2 x}+ , let x = words "+ 5 6" in+ HU.testCase "3" $+ fullParses (parser $ grammar LeftAssoc) x+ @?= (,) [Plus (Var "5") (Var "6")]+ Report {position = 3, expected = [], unconsumed = []}+ , let x = words "+ + 5 6 7" in+ HU.testCase "4" $+ fullParses (parser $ grammar RightAssoc) x+ @?= (,) [Plus (Plus (Var "5") (Var "6")) (Var "7")]+ Report {position = 5, expected = [], unconsumed = []}+ , let x = words "+ 5 + 6 7" in+ HU.testCase "5" $+ fullParses (parser $ grammar RightAssoc) x+ @?= (,) [Plus (Var "5") (Plus (Var "6") (Var "7"))]+ Report {position = 5, expected = [], unconsumed = []}+ , let x = words "+ 5 6" in+ HU.testCase "6" $+ fullParses (parser $ grammar RightAssoc) x+ @?= (,) [Plus (Var "5") (Var "6")]+ Report {position = 3, expected = [], unconsumed = []}+ , let x = words "+ + 5 6 7" in+ HU.testCase "7" $+ fullParses (parser $ grammar NonAssoc) x+ @?= (,) [Plus (Plus (Var "5") (Var "6")) (Var "7")]+ Report {position = 5, expected = [], unconsumed = []}+ , let x = words "+ 5 + 6 7" in+ HU.testCase "8" $+ fullParses (parser $ grammar NonAssoc) x+ @?= (,) [Plus (Var "5") (Plus (Var "6") (Var "7"))]+ Report {position = 5, expected = [], unconsumed = []}+ , let x = words "+ 5 6" in+ HU.testCase "9" $+ fullParses (parser $ grammar NonAssoc) x+ @?= (,) [Plus (Var "5") (Var "6")]+ Report {position = 3, expected = [], unconsumed = []}+ ]++data AST+ = Var String+ | Plus AST AST+ deriving (Eq, Ord, Show)++grammar :: Associativity -> Grammar r (Prod r String String AST)+grammar a = mdo+ atomicExpr <- rule $ Var <$> satisfy (/= "+")++ expr <- mixfixExpression+ [[([Just (token "+"), Nothing, Nothing], a)]]+ atomicExpr+ (\x y -> case (x,y) of+ ([Just "+", Nothing, Nothing], [e1,e2]) -> Plus e1 e2+ _ -> undefined)++ return expr
+ tests/Issue14.hs view
@@ -0,0 +1,49 @@+module Issue14 where+import Control.Applicative+import Test.Tasty+import Test.Tasty.QuickCheck as QC++import Text.Earley++tests :: TestTree+tests = testGroup "Issue 14"+ [ QC.testProperty "The same rule in alternatives gives many results" $+ \x -> fullParses (parser (issue14 x)) ""+ == (,) (replicate (issue14Length x) ())+ Report { position = 0, expected = [], unconsumed = [] }+ ]++data Issue14 a+ = Pure a+ | Alt (Issue14 a) (Issue14 a)+ | Ap (Issue14 a) (Issue14 a)+ deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (Issue14 a) where+ arbitrary = sized arbTree+ where arbTree n | n > 0 = oneof [ Pure <$> arbitrary+ , Alt <$> arbTree1 <*> arbTree1+ , Ap <$> arbTree1 <*> arbTree1+ ]+ where arbTree1 = arbTree (n `div` 2)+ arbTree _ = Pure <$> arbitrary++ shrink (Pure a) = Pure <$> shrink a+ shrink (Alt a b) = a : b : [Alt a' b | a' <- shrink a] ++ [Alt a b' | b' <- shrink b]+ shrink (Ap a b) = a : b : [Ap a' b | a' <- shrink a] ++ [Ap a b' | b' <- shrink b]++issue14Length :: Issue14 () -> Int+issue14Length (Pure ()) = 1+issue14Length (Alt a b) = issue14Length a + issue14Length b+issue14Length (Ap a b) = issue14Length a * issue14Length b++issue14 :: Issue14 () -> Grammar r (Prod r () Char ())+issue14 tree = do+ emptyRule <- rule $ pure ()+ let x = go emptyRule tree+ return x+ where+ go x (Pure ()) = x+ go x (Alt b1 b2) = go x b1 <|> go x b2+ go x (Ap b1 b2) = go x b1 <* go x b2+
+ tests/Mixfix.hs view
@@ -0,0 +1,53 @@+module Mixfix where+import Control.Applicative+import Test.Tasty+import Test.Tasty.HUnit as HU++import Text.Earley+import Text.Earley.Mixfix++tests :: TestTree+tests = testGroup "Mixfix"+ [ HU.testCase "1" $+ let x = Ident [Just "x"] in+ fullParses (parser mixfixGrammar) (words "if x then x else x")+ @?= (,) [App ifthenelse [x, x, x]] Report {position = 6, expected = [], unconsumed = []}+ , HU.testCase "2" $+ let x = Ident [Just "x"] in+ fullParses (parser mixfixGrammar) (words "prefix x postfix")+ @?= (,) [App prefix [App postfix [x]]] Report {position = 3, expected = [], unconsumed = []}+ , HU.testCase "3" $+ let x = Ident [Just "x"] in+ fullParses (parser mixfixGrammar) (words "x infix1 x infix2 x")+ @?= (,) [App infix1 [x, App infix2 [x, x]]] Report {position = 5, expected = [], unconsumed = []}+ , HU.testCase "4" $+ let x = Ident [Just "x"] in+ fullParses (parser mixfixGrammar) (words "[ x ]")+ @?= (,) [App closed [x]] Report {position = 3, expected = [], unconsumed = []}+ ]++data MixfixExpr = Ident (Holey String) | App (Holey String) [MixfixExpr]+ deriving (Eq, Show)++mixfixGrammar :: Grammar r (Prod r String String MixfixExpr)+mixfixGrammar = mixfixExpression table+ (Ident . pure . Just <$> namedToken "x")+ App+ where+ hident = map (fmap token)+ table =+ [ [(hident ifthenelse, RightAssoc)]+ , [(hident prefix, RightAssoc)]+ , [(hident postfix, LeftAssoc)]+ , [(hident infix1, LeftAssoc)]+ , [(hident infix2, RightAssoc)]+ , [(hident closed, NonAssoc)]+ ]++ifthenelse, prefix, postfix, infix1, infix2, closed :: Holey String+ifthenelse = [Just "if", Nothing, Just "then", Nothing, Just "else", Nothing]+prefix = [Just "prefix", Nothing]+postfix = [Nothing, Just "postfix"]+infix1 = [Nothing, Just "infix1", Nothing]+infix2 = [Nothing, Just "infix2", Nothing]+closed = [Just "[", Nothing, Just "]"]
+ tests/Optional.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}+module Optional where+import Control.Applicative+import Test.Tasty+import Test.Tasty.HUnit as HU++import Text.Earley++tests :: TestTree+tests = testGroup "Optional"+ [ HU.testCase "Nothing" $+ fullParses (parser $ return optional_) "b"+ @?= (,) [(Nothing, 'b')] Report {position = 1, expected = "", unconsumed = ""}+ , HU.testCase "Just" $+ fullParses (parser $ return optional_) "ab"+ @?= (,) [(Just 'a', 'b')] Report {position = 2, expected = "", unconsumed = ""}+ , HU.testCase "Using rules Nothing" $+ fullParses (parser optionalRule) "b"+ @?= (,) [(Nothing, 'b')] Report {position = 1, expected = "", unconsumed = ""}+ , HU.testCase "Using rules Just" $+ fullParses (parser optionalRule) "ab"+ @?= (,) [(Just 'a', 'b')] Report {position = 2, expected = "", unconsumed = ""}+ , HU.testCase "Without continuation Nothing" $+ fullParses (parser $ return $ optional $ namedToken 'a') ""+ @?= (,) [Nothing] Report {position = 0, expected = "a", unconsumed = ""}+ , HU.testCase "Without continuation Just" $+ fullParses (parser $ return $ optional $ namedToken 'a') "a"+ @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}+ , HU.testCase "Using rules without continuation Nothing" $+ fullParses (parser $ rule $ optional $ namedToken 'a') ""+ @?= (,) [Nothing] Report {position = 0, expected = "a", unconsumed = ""}+ , HU.testCase "Using rules without continuation Just" $+ fullParses (parser $ rule $ optional $ namedToken 'a') "a"+ @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}+ ]++optional_ :: Prod r Char Char (Maybe Char, Char)+optional_ = (,) <$> optional (namedToken 'a') <*> namedToken 'b'++optionalRule :: Grammar r (Prod r Char Char (Maybe Char, Char))+optionalRule = mdo+ test <- rule $ (,) <$> optional (namedToken 'a') <*> namedToken 'b'+ return test
+ tests/ReversedWords.hs view
@@ -0,0 +1,21 @@+module ReversedWords where+import Control.Applicative+import Test.Tasty+import Test.Tasty.HUnit as HU++import Text.Earley++someWords :: Grammar r (Prod r () Char [String])+someWords = return $ flip (:) <$> (map reverse <$> some (list "word")) <*> list "stop"++tests :: TestTree+tests = testGroup "Unit Tests"+ [ 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 = []+ }+ ]
+ tests/VeryAmbiguous.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}+module VeryAmbiguous where+import Control.Applicative+import Test.Tasty+import Test.Tasty.HUnit as HU++import Text.Earley++tests :: TestTree+tests = testGroup "Very ambiguous"+ [ HU.testCase "Gives the right number of results" $+ length (fst $ fullParses (parser veryAmbiguous) $ replicate 8 'b') @?= 2871+ , HU.testCase "Gives the correct report" $+ report (parser veryAmbiguous) (replicate 3 'b') @?=+ Report {position = 3, expected = "s", unconsumed = ""}+ ]++veryAmbiguous :: Grammar r (Prod r Char Char ())+veryAmbiguous = mdo+ s <- rule $ () <$ token 'b'+ <|> () <$ s <* s+ <|> () <$ s <* s <* s+ <?> 's'+ return s