diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -23,3 +23,7 @@ ## 1.0.0.1 -- 2021-06-29 * Improved implementation of `oneOf` and `noneOf` to use ranges and not exhaustive character search + +## 1.0.0.2 -- 2021-08-13 + +* Added small optimisation to accomodate new core changes: added `try` for all top-level parsers. diff --git a/benchmarks/BrainfuckBench/Main.hs b/benchmarks/BrainfuckBench/Main.hs --- a/benchmarks/BrainfuckBench/Main.hs +++ b/benchmarks/BrainfuckBench/Main.hs @@ -50,16 +50,16 @@ let bfTest :: NFData rep => (FilePath -> IO rep) -> String -> (rep -> Maybe [BrainFuckOp]) -> Benchmark bfTest = benchmark ["benchmarks/inputs/helloworld.bf", "benchmarks/inputs/helloworld_golfed.bf", "benchmarks/inputs/compiler.bf"] in bgroup "Brainfuck" - [ {-bfTest string "Parsley (Stream)" (brainfuckParsleySS . CharList) - ,-} bfTest string "Happy" BrainfuckBench.Happy.Parser.brainfuck + [ bfTest string "Parsley (Stream)" (brainfuckParsleySS . CharList) , bfTest string "Parsley (String)" brainfuckParsleyS , bfTest text "Parsley (Text)" (brainfuckParsleyT . Text16) - --, bfTest bytestring "Parsley (ByteString)" brainfuckParsleyB + , bfTest bytestring "Parsley (ByteString)" brainfuckParsleyB --, bfTest lazy_bytestring "Parsley (Lazy ByteString)" brainfuckParsleyLB + , bfTest string "Handrolled" BrainfuckBench.Handrolled.Parser.brainfuck + , bfTest string "Happy" BrainfuckBench.Happy.Parser.brainfuck , bfTest string "Parsec (String)" (parsecParse BrainfuckBench.Parsec.Parser.brainfuck) , bfTest text "Parsec (Text)" (parsecParse BrainfuckBench.Parsec.Parser.brainfuck) , bfTest string "Mega (String)" (megaParse BrainfuckBench.Megaparsec.Parser.brainfuck) , bfTest text "Mega (Text)" (megaParse BrainfuckBench.Megaparsec.Parser.brainfuck) , bfTest text "Atto (Text)" (attoParse BrainfuckBench.Attoparsec.Parser.brainfuck) - , bfTest string "Handrolled" BrainfuckBench.Handrolled.Parser.brainfuck ] diff --git a/benchmarks/JavascriptBench/Parsley/Parser.hs b/benchmarks/JavascriptBench/Parsley/Parser.hs --- a/benchmarks/JavascriptBench/Parsley/Parser.hs +++ b/benchmarks/JavascriptBench/Parsley/Parser.hs @@ -10,7 +10,7 @@ import Parsley.Combinator (token, oneOf, noneOf, eof) import Parsley.Fold (skipMany, skipSome, sepBy, sepBy1, pfoldl1, chainl1) import Parsley.Precedence (precedence, monolith, prefix, postfix, infixR, infixL) -import Parsley.Defunctionalized (Defunc(CONS, ID, LIFTED), pattern FLIP_H, pattern COMPOSE_H) +import Parsley.Defunctionalized (Defunc(CONS, ID, LIFTED, LAM_S), pattern FLIP_H, pattern COMPOSE_H) import JavascriptBench.Shared import Data.Char (isSpace, isUpper, digitToInt, isDigit) import Data.Maybe (catMaybes) @@ -93,7 +93,7 @@ conCall = identifier <**> (dot *> (FLIP_H [|JSQual|] <$> conCall) <|> FLIP_H [|JSConCall|] <$> parens (commaSep asgn) - <|> pure (makeQ (\name -> JSConCall name []) [||\name -> JSConCall name []||])) + <|> pure (LAM_S $ \name -> [|JSConCall $name []|])) member :: Parser JSMember member = primaryExpr <**> (FLIP_H [|JSCall|] <$> parens (commaSep asgn) @@ -164,7 +164,7 @@ number :: Defunc Int -> Parser Char -> Parser Int number qbase digit = pfoldl1 addDigit (LIFTED 0) digit where - addDigit = [|\x d -> $(qbase) * x + (digitToInt d)|] + addDigit = [|\x d -> $qbase * x + digitToInt d|] stringLiteral :: Parser String stringLiteral = [|catMaybes|] <$> between (token "\"") (token "\"") (many stringChar) <* whitespace diff --git a/parsley.cabal b/parsley.cabal --- a/parsley.cabal +++ b/parsley.cabal @@ -5,7 +5,7 @@ -- | +------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.0.0.1 +version: 1.0.0.2 synopsis: A fast parser combinator library backed by Typed Template Haskell description: Parsley is a staged selective parser combinator library, which means it does not support monadic operations, and relies on Typed Template @@ -84,11 +84,12 @@ source-repository head type: git - location: https://github.com/j-mie6/HaskellParsley + location: https://github.com/j-mie6/ParsleyHaskell common test-common build-depends: base >=4.10 && <5, parsley, + parsley-core, parsley-garnish, tasty, template-haskell @@ -96,17 +97,24 @@ hs-source-dirs: test default-language: Haskell2010 ghc-options: -fplugin=Parsley.OverloadedQuotesPlugin + other-modules: TestUtils test-suite parsley-test import: test-common type: exitcode-stdio-1.0 build-depends: tasty-hunit, tasty-quickcheck, th-test-utils, deepseq - main-is: ParsleyTest.hs + main-is: Parsley/Tests.hs other-modules: Parsley.Alternative.Test, Parsley.Applicative.Test, Parsley.Combinator.Test, Parsley.Fold.Test, Parsley.Precedence.Test, Parsley.Register.Test, Parsley.Selective.Test, Parsley.Primitive.Test, Parsley.Alternative.Parsers, Parsley.Applicative.Parsers, Parsley.Combinator.Parsers, Parsley.Fold.Parsers, - Parsley.Precedence.Parsers, Parsley.Register.Parsers, Parsley.Selective.Parsers, Parsley.Primitive.Parsers, - TestUtils + Parsley.Precedence.Parsers, Parsley.Register.Parsers, Parsley.Selective.Parsers, Parsley.Primitive.Parsers + +test-suite regression-test + import: test-common + type: exitcode-stdio-1.0 + build-depends: tasty-hunit, tasty-quickcheck, th-test-utils, deepseq + main-is: Regression/Tests.hs + other-modules: Regression.Parsers common benchmark-common build-tool-depends: happy:happy diff --git a/src/ghc/Parsley.hs b/src/ghc/Parsley.hs --- a/src/ghc/Parsley.hs +++ b/src/ghc/Parsley.hs @@ -68,7 +68,7 @@ runParser :: (Trace, Input input) => Parser a -- ^ The parser to be compiled -> Code (input -> Maybe a) -- ^ The generated parsing function -runParser p = [||\input -> $$(eval [||input||] (compile p codeGen))||] +runParser p = [||\input -> $$(eval [||input||] (compile (try p) codeGen))||] {-| This function generates a function that reads input from a file diff --git a/test/Parsley/Fold/Parsers.hs b/test/Parsley/Fold/Parsers.hs --- a/test/Parsley/Fold/Parsers.hs +++ b/test/Parsley/Fold/Parsers.hs @@ -13,7 +13,7 @@ plusOne' = chainPre (try (string "++") $> [|succ|]) (char '1' $> [|1|]) plusOnePure :: Parser Int -plusOnePure = try (chainPre (string "++" $> [|succ|]) (pure ([|1|]))) <|> pure ([|0|]) +plusOnePure = try (chainPre (string "++" $> [|succ|]) (pure [|1|])) <|> pure [|0|] onePlus :: Parser Int onePlus = chainPost (char '1' $> [|1|]) (string "++" $> [|succ|]) diff --git a/test/Parsley/Primitive/Parsers.hs b/test/Parsley/Primitive/Parsers.hs --- a/test/Parsley/Primitive/Parsers.hs +++ b/test/Parsley/Primitive/Parsers.hs @@ -26,3 +26,6 @@ recursive = let r = item <:> r <|> pure EMPTY in r + +lookAheadDigit :: Parser Char +lookAheadDigit = lookAhead digit *> digit diff --git a/test/Parsley/Primitive/Test.hs b/test/Parsley/Primitive/Test.hs --- a/test/Parsley/Primitive/Test.hs +++ b/test/Parsley/Primitive/Test.hs @@ -84,8 +84,14 @@ , testCase "consume more than 1 piece of input with two" $ twoDigits "12" @?= Just '2' ] +lookAheadDigit :: String -> Maybe Char +lookAheadDigit = $$(runParserMocked Parsers.lookAheadDigit [||Parsers.lookAheadDigit||]) + lookAheadTests :: TestTree -lookAheadTests = testGroup "lookAhead should" [] +lookAheadTests = testGroup "lookAhead should" + [ testCase "rollback consumed input" $ lookAheadDigit "9" @?= Just '9' + , testCase "fail when given no input when expected" $ lookAheadDigit "" @?= Nothing + ] notFollowedByTests :: TestTree notFollowedByTests = testGroup "notFollowedBy should" [] diff --git a/test/Parsley/Tests.hs b/test/Parsley/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Parsley/Tests.hs @@ -0,0 +1,24 @@ +module Main where +import Test.Tasty +import qualified Parsley.Alternative.Test as Alternative +import qualified Parsley.Applicative.Test as Applicative +import qualified Parsley.Combinator.Test as Combinator +import qualified Parsley.Fold.Test as Fold +import qualified Parsley.Precedence.Test as Precedence +import qualified Parsley.Primitive.Test as Primitive +import qualified Parsley.Register.Test as Register +import qualified Parsley.Selective.Test as Selective + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Parsley Tests" [ Primitive.tests + , Alternative.tests + , Applicative.tests + , Combinator.tests + , Fold.tests + , Precedence.tests + , Register.tests + , Selective.tests + ] diff --git a/test/ParsleyTest.hs b/test/ParsleyTest.hs deleted file mode 100644 --- a/test/ParsleyTest.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Main where -import Test.Tasty -import qualified Parsley.Alternative.Test as Alternative -import qualified Parsley.Applicative.Test as Applicative -import qualified Parsley.Combinator.Test as Combinator -import qualified Parsley.Fold.Test as Fold -import qualified Parsley.Precedence.Test as Precedence -import qualified Parsley.Primitive.Test as Primitive -import qualified Parsley.Register.Test as Register -import qualified Parsley.Selective.Test as Selective - -main :: IO () -main = defaultMain tests - -tests :: TestTree -tests = testGroup "Parsley Tests" [ Primitive.tests - , Alternative.tests - , Applicative.tests - , Combinator.tests - , Fold.tests - , Precedence.tests - , Register.tests - , Selective.tests - ] diff --git a/test/Regression/Parsers.hs b/test/Regression/Parsers.hs new file mode 100644 --- /dev/null +++ b/test/Regression/Parsers.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +module Regression.Parsers where + +import Prelude hiding (pure, (<*>), (*>), (<*)) +import Data.Char (isDigit) +import Parsley +import Parsley.Combinator (token) +--import Parsley.Garnish + +issue26_ex1 :: Parser () +issue26_ex1 = (token "123" <|> token "") *> void (token "abc") + +issue26_ex2 :: Parser () +issue26_ex2 = (token "123" <|> token "45") *> void (token "abc") diff --git a/test/Regression/Tests.hs b/test/Regression/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Regression/Tests.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell, UnboxedTuples, ScopedTypeVariables, TypeApplications #-} +module Main where +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils +import qualified Regression.Parsers as Parsers + +import Parsley (runParser) +import Parsley.InputExtras (CharList(..)) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Regression Tests" [ issue26 ] + +issue26 :: TestTree +issue26 = testGroup "#26 Coin draining on bindings is wrong" + [ testCase "" $ issue26_ex1 (CharList "123ab") @?= Nothing + , testCase "" $ issue26_ex2 (CharList "123ab") @?= Nothing + ] + +issue26_ex1 :: CharList -> Maybe () +issue26_ex1 = $$(Parsley.runParser Parsers.issue26_ex1) + +issue26_ex2 :: CharList -> Maybe () +issue26_ex2 = $$(Parsley.runParser Parsers.issue26_ex2) diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE TemplateHaskell, TypeApplications, DeriveAnyClass, StandaloneDeriving, CPP, FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell, TypeApplications, DeriveAnyClass, StandaloneDeriving, CPP, FlexibleInstances, MonoLocalBinds #-} module TestUtils where import Parsley (runParser, Parser, Code) ---import Parsley.Internal.Verbose () -import Language.Haskell.TH.Syntax +import Parsley.Internal.Trace (Trace) +import Language.Haskell.TH.Syntax #if MIN_VERSION_template_haskell(2,17,0) hiding (Code) #endif @@ -21,7 +21,7 @@ #endif -- TODO Use WQ: requires lift plugin to not require any Lift instance for variables (if missing) -runParserMocked :: Parser a -> Code (Parser a) -> Code (String -> Maybe a) +runParserMocked :: Trace => Parser a -> Code (Parser a) -> Code (String -> Maybe a) runParserMocked p qp = [|| \s -> runParserMocked' $$qp `deepseq` $$(runParser p) s ||]