grammatical-parsers 0.3.1 → 0.3.2

raw patch · 11 files changed

+387/−204 lines, 11 filesdep +size-baseddep ~containersdep ~rank2classesdep ~testing-featPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: size-based

Dependency ranges changed: containers, rank2classes, testing-feat

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−0
• examples/Boolean.hs +2/−2
• grammatical-parsers.cabal +15/−13
• src/Text/Grampa.hs +10/−8
• src/Text/Grampa/Class.hs +26/−5
• src/Text/Grampa/ContextFree/LeftRecursive.hs +49/−22
• src/Text/Grampa/ContextFree/SortedMemoizing.hs +1/−1
• src/Text/Grampa/Internal.hs +8/−2
• test/Test.hs +100/−66
• test/Test/Ambiguous.hs +35/−0
• test/Test/Examples.hs +103/−85

@@ -0,0 +1,38 @@+Version 0.3.2+---------------+* Improved error reporting+* Updated test suite to work with testing-feat >= 1.1+* Fixed the construction of `Ambiguous` results+* Added Applicative and Traversable instances for Ambiguous++Version 0.3.1+---------------+* Added `Text.Parser.Combinators`+* Improved `try/(<?>)` error reporting+* Added `showFailure`++Version 0.3+---------------+* Eliminated `token` and `whiteSpace`+* Added the `Lexical` class of grammars+* Added `Semigroup` instances to fix compilation with GHC 8.4.1+* More precise calculation of `(>>=)` descendants+* Added the `Ambiguous` results and the `AmbiguousParsing` class+* Added the `SortedMemoizing` module++Version 0.2.2+---------------+* Incremented dependency version bounds++Version 0.2.1+---------------+* Added the `ContextFree.Continued` module+* Fixed `LeftRecursive.Parallel.concatMany`++Version 0.2+---------------+* Numerous performance and documentation improvements+* Fixed the `endOfInput` implementation in `PEG.Backtrack`+* Made `LeftRecursive.Parser` a type synonym, introduced `peg` and `longest`+* Added the `notSatisfy[Char]` methods+* Added `satisfyCharInput`

@@ -53,9 +53,9 @@            p g String e -> Boolean e (p g String) -> Boolean e (p g String) boolean p Boolean{..} = Boolean{    expr= term-         <|> or <$> expr <* symbol "||" <*> term,+         <|> or <$> term <* symbol "||" <*> expr,    term= factor-         <|> and <$> term <* symbol "&&" <*> factor,+         <|> and <$> factor <* symbol "&&" <*> term,    factor= keyword "True" *> pure true            <|> keyword "False" *> pure false            <|> keyword "not" *> takeCharsWhile isSpace *> (not <$> factor)

@@ -1,5 +1,5 @@ name:                grammatical-parsers-version:             0.3.1+version:             0.3.2 synopsis:            parsers that combine into grammars description:   /Gram/matical-/pa/rsers, or Grampa for short, is a library of parser types whose values are meant to be assigned@@ -16,7 +16,7 @@ category:            Text build-type:          Simple cabal-version:       >=1.10-extra-source-files:  README.md+extra-source-files:  README.md, CHANGELOG.md source-repository head   type:              git   location:          https://github.com/blamario/grampa@@ -37,33 +37,35 @@   -- other-modules:   ghc-options:         -Wall   build-depends:       base >=4.9 && <5,-                       containers >= 0.4 && < 0.6,+                       containers >= 0.4 && < 0.7,                        transformers >= 0.5 && < 0.6,                        monoid-subclasses >=0.4 && <0.5,                        parsers < 0.13,-                       rank2classes >= 1.0.2 && < 1.2+                       rank2classes >= 1.0.2 && < 1.3  executable             arithmetic   hs-source-dirs:      examples   main-is:             Main.hs   other-modules:       Arithmetic, Boolean, Combined, Comparisons, Conditionals, Lambda, Utilities   default-language:    Haskell2010-  build-depends:       base >=4.9 && <5, containers >= 0.5.7.0 && < 0.6,+  build-depends:       base >=4.9 && <5, containers >= 0.5.7.0 && < 0.7,                        parsers < 0.13,-                       rank2classes >= 1.0.2 && < 1.2, grammatical-parsers,+                       rank2classes >= 1.0.2 && < 1.3, grammatical-parsers,                        monoid-subclasses >=0.4 && <0.5  test-suite           quicktests   type:              exitcode-stdio-1.0   hs-source-dirs:    test, examples   x-uses-tf:         true-  build-depends:     base >=4.9 && < 5, containers >= 0.5.7.0 && < 0.6,+  build-depends:     base >=4.9 && < 5, containers >= 0.5.7.0 && < 0.7,                      monoid-subclasses < 0.5, parsers < 0.13,-                     rank2classes >= 1.0.2 && < 1.2, grammatical-parsers,-                     QuickCheck >= 2 && < 3, checkers >= 0.4.6 && < 0.5, testing-feat < 0.5,+                     rank2classes >= 1.0.2 && < 1.3, grammatical-parsers,+                     QuickCheck >= 2 && < 3, checkers >= 0.4.6 && < 0.5, size-based < 0.2,+                     testing-feat >= 1.1 && < 1.2,                      tasty >= 0.7, tasty-quickcheck >= 0.7   main-is:           Test.hs-  other-modules:     Test.Examples, Arithmetic, Boolean, Combined, Comparisons, Conditionals, Lambda, Utilities+  other-modules:     Test.Ambiguous, Test.Examples,+                     Arithmetic, Boolean, Combined, Comparisons, Conditionals, Lambda, Utilities   default-language:  Haskell2010  test-suite           doctests@@ -78,9 +80,9 @@   type:              exitcode-stdio-1.0   hs-source-dirs:    test, examples   ghc-options:       -O2 -Wall -rtsopts -main-is Benchmark.main-  Build-Depends:     base >=4.9 && < 5, rank2classes >= 1.0.2 && < 1.2, grammatical-parsers,-                     monoid-subclasses >=0.4 && <0.5,-                     criterion >= 1.0, deepseq >= 1.1, containers >= 0.5.7.0 && < 0.6, text >= 1.1+  Build-Depends:     base >=4.9 && < 5, rank2classes >= 1.0.2 && < 1.3, grammatical-parsers,+                     monoid-subclasses >=0.4 && <0.5, parsers < 0.13,+                     criterion >= 1.0, deepseq >= 1.1, containers >= 0.5.7.0 && < 0.7, text >= 1.1   main-is:           Benchmark.hs   other-modules:     Main, Arithmetic, Boolean, Combined, Comparisons, Conditionals, Lambda, Utilities   default-language:  Haskell2010

@@ -1,6 +1,6 @@ -- | Collection of parsing algorithms with a common interface, operating on grammars represented as records with rank-2 -- field types.-{-# LANGUAGE FlexibleContexts, KindSignatures, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, KindSignatures, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Text.Grampa (    -- * Parsing methods    MultiParsing(..),@@ -16,6 +16,7 @@  import Data.List (intercalate) import Data.Monoid ((<>))+import qualified Data.Monoid.Factorial as Factorial import Data.Monoid.Textual (TextualMonoid, toString) import Text.Parser.Char (CharParsing(char, notChar, anyChar)) import Text.Parser.Combinators (Parsing((<?>), notFollowedBy, skipMany, skipSome, unexpected))@@ -42,10 +43,10 @@  -- | Given the textual parse input, the parse failure on the input, and the number of lines preceding the failure to -- show, produce a human-readable failure description.-showFailure :: TextualMonoid s => s -> ParseFailure -> Int -> String+showFailure :: (Eq s, TextualMonoid s) => s -> ParseFailure -> Int -> String showFailure input (ParseFailure pos expected) preceding =-   unlines prevLines <> replicate column ' ' <> "^\n"-   <> "at line " <> show (length allPrevLines) <> ", column " <> show column <> "\n"+   unlines (toString mempty <$> prevLines) <> replicate column ' ' <> "^\n"+   <> "at line " <> show (length allPrevLines) <> ", column " <> show (column+1) <> "\n"    <> "expected " <> oxfordComma expected    where oxfordComma [] = []          oxfordComma [x] = x@@ -54,12 +55,13 @@          onLast _ [] = []          onLast f [x] = [f x]          onLast f (x:xs) = x : onLast f xs-         (allPrevLines, column) = context [] pos (lines $ toString (const mempty) input)+         (allPrevLines, column) = context [] pos (Factorial.split (== "\n") input)          prevLines = reverse (take (succ preceding) allPrevLines)          context revLines restCount []             | restCount > 0 = (["Error: the failure position is beyond the input length"], -1)             | otherwise = (revLines, restCount)          context revLines restCount (next:rest)-            | restCount < nextLength = (next:revLines, restCount)-            | otherwise = context (next:revLines) (restCount - nextLength - 1) rest-            where nextLength = length next+            | restCount' < 0 = (next:revLines, restCount)+            | otherwise = context (next:revLines) restCount' rest+            where nextLength = Factorial.length next+                  restCount' = restCount - nextLength - 1

@@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DefaultSignatures, RankNTypes, ScopedTypeVariables,-             TypeApplications, TypeFamilies, DeriveDataTypeable, DeriveFunctor #-}+             TypeApplications, TypeFamilies, DeriveDataTypeable #-} module Text.Grampa.Class (MultiParsing(..), AmbiguousParsing(..), GrammarParsing(..), MonoidParsing(..), Lexical(..),                           ParseResults, ParseFailure(..), Ambiguous(..), completeParser) where @@ -10,12 +10,13 @@ import Data.List.NonEmpty (NonEmpty((:|))) import Data.Data (Data) import Data.Typeable (Typeable)-import Data.Monoid (Monoid, (<>))+import Data.Monoid (Monoid(mempty, mappend)) import Data.Monoid.Cancellative (LeftReductiveMonoid) import qualified Data.Monoid.Null as Null import Data.Monoid.Null (MonoidNull) import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid)+import Data.Semigroup (Semigroup((<>))) import Text.Parser.Combinators (Parsing(notFollowedBy, (<?>)), skipMany) import Text.Parser.Char (CharParsing(char)) import Text.Parser.Token (TokenParsing)@@ -30,13 +31,33 @@  -- | An 'Ambiguous' parse result, produced by the 'ambiguous' combinator, contains a 'NonEmpty' list of alternative -- results.-newtype Ambiguous a = Ambiguous (NonEmpty a) deriving (Data, Eq, Functor, Ord, Show, Typeable)+newtype Ambiguous a = Ambiguous (NonEmpty a) deriving (Data, Eq, Ord, Show, Typeable)  instance Show1 Ambiguous where    liftShowsPrec sp sl d (Ambiguous (h :| l)) t       | d > 5 = "(Ambiguous $ " <> sp 0 h (" :| " <> sl l (')' : t))       | otherwise = "Ambiguous (" <> sp 0 h (" :| " <> sl l (')' : t)) +instance Functor Ambiguous where+   fmap f (Ambiguous a) = Ambiguous (fmap f a)++instance Applicative Ambiguous where+   pure a = Ambiguous (pure a)+   Ambiguous f <*> Ambiguous a = Ambiguous (f <*> a)++instance Foldable Ambiguous where+   foldMap f (Ambiguous a) = foldMap f a++instance Traversable Ambiguous where+   traverse f (Ambiguous a) = Ambiguous <$> traverse f a++instance Semigroup a => Semigroup (Ambiguous a) where+   Ambiguous xs <> Ambiguous ys = Ambiguous (liftA2 (<>) xs ys)++instance Monoid a => Monoid (Ambiguous a) where+   mempty = Ambiguous (mempty :| [])+   Ambiguous xs `mappend` Ambiguous ys = Ambiguous (liftA2 mappend xs ys)+ completeParser :: MonoidNull s => Compose ParseResults (Compose [] ((,) s)) r -> Compose ParseResults [] r completeParser (Compose (Left failure)) = Compose (Left failure) completeParser (Compose (Right (Compose results))) =@@ -194,7 +215,7 @@    lexicalToken p = p <* lexicalWhiteSpace    isIdentifierStartChar c = isLetter c || c == '_'    isIdentifierFollowChar c = isAlphaNum c || c == '_'-   identifier = identifierToken (liftA2 (<>) (satisfyCharInput (isIdentifierStartChar @g))-                                             (takeCharsWhile (isIdentifierFollowChar @g))) <?> "an identifier"+   identifier = identifierToken (liftA2 mappend (satisfyCharInput (isIdentifierStartChar @g))+                                                (takeCharsWhile (isIdentifierFollowChar @g))) <?> "an identifier"    identifierToken = lexicalToken    keyword s = lexicalToken (string s *> notSatisfyChar (isIdentifierFollowChar @g)) <?> ("keyword " <> show s)

@@ -684,33 +684,60 @@                   f (FrontParser p) _ = Memoizing.applyParser p ((s,d''):parsedTail)                   f _ result = result          fixRecursive :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)-         whileAnyContinues :: g (ResultList g s) -> g (ResultList g s) -> g (ResultList g s)-         recurseOnce :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)-         maybeDependencies :: g (Rank2.Product (Const (Maybe (g (Const Bool)))) (ResultAppend g s))-         maybeDependency :: SeparatedParser Memoizing.Parser g s r-                         -> Rank2.Product (Const (Maybe (g (Const Bool)))) (ResultAppend g s) r+         whileAnyContinues :: (g (ResultList g s) -> g (ResultList g s))+                           -> (g (ResultList g s) -> g (ResultList g s))+                           -> g (ResultList g s) -> g (ResultList g s) -> g (ResultList g s)+         recurseTotal :: s -> g (ResultList g s Rank2.~> ResultList g s) -> [(s, g (ResultList g s))]+                      -> g (ResultList g s)+                      -> g (ResultList g s)+         recurseMarginal :: s -> [(s, g (ResultList g s))]+                      -> g (ResultList g s)+                      -> g (ResultList g s)+         maybeDependencies :: g (Const (Maybe (g (Const Bool))))+         maybeDependency :: SeparatedParser Memoizing.Parser g s r -> Const (Maybe (g (Const Bool))) r+         appends :: g (ResultAppend g s)+         parserAppend :: SeparatedParser Memoizing.Parser g s r -> ResultAppend g s r           directs = Rank2.fmap backParser parsers          indirects = Rank2.fmap (\p-> case p of {CycleParser{}-> cycleParser p; _ -> empty}) parsers+         appends = Rank2.fmap parserAppend parsers+         parserAppend p@CycleParser{} = appendResultsArrow p+         parserAppend _ = Rank2.Arrow (Rank2.Arrow . (<>))          maybeDependencies = Rank2.fmap maybeDependency parsers-         maybeDependency p@CycleParser{} = Rank2.Pair (Const $ Just $ dependencies p) (appendResultsArrow p)-         maybeDependency _ = Rank2.Pair (Const Nothing) (Rank2.Arrow (Rank2.Arrow . (<>)))+         maybeDependency p@CycleParser{} = Const (Just $ dependencies p)+         maybeDependency _ = Const Nothing           fixRecursive s parsedTail initial =-            foldr1 whileAnyContinues (iterate (recurseOnce s parsedTail) initial)+            whileAnyContinues (recurseTotal s (appends Rank2.<*> initial) parsedTail)+                              (recurseMarginal s parsedTail)+                              initial initial -         whileAnyContinues g1 g2 = Rank2.liftA3 choiceWhile maybeDependencies g1 g2-            where choiceWhile :: Rank2.Product (Const (Maybe (g (Const Bool)))) (ResultAppend g s) x-                              -> ResultList g s x -> ResultList g s x -> ResultList g s x-                  combine :: Const Bool x -> ResultList g s x -> Const Bool x-                  choiceWhile (Rank2.Pair (Const Nothing) _) r1 _ = r1-                  choiceWhile (Rank2.Pair (Const (Just deps)) append) r1 r2-                     | getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps g1)) =-                       append `Rank2.apply` r1 `Rank2.apply` r2-                     | otherwise = r1-                  combine (Const False) _ = Const False-                  combine (Const True) (ResultList [] _) = Const False-                  combine (Const True) _ = Const True+         whileAnyContinues ft fm total marginal =+            Rank2.liftA3 choiceWhile maybeDependencies total (whileAnyContinues ft fm (ft total) (fm marginal))+            where choiceWhile :: Const (Maybe (g (Const Bool))) x+                              -> ResultList g s x -> ResultList g s x+                              -> ResultList g s x+                  choiceWhile (Const Nothing) t _ = t+                  choiceWhile (Const (Just deps)) t t'+                     | getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps marginal)) = t'+                     | ResultList [] (Memoizing.FailureInfo _ expected) <- t =+                        let ResultList _ (Memoizing.FailureInfo pos expected') =+                               if getAny (Rank2.foldMap (Any . getConst) $+                                          Rank2.liftA2 (combineFailures expected) deps marginal)+                                  then t' else t+                        in ResultList [] (Memoizing.FailureInfo pos expected')+                     | otherwise = t+                     where combine :: Const Bool x -> ResultList g s x -> Const Bool x+                           combineFailures :: [String] -> Const Bool x -> ResultList g s x -> Const Bool x+                           combine (Const False) _ = Const False+                           combine (Const True) (ResultList [] _) = Const False+                           combine (Const True) _ = Const True+                           combineFailures _ (Const False) _ = Const False+                           combineFailures expected (Const True) (ResultList _ (Memoizing.FailureInfo _ expected'))+                              = Const (any (`notElem` expected) expected') -         recurseOnce s parsedTail initial = Rank2.fmap (($ parsed) . Memoizing.applyParser) indirects-            where parsed = (s, initial):parsedTail+         recurseTotal s initialAppends parsedTail total = Rank2.liftA2 reparse initialAppends indirects+            where reparse :: (ResultList g s Rank2.~> ResultList g s) a -> Memoizing.Parser g s a -> ResultList g s a+                  reparse append p = Rank2.apply append (Memoizing.applyParser p $ (s, total) : parsedTail)+         recurseMarginal s parsedTail marginal =+            flip Memoizing.applyParser ((s, marginal) : parsedTail) Rank2.<$> indirects

@@ -57,7 +57,7 @@    {-# INLINABLE (<*>) #-}  instance Alternative (Parser g i) where-   empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) ["empty"])+   empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) [])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest    {-# INLINABLE (<|>) #-}

@@ -33,10 +33,16 @@          f (ResultsOfLength _ [] r) = (,) mempty <$> toList r  instance Semigroup FailureInfo where-   f1@(FailureInfo pos1 exp1) <> f2@(FailureInfo pos2 exp2) = FailureInfo pos' exp'+   FailureInfo pos1 exp1 <> FailureInfo pos2 exp2 = FailureInfo pos' exp'       where (pos', exp') | pos1 < pos2 = (pos1, exp1)                          | pos1 > pos2 = (pos2, exp2)-                         | otherwise = (pos1, exp1 <> exp2)+                         | otherwise = (pos1, merge exp1 exp2)+            merge [] exps = exps+            merge exps [] = exps+            merge xs@(x:xs') ys@(y:ys')+               | x < y = x : merge xs' ys+               | x > y = y : merge xs ys'+               | otherwise = x : merge xs' ys'  instance Monoid FailureInfo where    mempty = FailureInfo maxBound []

@@ -1,5 +1,5 @@-{-# Language FlexibleContexts, FlexibleInstances, RankNTypes, RecordWildCards, ScopedTypeVariables, -             StandaloneDeriving, TemplateHaskell, UndecidableInstances #-}+{-# Language FlexibleContexts, FlexibleInstances, RankNTypes, RecordWildCards, +             ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, UndecidableInstances #-} module Main where  import Control.Applicative (Applicative, Alternative, Const(..), pure, empty, many, optional, (<*>), (*>), (<|>))@@ -7,7 +7,9 @@ import Control.Monad (MonadPlus(mzero, mplus), guard, liftM, liftM2, void) import Data.Char (isSpace, isLetter) import Data.List (find, minimumBy, nub, sort)-import Data.Monoid (Monoid(..), Product(..), (<>))+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Semigroup (Semigroup, (<>))+import Data.Monoid (Monoid(..), Product(..)) import Data.Monoid.Cancellative (LeftReductiveMonoid(..)) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid(factors))@@ -16,14 +18,16 @@ import Data.Word (Word8, Word64)  import Data.Functor.Compose (Compose(..))-import Text.Parser.Combinators (sepBy1, skipMany)+import Text.Parser.Combinators (choice, sepBy1, skipMany) import Text.Parser.Token (whiteSpace) -import Test.Feat (Enumerable(..), Enumerate, FreePair(Free), consts, shared, unary, uniform)+import Control.Enumerable (Shareable, Sized, share)+import Test.Feat (Enumerable(..), c0, c1, uniform) import Test.Feat.Enumerate (pay) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.QuickCheck (Arbitrary(..), Gen, Positive(..), Property,                               (===), (==>), (.&&.), forAll, property, sized, testProperty, within)+import Test.QuickCheck (verbose) import Test.QuickCheck.Checkers (Binop, EqProp(..), TestBatch, unbatch) import Test.QuickCheck.Classes (functor, monad, monoid, applicative, alternative,                                 monadFunctor, monadApplicative, monadOr, monadPlus)@@ -34,6 +38,7 @@ import qualified Text.Grampa.ContextFree.Parallel as Parallel import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive +import qualified Test.Ambiguous import qualified Test.Examples  import Prelude hiding (null, takeWhile)@@ -88,10 +93,35 @@                testProperty "name list" $                  start (parseComplete nameListGrammar "foo, bar") == Compose (Right ["foo bar"])],            testGroup "arithmetic"-             [testProperty "arithmetic"   $ Test.Examples.parseArithmetical,-              testProperty "comparisons"  $ Test.Examples.parseComparison,-              testProperty "boolean"      $ Test.Examples.parseBoolean,-              testProperty "conditionals" $ Test.Examples.parseConditional],+             [testProperty "arithmetic"   $ \tree-> Test.Examples.parseArithmetical (show tree) === Right tree,+              testProperty "boolean"      $ \tree-> Test.Examples.parseBoolean (show tree) === Right tree,+              testProperty "conditionals" $ \tree-> Test.Examples.parseConditional (show tree) === Right tree],+           testGroup "ambiguous"+             [testProperty "complete" $+              Test.Ambiguous.amb (parseComplete (fixGrammar Test.Ambiguous.grammar) "xyzw")+              == Compose (Right [pure (flip Test.Ambiguous.Xyzw "w" $ Ambiguous $ pure $+                                       flip Test.Ambiguous.Xyz "z" $ Ambiguous $+                                       Test.Ambiguous.Xy1 "x" "y"+                                       :| [Test.Ambiguous.Xy2+                                           (pure $ Test.Ambiguous.Xy1 "x" "") "y"])]),+              testProperty "prefix" $+              Test.Ambiguous.amb (parsePrefix (fixGrammar Test.Ambiguous.grammar) "xyzw")+              == Compose (Compose (Right [("yzw", pure (Test.Ambiguous.Xy1 "x" "")),+                                          ("zw", Ambiguous (Test.Ambiguous.Xy1 "x" "y" :|+                                                            [Test.Ambiguous.Xy2+                                                             (pure (Test.Ambiguous.Xy1 "x" ""))+                                                             "y"])),+                                          ("w", pure (Test.Ambiguous.Xyz+                                                      (Ambiguous (Test.Ambiguous.Xy1 "x" "y" :|+                                                                  [Test.Ambiguous.Xy2+                                                                   (pure (Test.Ambiguous.Xy1 "x" ""))+                                                                   "y"]))+                                                      "z")),+                                          ("", pure (flip Test.Ambiguous.Xyzw "w" $ Ambiguous $ pure $+                                                     flip Test.Ambiguous.Xyz "z" $ Ambiguous $+                                                     Test.Ambiguous.Xy1 "x" "y"+                                                     :| [Test.Ambiguous.Xy2+                                                         (pure $ Test.Ambiguous.Xy1 "x" "") "y"]))]))],            testGroup "primitives"              [testProperty "anyToken mempty" $ simpleParse anyToken "" == Left (ParseFailure 0 ["anyToken"]),               testProperty "anyToken list" $@@ -123,8 +153,19 @@               testBatch $ monadFunctor parser2s,               testBatch $ monadApplicative parser2s,               -- testBatch $ monadOr parser2s,-              testBatch $ monadPlus parser2s-             ]]+              testBatch $ monadPlus parser2s],+           testGroup "errors"+             [testProperty "start" (Test.Examples.parseArithmetical ":4" +                                    === Left ":4\n^\nat line 1, column 1\nexpected digits, string \"(\", or string \"-\""),+              testProperty "middle" (Test.Examples.parseArithmetical "4 - :3"+                                     === Left "4 - :3\n    ^\nat line 1, column 5\nexpected digits or string \"(\""),+              testProperty "middle line" (Test.Examples.parseArithmetical "4 -\n :3\n+ 2"+                                           === Left "4 -\n :3\n ^\nat line 2, column 2\nexpected digits or string \"(\""),+              testProperty "missing" (Test.Examples.parseArithmetical "4 - " +                                      === Left "4 - \n    ^\nat line 1, column 5\nexpected digits or string \"(\""),+              testProperty "missing" (Test.Examples.parseArithmetical "4 -\n" +                                      === Left "4 -\n\n^\nat line 2, column 1\nexpected digits or string \"(\"")]+           ]    where lookAheadP :: String -> DescribedParser String [Bool] -> Bool          lookAheadConsumeP :: DescribedParser String [Bool] -> Property          lookAheadOrNotP :: DescribedParser String () -> Property@@ -161,6 +202,9 @@ instance Show (DescribedParser s r) where    show (DescribedParser d _) = d +instance (Show s, MonoidNull s, Semigroup r) => Semigroup (DescribedParser s r) where+   DescribedParser d1 p1 <> DescribedParser d2 p2 = DescribedParser (d1 ++ " <> " ++ d2) (p1 <> p2)+ instance (Show s, MonoidNull s, Monoid r) => Monoid (DescribedParser s r) where    mempty = DescribedParser "mempty" mempty    DescribedParser d1 p1 `mappend` DescribedParser d2 p2 = DescribedParser (d1 ++ " <> " ++ d2) (mappend p1 p2)@@ -197,68 +241,58 @@    mzero = DescribedParser "mzero" mzero    DescribedParser d1 p1 `mplus` DescribedParser d2 p2 = DescribedParser (d1 ++ " `mplus` " ++ d2) (mplus p1 p2) -instance forall s. (FactorialMonoid s, LeftReductiveMonoid s, Ord s, Typeable s, Show s, Enumerable s) =>+instance forall s. (Semigroup s, FactorialMonoid s, LeftReductiveMonoid s, Ord s, Typeable s, Show s, Enumerable s) =>          Enumerable (DescribedParser s s) where-   enumerate = consts (pure <$> [DescribedParser "anyToken" anyToken,-                                 DescribedParser "getInput" getInput,-                                 DescribedParser "empty" empty,-                                 DescribedParser "mempty" mempty])-               <> pay (unary $ \s-> DescribedParser "string" (string s))-               <> pay (unary $ \pred-> DescribedParser "satisfy" (satisfy pred))-               <> pay (unary $ \pred-> DescribedParser "takeWhile" (takeWhile pred))-               <> pay (unary $ \pred-> DescribedParser "takeWhile1" (takeWhile1 pred))-               <> binary " *> " (*>)-               <> binary " <> " (<>)-               <> binary " <|> " (<|>)-      where binary :: String -> (forall g. Rank2.Functor g => Parser g s s -> Parser g s s -> Parser g s s)-                   -> Enumerate (DescribedParser s s)-            binary nm op = (\(Free (DescribedParser d1 p1, DescribedParser d2 p2))-> DescribedParser (d1 <> nm <> d2) (op p1 p2))-                           <$> pay enumerate+   enumerate = share (choice [c0 (DescribedParser "anyToken" anyToken),+                              c0 (DescribedParser "getInput" getInput),+                              c0 (DescribedParser "empty" empty),+                              c0 (DescribedParser "mempty" mempty),+                              pay (c1 $ \s-> DescribedParser "string" (string s)),+                              pay (c1 $ \pred-> DescribedParser "satisfy" (satisfy pred)),+                              pay (c1 $ \pred-> DescribedParser "takeWhile" (takeWhile pred)),+                              pay (c1 $ \pred-> DescribedParser "takeWhile1" (takeWhile1 pred)),+                              binary " *> " (*>),+                              binary " <> " (<>),+                              binary " <|> " (<|>)]) -instance forall s r. (Ord s, FactorialMonoid s, LeftReductiveMonoid s, Show s, Enumerable s) =>+instance forall s r. (Ord s, Semigroup s, FactorialMonoid s, LeftReductiveMonoid s, Show s, Enumerable s) =>          Enumerable (DescribedParser s ()) where-   enumerate = consts (pure <$> [DescribedParser "endOfInput" endOfInput])-               <> pay (unary $ \(DescribedParser d p :: DescribedParser s s)-> DescribedParser ("void " <> d) (void p))-               <> pay (unary $ \(DescribedParser d p :: DescribedParser s s)->-                                  DescribedParser ("(notFollowedBy " <> d <> ")") (notFollowedBy p))+   enumerate = share (choice [c0 (DescribedParser "endOfInput" endOfInput),+                              pay (c1 $ \(DescribedParser d p :: DescribedParser s s)-> DescribedParser ("void " <> d) (void p)),+                              pay (c1 $ \(DescribedParser d p :: DescribedParser s s)->+                                    DescribedParser ("(notFollowedBy " <> d <> ")") (notFollowedBy p))]) -instance forall s r. (Show s, FactorialMonoid s, Typeable s) => Enumerable (DescribedParser s [Bool]) where-   enumerate = consts (pure <$> [DescribedParser "empty" empty,-                                 DescribedParser "mempty" mempty])-               <> pay (unary $ \r-> DescribedParser ("(pure " ++ shows r ")") (pure r))-               <> pay (unary $ \(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p))-               <> binary " *> " (*>)-               <> binary " <> " (<>)-               <> binary " <|> " (<|>)-      where binary :: String-                   -> (forall g. Rank2.Functor g => Parser g s [Bool] -> Parser g s [Bool] -> Parser g s [Bool])-                   -> Enumerate (DescribedParser s [Bool])-            binary nm op = (\(Free (DescribedParser d1 p1, DescribedParser d2 p2))-> DescribedParser (d1 <> nm <> d2) (op p1 p2))-                           <$> pay enumerate+instance forall s r. (Show s, Semigroup s, FactorialMonoid s, Typeable s) => Enumerable (DescribedParser s [Bool]) where+   enumerate = share (choice [c0 (DescribedParser "empty" empty),+                              c0 (DescribedParser "mempty" mempty),+                              pay (c1 $ \r-> DescribedParser ("(pure " ++ shows r ")") (pure r)),+                              pay (c1 $ \(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p)),+                              binary " *> " (*>),+                              binary " <> " (<>),+                              binary " <|> " (<|>)]) -instance forall s r. (Show s, FactorialMonoid s, Typeable s) => Enumerable (DescribedParser s ([Bool] -> [Bool])) where-   enumerate = consts (pure <$> [DescribedParser "empty" empty,-                                 DescribedParser "mempty" mempty])-               <> pay (unary $ \r-> DescribedParser ("(pure " ++ shows r ")") (pure r))-               <> pay (unary $ \(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p))-               <> binary " *> " (*>)-               <> binary " <> " (<>)-               <> binary " <|> " (<|>)-      where binary :: String-                   -> (forall g. Rank2.Functor g => Parser g s ([Bool] -> [Bool]) -> Parser g s ([Bool] -> [Bool])-                                                    -> Parser g s ([Bool] -> [Bool]))-                   -> Enumerate (DescribedParser s ([Bool] -> [Bool]))-            binary nm op = (\(Free (DescribedParser d1 p1, DescribedParser d2 p2))-> DescribedParser (d1 <> nm <> d2) (op p1 p2))-                           <$> pay enumerate+instance forall s r. (Show s, Semigroup s, FactorialMonoid s, Typeable s) =>+         Enumerable (DescribedParser s ([Bool] -> [Bool])) where+   enumerate = share (choice [c0 (DescribedParser "empty" empty),+                              c0 (DescribedParser "mempty" mempty),+                              pay (c1 $ \r-> DescribedParser ("(pure " ++ shows r ")") (pure r)),+                              pay (c1 $ \(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p)),+                              binary " *> " (*>),+                              binary " <> " (<>),+                              binary " <|> " (<|>)]) -instance (Ord s, Enumerable s) => Enumerable (s -> Bool) where-   enumerate = pay (unary (<=))-               <> pay (unary const)+binary :: forall f s a. (Typeable f, Sized f, Enumerable (DescribedParser s a))+       => String+       -> (forall g. Rank2.Functor g => Parser g s a -> Parser g s a -> Parser g s a)+       -> Shareable f (DescribedParser s a)+binary nm op = pay $ c1 (\(DescribedParser d1 p1, DescribedParser d2 p2)-> +                          DescribedParser (d1 <> nm <> d2) (op p1 p2)) -instance Enumerable ([Bool] -> [Bool]) where-   enumerate = consts [pure id,-                       pure (map not)]-               <> pay (unary const)+instance {-# OVERLAPS #-} (Ord s, Enumerable s) => Enumerable (s -> Bool) where+   enumerate = share (pay (c1 (<=)) <|> pay (c1 const))++-- instance Enumerable ([Bool] -> [Bool]) where+--    enumerate = share (choice [c0 id, c0 (map not), pay (c1 const)])  instance EqProp Word64 where    a =-= b = property (a == b)

@@ -0,0 +1,35 @@+{-# Language FlexibleInstances, RankNTypes, RecordWildCards, TemplateHaskell #-}+module Test.Ambiguous where++import Control.Applicative ((<|>), empty, liftA2)+import Data.Foldable (fold)+import Data.Semigroup ((<>))++import qualified Rank2.TH+import Text.Grampa+import Text.Grampa.Combinators+import Text.Grampa.ContextFree.LeftRecursive (Parser)++import Debug.Trace++data Amb = Xy1 String String+         | Xy2 (Ambiguous Amb) String+         | Xyz (Ambiguous Amb) String+         | Xyzw (Ambiguous Amb) String+         deriving (Eq, Show)++data Test p = Test{+   amb :: p (Ambiguous Amb)+   }++grammar :: Test (Parser Test String) -> Test (Parser Test String)+grammar Test{..} = Test{+   amb = ambiguous (Xy1 <$> string "x" <*> moptional (string "y")+                    <|> Xy2 <$> amb <*> string "y"+                    <|> Xyz <$> amb <*> string "z"+                    <|> Xyzw <$> amb <*> string "w")+   }++instance Lexical Test++$(Rank2.TH.deriveAll ''Test)

@@ -1,13 +1,16 @@-{-# Language FlexibleInstances, RankNTypes, ScopedTypeVariables #-}+{-# Language FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-} module Test.Examples where  import Control.Applicative (empty, (<|>)) import Data.Functor.Compose (Compose(..)) import Data.Monoid (Monoid(..), (<>))-import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid)+import Text.Parser.Combinators (choice) -import Test.Feat (Enumerable(..), Enumerate, FreePair(Free), consts, shared, unary, uniform)+import Control.Enumerable (share)+import Test.Feat (Enumerable(..), Enumerate, c0, c1, c2, c3, uniform) import Test.Feat.Enumerate (pay)+import Test.Feat.Modifiers (Nat(..)) import Test.Tasty.QuickCheck (Arbitrary(..), Gen, Positive(..), Property, testProperty, (===), (==>), (.&&.),                               forAll, mapSize, oneof, resize, sized, whenFail) import Data.Word (Word8)@@ -20,117 +23,132 @@ import qualified Boolean import qualified Conditionals -parseArithmetical :: Sum -> Bool-parseArithmetical (Sum s) = f s' == s'-   where f = uniqueParse (fixGrammar Arithmetic.arithmetic) Arithmetic.expr-         s' = f s+parseArithmetical :: String -> Either String ArithmeticTree   +parseArithmetical = uniqueParse (fixGrammar Arithmetic.arithmetic) Arithmetic.expr -parseComparison :: Comparison -> Bool-parseComparison (Comparison s) = f s' == s'-   where f = uniqueParse (fixGrammar comparisons) (Comparisons.test . Rank2.snd)-         s' = f s+parseBoolean :: String -> Either String BooleanTree+parseBoolean = uniqueParse (fixGrammar boolean) (Boolean.expr . Rank2.snd)  comparisons :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) =>                GrammarBuilder ArithmeticComparisons g Parser String comparisons (Rank2.Pair a c) =    Rank2.Pair (Arithmetic.arithmetic a) (Comparisons.comparisons c){Comparisons.term= Arithmetic.expr a} -parseBoolean :: Disjunction -> Bool-parseBoolean (Disjunction s) = f s' == s'-   where f = uniqueParse (fixGrammar boolean) (Boolean.expr . Rank2.snd)-         s' = f s- boolean :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) =>            GrammarBuilder ArithmeticComparisonsBoolean g Parser String boolean (Rank2.Pair ac b) = Rank2.Pair (comparisons ac) (Boolean.boolean (Comparisons.test $ Rank2.snd ac) b) -parseConditional :: Conditional -> Bool-parseConditional (Conditional s) = f s' == s'-   where f = uniqueParse (fixGrammar conditionals) (Conditionals.expr . Rank2.snd)-         s' = f s+parseConditional :: String -> Either String (ConditionalTree ArithmeticTree)+parseConditional = uniqueParse (fixGrammar conditionals) (Conditionals.expr . Rank2.snd)  conditionals :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) => GrammarBuilder ACBC g Parser String conditionals (Rank2.Pair acb c) =    boolean acb `Rank2.Pair`    Conditionals.conditionals c{Conditionals.test= Boolean.expr (Rank2.snd acb),-                               Conditionals.term= Arithmetic.expr (Rank2.fst $ Rank2.fst acb)}+                               Conditionals.term= Unconditional <$> Arithmetic.expr (Rank2.fst $ Rank2.fst acb)} -type ArithmeticComparisons = Rank2.Product (Arithmetic.Arithmetic String) (Comparisons.Comparisons String String)-type ArithmeticComparisonsBoolean = Rank2.Product ArithmeticComparisons (Boolean.Boolean String)-type ACBC = Rank2.Product ArithmeticComparisonsBoolean (Conditionals.Conditionals String String)+type ArithmeticComparisons = Rank2.Product (Arithmetic.Arithmetic ArithmeticTree) (Comparisons.Comparisons ArithmeticTree BooleanTree)+type ArithmeticComparisonsBoolean = Rank2.Product ArithmeticComparisons (Boolean.Boolean BooleanTree)+type ACBC = Rank2.Product ArithmeticComparisonsBoolean (Conditionals.Conditionals BooleanTree+                                                        (ConditionalTree ArithmeticTree)) -newtype Factor      = Factor {factorString :: String}           deriving (Show)-newtype Product     = Product {productString :: String}         deriving (Show)-newtype Sum         = Sum {sumString :: String}                 deriving (Show)-newtype Comparison  = Comparison {compString :: String}         deriving (Show)-newtype Truth       = Truth {truthString :: String}             deriving (Show)-newtype Conjunction = Conjunction {conjunctionString :: String} deriving (Show)-newtype Disjunction = Disjunction {disjunctionString :: String} deriving (Show)-newtype Conditional = Conditional {conditionalString :: String} deriving (Show)+data ArithmeticTree = Number (Nat Int)+                   | Add ArithmeticTree ArithmeticTree+                   | Multiply ArithmeticTree ArithmeticTree+                   | Negate ArithmeticTree+                   | Subtract ArithmeticTree ArithmeticTree+                   | Divide ArithmeticTree ArithmeticTree+                   deriving Eq -instance Arbitrary Factor where-   arbitrary = sized uniform-instance Arbitrary Product where-   arbitrary = sized uniform-instance Arbitrary Sum where-   arbitrary = sized uniform-instance Arbitrary Comparison where-   arbitrary = sized uniform-instance Arbitrary Truth where-   arbitrary = sized uniform-instance Arbitrary Conjunction where-   arbitrary = sized uniform-instance Arbitrary Disjunction where-   arbitrary = sized uniform-instance Arbitrary Conditional where-   arbitrary = sized uniform+data BooleanTree = BooleanConstant Bool+                 | Comparison ArithmeticTree Relation ArithmeticTree+                 | Not BooleanTree+                 | And BooleanTree BooleanTree+                 | Or BooleanTree BooleanTree+                 deriving Eq -instance Enumerable Factor where-   enumerate = unary (Factor . (show :: Word8 -> String))-               <> pay (unary $ Factor . (\s-> "(" <> s <> ")") . productString)+data ConditionalTree a = If BooleanTree (ConditionalTree a) (ConditionalTree a)+                       | Unconditional a+                       deriving Eq -instance Enumerable Product where-   enumerate = unary (Product . factorString)-               <> (Product <$> (\(Free (Product a, Factor b))-> a <> "*" <> b) <$> pay enumerate)-               <> (Product <$> (\(Free (Product a, Factor b))-> a <> "/" <> b) <$> pay enumerate)+newtype Relation = Relation String deriving Eq -instance Enumerable Sum where-   enumerate = unary (Sum . productString)-               <> (Sum <$> (\(Free (Sum a, Product b))-> a <> "+" <> b) <$> pay enumerate)-               <> (Sum <$> (\(Free (Sum a, Product b))-> a <> "-" <> b) <$> pay enumerate)+instance Show ArithmeticTree where+   showsPrec p (Add l r) rest | p < 1 = showsPrec 0 l (" + " <> showsPrec 1 r rest)+   showsPrec p (Subtract l r) rest | p < 1 = showsPrec 0 l (" - " <> showsPrec 1 r rest)+   showsPrec p (Negate e) rest | p < 1 = "- " <> showsPrec 1 e rest+   showsPrec p (Multiply l r) rest | p < 2 = showsPrec 1 l (" * " <> showsPrec 2 r rest)+   showsPrec p (Divide l r) rest | p < 2 = showsPrec 1 l (" / " <> showsPrec 2 r rest)+   showsPrec _ (Number (Nat n)) rest = shows n rest+   showsPrec p e rest = "(" <> showsPrec 0 e (")" <> rest) -instance Enumerable Comparison where-   enumerate = Comparison <$> (((\(Free (Sum a, Sum b))-> a <> "<" <> b) <$> pay enumerate)-                               <> ((\(Free (Sum a, Sum b))-> a <> "<=" <> b) <$> pay enumerate)-                               <> ((\(Free (Sum a, Sum b))-> a <> "==" <> b) <$> pay enumerate)-                               <> ((\(Free (Sum a, Sum b))-> a <> ">=" <> b) <$> pay enumerate)-                               <> ((\(Free (Sum a, Sum b))-> a <> ">" <> b) <$> pay enumerate))+instance Show BooleanTree where+   showsPrec p (Or l r) rest | p < 1 = showsPrec 1 l (" || " <> showsPrec 0 r rest)+   showsPrec p (And l r) rest | p < 2 = showsPrec 2 l (" && " <> showsPrec 1 r rest)+   showsPrec p (Not e) rest | p < 3 = "not " <> showsPrec 3 e rest+   showsPrec p (Comparison l rel r) rest | p < 3 = showsPrec 0 l (" " <> show rel <> " " <> showsPrec 0 r rest)+   showsPrec _ (BooleanConstant b) rest = shows b rest+   showsPrec p e rest = "(" <> showsPrec 0 e (")" <> rest) -instance Enumerable Truth where-   enumerate = Truth <$> (consts [pure "False", pure "True"]-                          <> pay (unary $ ("not " <>) . truthString)-                          <> pay (unary $ (\s-> "(" <> s <> ")") . disjunctionString))+instance Show a => Show (ConditionalTree a) where+   show (Unconditional a) = show a+   show (If test true false) = "if " <> show test <> " then " <> show true <> " else " <> show false -instance Enumerable Conjunction where-   enumerate = unary (Conjunction . truthString)-               <> (Conjunction <$> (\(Free (Conjunction a, Truth b))-> a <> "&&" <> b) <$> pay enumerate)+instance Show Relation where+   show (Relation rel) = rel -instance Enumerable Disjunction where-   enumerate = unary (Disjunction . conjunctionString)-               <> (Disjunction <$> (\(Free (Disjunction a, Conjunction b))-> a <> "||" <> b) <$> pay enumerate)+instance Arithmetic.ArithmeticDomain ArithmeticTree where+   number = Number . Nat+   add = Add+   multiply = Multiply+   negate = Negate+   subtract = Subtract+   divide = Divide -instance Enumerable Conditional where-   enumerate = Conditional-               <$> (\(Free (Disjunction a, Free (Sum b, Sum c)))-> "if " <> a <> " then " <> b <> " else " <> c)-               <$> pay enumerate+instance Boolean.BooleanDomain BooleanTree where+   true = BooleanConstant True+   false = BooleanConstant False+   and = And+   or = Or+   not = Not -uniqueParse :: (Eq s, FactorialMonoid s, Rank2.Apply g, Rank2.Traversable g, Rank2.Distributive g) =>-               Grammar g Parser s -> (forall f. g f -> f r) -> s -> r+instance Comparisons.ComparisonDomain ArithmeticTree BooleanTree where+   lessThan = flip Comparison (Relation "<")+   lessOrEqual = flip Comparison (Relation "<=")+   equal = flip Comparison (Relation "==")+   greaterOrEqual = flip Comparison (Relation ">=")+   greaterThan = flip Comparison (Relation ">")++instance Conditionals.ConditionalDomain BooleanTree (ConditionalTree ArithmeticTree) where+   ifThenElse = If++instance Arbitrary ArithmeticTree where+   arbitrary = sized uniform+instance Arbitrary BooleanTree where+   arbitrary = sized uniform+instance Arbitrary (ConditionalTree ArithmeticTree) where+   arbitrary = sized uniform++instance Enumerable ArithmeticTree where+   enumerate = share (choice $ pay <$> [c1 (Number . (Nat . fromIntegral . nat :: Nat Integer -> Nat Int)), +                                        c2 Add, c2 Multiply, c1 Negate, c2 Subtract, c2 Divide])++instance Enumerable BooleanTree where+   enumerate = share $ choice $ pay <$> [c1 BooleanConstant, c3 Comparison, c2 And, c2 Or]++instance Enumerable a => Enumerable (ConditionalTree a) where+   enumerate = share (pay $ c3 $ \test true false-> If test (Unconditional true) (Unconditional false))++instance Enumerable Relation where+   enumerate = share (choice $ pay . pure . Relation <$> ["<", "<=", "==", ">=", ">"])++uniqueParse :: (Eq s, TextualMonoid s, Rank2.Apply g, Rank2.Traversable g, Rank2.Distributive g) =>+               Grammar g Parser s -> (forall f. g f -> f r) -> s -> Either String r uniqueParse g p s = case getCompose (p $ parseComplete g s)-                    of Right [r] -> r-                       Right [] -> error "Unparseable"-                       Right _ -> error "Ambiguous"-                       Left (ParseFailure pos exp) -> error ("At " <> show pos <> " expected one of " <> show exp)+                    of Right [r] -> Right r+                       Right [] -> Left "Unparseable"+                       Right _ -> Left "Ambiguous"+                       Left err -> Left (showFailure s err 3)  instance Lexical ArithmeticComparisons instance Lexical ArithmeticComparisonsBoolean