fixed a couple of bugs

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

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}
 
 {-|

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

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
 

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"

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)