diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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` diff --git a/examples/Boolean.hs b/examples/Boolean.hs --- a/examples/Boolean.hs +++ b/examples/Boolean.hs @@ -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) diff --git a/grammatical-parsers.cabal b/grammatical-parsers.cabal --- a/grammatical-parsers.cabal +++ b/grammatical-parsers.cabal @@ -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 diff --git a/src/Text/Grampa.hs b/src/Text/Grampa.hs --- a/src/Text/Grampa.hs +++ b/src/Text/Grampa.hs @@ -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 diff --git a/src/Text/Grampa/Class.hs b/src/Text/Grampa/Class.hs --- a/src/Text/Grampa/Class.hs +++ b/src/Text/Grampa/Class.hs @@ -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) diff --git a/src/Text/Grampa/ContextFree/LeftRecursive.hs b/src/Text/Grampa/ContextFree/LeftRecursive.hs --- a/src/Text/Grampa/ContextFree/LeftRecursive.hs +++ b/src/Text/Grampa/ContextFree/LeftRecursive.hs @@ -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 diff --git a/src/Text/Grampa/ContextFree/SortedMemoizing.hs b/src/Text/Grampa/ContextFree/SortedMemoizing.hs --- a/src/Text/Grampa/ContextFree/SortedMemoizing.hs +++ b/src/Text/Grampa/ContextFree/SortedMemoizing.hs @@ -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 (<|>) #-} diff --git a/src/Text/Grampa/Internal.hs b/src/Text/Grampa/Internal.hs --- a/src/Text/Grampa/Internal.hs +++ b/src/Text/Grampa/Internal.hs @@ -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 [] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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) diff --git a/test/Test/Ambiguous.hs b/test/Test/Ambiguous.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ambiguous.hs @@ -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) diff --git a/test/Test/Examples.hs b/test/Test/Examples.hs --- a/test/Test/Examples.hs +++ b/test/Test/Examples.hs @@ -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