diff --git a/parsley-core/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs b/parsley-core/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs index 5a7fc8f8..7398679f 100644 --- a/parsley-core/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +++ b/parsley-core/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs @@ -171,11 +171,12 @@ evalIter :: (RecBuilder o, PositionOps (StaRep o), HandlerOps o, DynOps o) evalIter μ l h = freshUnique $ \u1 -> -- This one is used for the handler's offset from point of failure freshUnique $ \u2 -> -- This one is used for the handler's check and loop offset - case h of - Always gh (Machine h) -> - liftM2 (\mh ctx γ -> bindIterAlways ctx μ l gh (buildHandler γ mh u1) (input γ) u2) h ask - Same gyes (Machine yes) gno (Machine no) -> - liftM3 (\myes mno ctx γ -> bindIterSame ctx μ l gyes (buildIterYesHandler γ myes u1) gno (buildHandler γ mno u1) (input γ) u2) yes no ask + local voidCoins $ -- We must not allow factored input to pass through to iterative handlers, they have rolling inputs + case h of + Always gh (Machine h) -> + liftM2 (\mh ctx γ -> bindIterAlways ctx μ l gh (buildHandler γ mh u1) (input γ) u2) h ask + Same gyes (Machine yes) gno (Machine no) -> + liftM3 (\myes mno ctx γ -> bindIterSame ctx μ l gyes (buildIterYesHandler γ myes u1) gno (buildHandler γ mno u1) (input γ) u2) yes no ask evalJoin :: (DynOps o, ?flags :: Opt.Flags) => ΦVar x -> MachineMonad s o (x : xs) n r a evalJoin φ = askΦ φ <&> resume diff --git a/parsley-core/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs b/parsley-core/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs index 92c0473b..cd79c5e0 100644 --- a/parsley-core/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs +++ b/parsley-core/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs @@ -66,7 +66,7 @@ import Data.Maybe (fromMaybe, isNothing) import Parsley.Internal.Backend.Machine.Defunc (Defunc) import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΣVar(..), ΦVar, IMVar, IΣVar) import Parsley.Internal.Backend.Machine.LetBindings (Regs(..)) -import Parsley.Internal.Backend.Machine.Types.Coins (Coins(willConsume)) +import Parsley.Internal.Backend.Machine.Types.Coins (Coins(Coins, willConsume)) import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynSubroutine) import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset) import Parsley.Internal.Backend.Machine.Types.Statics (QSubroutine(..), StaFunc, StaSubroutine, StaCont) @@ -348,6 +348,7 @@ broken. @since 1.5.0.0 -} storePiggy :: Coins -> Ctx s o a -> Ctx s o a +storePiggy (Coins 0 _ _) ctx = ctx storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx), netWorth = netWorth ctx + willConsume coins} {-| diff --git a/parsley-core/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs b/parsley-core/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs index 9cdcd3b1..d3045fd8 100644 --- a/parsley-core/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +++ b/parsley-core/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs @@ -53,11 +53,12 @@ codeGen :: (Trace, ?flags :: Opt.Flags) codeGen letBound p rs μ0 = trace ("GENERATING " ++ name ++ ": " ++ show p ++ "\nMACHINE: " ++ show (elems rs) ++ " => " ++ show m) $ makeLetBinding m rs newMeta where name = maybe "TOP LEVEL" show letBound - addCoinsTop = maybe addCoinsNeeded (const id) letBound + --addCoinsTop = maybe addCoinsNeeded (const id) letBound m = finalise (histo alg p) alg :: Combinator (Cofree Combinator (CodeGen o a)) x -> CodeGen o a x alg = deep |> (\x -> CodeGen (shallow (imap extract x))) - finalise cg = addCoinsTop (runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0) + -- add coins is safe here because if a cut is present it will only factor 1 coin + finalise cg = addCoinsNeeded (runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0) pattern (:<$>:) :: Core.Defunc (a -> b) -> Cofree Combinator k a -> Combinator (Cofree Combinator k) b pattern f :<$>: p <- (_ :< Pure f) :<*>: p diff --git a/parsley/parsley.cabal b/parsley/parsley.cabal index 80077f10..22ecd0f5 100644 --- a/parsley/parsley.cabal +++ b/parsley/parsley.cabal @@ -106,7 +106,7 @@ common test-common default-language: Haskell2010 ghc-options: -pgmP cpphs -optP --cpp other-modules: TestUtils - if false && impl(ghc < 9) + if true && impl(ghc < 9) build-depends: dump-core ghc-options: -fplugin=DumpCore diff --git a/parsley/test/Regression/Parsers.hs b/parsley/test/Regression/Parsers.hs index fead1139..e1931e04 100644 --- a/parsley/test/Regression/Parsers.hs +++ b/parsley/test/Regression/Parsers.hs @@ -7,6 +7,7 @@ import Parsley import Parsley.Char (token) import Parsley.Register (newRegister_, put_, get) import Parsley.Defunctionalized (Defunc(LIFTED)) +import Parsley.Internal.Core.Primitives (loop) issue26_ex1 :: Parser () issue26_ex1 = (token "123" <|> token "") *> void (token "abc") @@ -22,3 +23,8 @@ issue41_ex2 = newRegister_ (LIFTED False) $ \reg -> try ((string "abc" *> get re issue41_ex3 :: Parser Bool issue41_ex3 = newRegister_ (LIFTED False) $ \reg -> try ((string "abc" *> get reg) <|> (put_ reg (LIFTED True) *> item *> get reg)) <|> get reg + +badFactor :: Parser String +badFactor = string "a" + <|> string "uxy" *> loop (void (char 'a')) unit *> string "z" + <|> string "b" diff --git a/parsley/test/Regression/Tests.hs b/parsley/test/Regression/Tests.hs index b19f7e1c..9d1f5dd8 100644 --- a/parsley/test/Regression/Tests.hs +++ b/parsley/test/Regression/Tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell, UnboxedTuples, ScopedTypeVariables, TypeApplications #-} +{-# OPTIONS_GHC -ddump-splices -ddump-to-file #-} module Main where import Test.Tasty import Test.Tasty.HUnit @@ -14,7 +15,7 @@ main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "Regression Tests" [ issue26, issue41 ] +tests = testGroup "Regression Tests" [ issue26, issue41, badFactorTests ] issue26 :: TestTree issue26 = testGroup "#26 Coin draining on bindings is wrong" @@ -37,6 +38,13 @@ issue41 = testGroup "#41 Length-factoring can cross `put` but shouldn't" , testCase "it should prevent factoring" $ issue41_ex3 "abc" @?= Just False ] +badFactorTests :: TestTree +badFactorTests = testGroup "bad factoring within loops" + [ testCase "it should not die in loop" $ badFactor "uxyaz" @?= Just "z" + , testCase "it should still work without a" $ badFactor "uxyz" @?= Just "z" + , testCase "it should fail gracefully on x" $ badFactor "u" @?= Nothing + ] + issue26_ex1 :: String -> Maybe () issue26_ex1 = $$(Parsley.parse Parsers.issue26_ex1) @@ -51,3 +59,6 @@ issue41_ex2 = $$(Parsley.parse Parsers.issue41_ex2) issue41_ex3 :: String -> Maybe Bool issue41_ex3 = $$(Parsley.parse Parsers.issue41_ex3) + +badFactor :: String -> Maybe String +badFactor = $$(Parsley.parse Parsers.badFactor)