parsley-core 1.5.0.0 → 1.6.0.0

raw patch · 15 files changed

+240/−75 lines, 15 filesdep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• README.md +2/−2
• parsley-core.cabal +8/−1
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +1/−0
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs +1/−0
• src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs +5/−4
• src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +13/−16
• src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +45/−28
• src/ghc/Parsley/Internal/Core/CombinatorAST.hs +7/−0
• src/ghc/Parsley/Internal/Frontend/Analysis.hs +2/−2
• src/ghc/Parsley/Internal/Frontend/Analysis/Cut.hs +29/−11
• src/ghc/Parsley/Internal/Frontend/Analysis/Flags.hs +3/−8
• src/ghc/Parsley/Internal/Frontend/Compiler.hs +2/−3
• test/Regression/Issue27.hs +104/−0
• test/RegressionTest.hs +11/−0

@@ -89,3 +89,10 @@ * Added type to `next` in `CharList`. * Added auxilliary information parameter to `sat`. * Added `fetch` and broke it out of `sat`.++## 1.6.0.0 -- 2021-08-13+Fix for issue #27++* Added `BlockCoins` instruction and `CutImmune` node.+* Changed how cut compliance is determined, and stopped some incorrect factoring.+* Removed unneeded flags for analysis.

@@ -1,8 +1,8 @@ # Parsley Internals -This package contains the internals for the [`parsley`](https://hackage.haskell.org/package/parsley-core) library. +This package contains the internals for the [`parsley`](https://hackage.haskell.org/package/parsley) library. -The version policy adheres to the regular Haskell PVP, but the two major versions are distinguished: +The version policy adheres to the regular Haskell PVP, but the two major versions are distinguished: the first is the _Public API_ major version, which represents backwards incompatible changes in the regular PVP sense that effect the `parsley` package itself and its users; the second version is the _Internal API_ major version, which would only effect users who use part of the internal parsley

@@ -5,7 +5,7 @@ --                   | +------- breaking internal API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.5.0.0+version:             1.6.0.0 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         This package contains the internals of the @parsley@ package.                      .@@ -167,6 +167,13 @@   build-depends:       tasty-hunit, tasty-quickcheck   main-is:             CommonTest.hs   other-modules:       CommonTest.Queue, CommonTest.RewindQueue++test-suite regression-test+  import:              test-common+  type:                exitcode-stdio-1.0+  build-depends:       tasty-hunit, tasty-quickcheck, containers+  main-is:             RegressionTest.hs+  other-modules:       Regression.Issue27  source-repository head   type:                git

@@ -249,3 +249,4 @@     mkCheck True  k = local (giveCoins (int 1)) k <&> \mk γ -> emitLengthCheck 1 (mk γ) (raise γ) (input γ)     mkCheck False k = k     prefetch o ctx k = fetch o (\c o' -> k (addChar c o' ctx))+evalMeta BlockCoins (Machine k) = k

@@ -203,3 +203,4 @@      if | not check     -> k         | requiresPiggy -> local (storePiggy 1) k         | otherwise     -> local (giveCoins 1) k <&> \mk γ -> emitLengthCheck 1 mk (raise γ) γ+evalMeta BlockCoins (Machine k) = k

@@ -28,8 +28,8 @@ first :: (a -> b) -> (a, x) -> (b, x) first = flip bimap id -second :: (a -> b) -> (x, a) -> (x, b)-second = bimap id+--second :: (a -> b) -> (x, a) -> (x, b)+--second = bimap id  bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) bimap = curry (bilift2 ($) ($))@@ -72,9 +72,10 @@ alg (LogExit _ k)                           = getConst4 k alg (MetaInstr (AddCoins _) (Const4 k))     = k alg (MetaInstr (RefundCoins n) (Const4 k))  = first (minCoins zero . (`minus` n)) k -- These were refunded, so deduct-alg (MetaInstr (DrainCoins _) (Const4 k))   = second (const False) k-alg (MetaInstr (GiveBursary n) (Const4 _))  = (n, False)                            -- We know that `n` is the required for `k`+alg (MetaInstr (DrainCoins n) _)            = (n, False)                            -- Used to be `second (const False) k`, but these should be additive?+alg (MetaInstr (GiveBursary n) _)           = (n, False)                            -- We know that `n` is the required for `k` alg (MetaInstr (PrefetchChar _) (Const4 k)) = k+alg (MetaInstr BlockCoins (Const4 k))       = first (const zero) k  algHandler :: Handler o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool) algHandler (Same yes no) = algCatch (getConst4 yes) (getConst4 no)

@@ -14,12 +14,11 @@ -} module Parsley.Internal.Backend.CodeGenerator (codeGen) where -import Data.Maybe                          (isJust) import Data.Set                            (Set, elems) import Control.Monad.Trans                 (lift) import Parsley.Internal.Backend.Machine    (user, userBool, LetBinding, makeLetBinding, newMeta, Instr(..), Handler(..),                                             _Fmap, _App, _Modify, _Get, _Put, _Make,-                                            addCoins, refundCoins, drainCoins, giveBursary,+                                            addCoins, refundCoins, drainCoins, giveBursary, blockCoins,                                             minus, minCoins, maxCoins, zero,                                             IMVar, IΦVar, IΣVar, MVar(..), ΦVar(..), ΣVar(..), SomeΣVar) import Parsley.Internal.Backend.Analysis   (coinsNeeded)@@ -57,12 +56,9 @@     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 =-      let m = runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0 σ0-      -- let-bound things are not safe to factor length checks out of-      -- This is because we do not know the cut characteristics of every caller-      -- In theory this /could/ be computed as the union of every call site-      in if isJust letBound then m else addCoins (coinsNeeded m) m+    -- It is never safe to add coins to the top of a binding+    -- This is because we don't know the characteristics of the caller (even the top-level!)+    finalise cg = runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0 σ0  pattern (:<$>:) :: Core.Defunc (a -> b) -> Cofree Combinator k a -> Combinator (Cofree Combinator k) b pattern f :<$>: p <- (_ :< Pure f) :<*>: p@@ -163,14 +159,15 @@      let minc = coinsNeeded (In4 (Choices (map userBool fs) qcs defc))      let defc':qcs' = map (maxCoins zero . (`minus` minc) . coinsNeeded >>= addCoins) (defc:qcs)      fmap binder (runCodeGen p (In4 (Choices (map user fs) qcs' defc')))-shallow (Let _ μ _)            m = do return $! tailCallOptimise μ m-shallow (ChainPre op p)        m = do chainPreCompile op p addCoinsNeeded id m-shallow (ChainPost p op)       m = do chainPostCompile p op addCoinsNeeded id m-shallow (MakeRegister σ p q)   m = do qc <- runCodeGen q m; runCodeGen p (In4 (_Make σ qc))-shallow (GetRegister σ)        m = do return $! In4 (_Get σ m)-shallow (PutRegister σ p)      m = do runCodeGen p (In4 (_Put σ (In4 (Push (user UNIT) m))))-shallow (Debug name p)         m = do fmap (In4 . LogEnter name) (runCodeGen p (In4 (Commit (In4 (LogExit name m)))))-shallow (MetaCombinator Cut p) m = do runCodeGen p (addCoins (coinsNeeded m) m)+shallow (Let _ μ _)                  m = do return $! tailCallOptimise μ m+shallow (ChainPre op p)              m = do chainPreCompile op p addCoinsNeeded id m+shallow (ChainPost p op)             m = do chainPostCompile p op addCoinsNeeded id m+shallow (MakeRegister σ p q)         m = do qc <- runCodeGen q m; runCodeGen p (In4 (_Make σ qc))+shallow (GetRegister σ)              m = do return $! In4 (_Get σ m)+shallow (PutRegister σ p)            m = do runCodeGen p (In4 (_Put σ (In4 (Push (user UNIT) m))))+shallow (Debug name p)               m = do fmap (In4 . LogEnter name) (runCodeGen p (In4 (Commit (In4 (LogExit name m)))))+shallow (MetaCombinator Cut p)       m = do blockCoins <$> runCodeGen p (addCoins (coinsNeeded m) m)+shallow (MetaCombinator CutImmune p) m = do addCoins . coinsNeeded <$> runCodeGen p (In4 Ret) <*> runCodeGen p m  tailCallOptimise :: MVar x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a tailCallOptimise μ (In4 Ret) = In4 (Jump μ)

@@ -24,7 +24,7 @@     -- * Smart Instructions     _App, _Fmap, _Modify, _Make, _Put, _Get,     -- * Smart Meta-Instructions-    addCoins, refundCoins, drainCoins, giveBursary, prefetchChar+    addCoins, refundCoins, drainCoins, giveBursary, prefetchChar, blockCoins   ) where  import Data.Kind                                    (Type)@@ -260,7 +260,13 @@    @since 1.5.0.0 -}   PrefetchChar :: Bool -> MetaInstr (Succ n)+  {-|+  True meta instruction: does /nothing/ except for reset coin count during coin analysis. +  @since 1.6.0.0+  -}+  BlockCoins :: MetaInstr n+ mkCoin :: (Coins -> MetaInstr n) -> Coins -> Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a mkCoin _    (Coins 0 0) = id mkCoin meta n           = In4 . MetaInstr (meta n)@@ -271,7 +277,8 @@ @since 1.5.0.0 -} addCoins :: Coins -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-addCoins = mkCoin AddCoins+addCoins (Coins 1 1) = id+addCoins coins       = mkCoin AddCoins coins  {-| Smart-constuctor around `RefundCoins`.@@ -300,12 +307,20 @@ {-| Smart-constructor around `PrefetchChar`. -@since 1.5.0.0 +@since 1.5.0.0 -} prefetchChar :: Bool -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a prefetchChar check = In4 . MetaInstr (PrefetchChar check)  {-|+Smart-constructor around `PrefetchChar`.++@since 1.6.0.0+-}+blockCoins :: Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a+blockCoins = In4 . MetaInstr BlockCoins++{-| Applies a value on the top of the stack to a function on the second-most top of the stack.  @since 1.0.0.0@@ -389,31 +404,32 @@   show = ($ "") . getConst4 . cata4 (Const4 . alg)     where       alg :: forall xs n r a. Instr o (Const4 (String -> String)) xs n r a -> String -> String-      alg Ret                 = "Ret"-      alg (Call μ k)          = "(Call " . shows μ . " " . getConst4 k . ")"-      alg (Jump μ)            = "(Jump " . shows μ . ")"-      alg (Push x k)          = "(Push " . shows x . " " . getConst4 k . ")"-      alg (Pop k)             = "(Pop " . getConst4 k . ")"-      alg (Lift2 f k)         = "(Lift2 " . shows f . " " . getConst4 k . ")"-      alg (Sat f k)           = "(Sat " . shows f . " " . getConst4 k . ")"-      alg Empt                = "Empt"-      alg (Commit k)          = "(Commit " . getConst4 k . ")"-      alg (Catch p h)         = "(Catch " . getConst4 p . " " . shows h . ")"-      alg (Tell k)            = "(Tell " . getConst4 k . ")"-      alg (Seek k)            = "(Seek " . getConst4 k . ")"-      alg (Case p q)          = "(Case " . getConst4 p . " " . getConst4 q . ")"-      alg (Choices fs ks def) = "(Choices " . shows fs . " [" . intercalateDiff ", " (map getConst4 ks) . "] " . getConst4 def . ")"-      alg (Iter μ l h)        = "{Iter " . shows μ . " " . getConst4 l . " " . shows h . "}"-      alg (Join φ)            = shows φ-      alg (MkJoin φ p k)      = "(let " . shows φ . " = " . getConst4 p . " in " . getConst4 k . ")"-      alg (Swap k)            = "(Swap " . getConst4 k . ")"-      alg (Dup k)             = "(Dup " . getConst4 k . ")"-      alg (Make σ a k)        = "(Make " . shows σ . " " . shows a . " " . getConst4 k . ")"-      alg (Get σ a k)         = "(Get " . shows σ . " " . shows a . " " . getConst4 k . ")"-      alg (Put σ a k)         = "(Put " . shows σ . " " . shows a . " " . getConst4 k . ")"-      alg (LogEnter _ k)      = getConst4 k-      alg (LogExit _ k)       = getConst4 k-      alg (MetaInstr m k)     = "[" . shows m . "] " . getConst4 k+      alg Ret                      = "Ret"+      alg (Call μ k)               = "(Call " . shows μ . " " . getConst4 k . ")"+      alg (Jump μ)                 = "(Jump " . shows μ . ")"+      alg (Push x k)               = "(Push " . shows x . " " . getConst4 k . ")"+      alg (Pop k)                  = "(Pop " . getConst4 k . ")"+      alg (Lift2 f k)              = "(Lift2 " . shows f . " " . getConst4 k . ")"+      alg (Sat f k)                = "(Sat " . shows f . " " . getConst4 k . ")"+      alg Empt                     = "Empt"+      alg (Commit k)               = "(Commit " . getConst4 k . ")"+      alg (Catch p h)              = "(Catch " . getConst4 p . " " . shows h . ")"+      alg (Tell k)                 = "(Tell " . getConst4 k . ")"+      alg (Seek k)                 = "(Seek " . getConst4 k . ")"+      alg (Case p q)               = "(Case " . getConst4 p . " " . getConst4 q . ")"+      alg (Choices fs ks def)      = "(Choices " . shows fs . " [" . intercalateDiff ", " (map getConst4 ks) . "] " . getConst4 def . ")"+      alg (Iter μ l h)             = "{Iter " . shows μ . " " . getConst4 l . " " . shows h . "}"+      alg (Join φ)                 = shows φ+      alg (MkJoin φ p k)           = "(let " . shows φ . " = " . getConst4 p . " in " . getConst4 k . ")"+      alg (Swap k)                 = "(Swap " . getConst4 k . ")"+      alg (Dup k)                  = "(Dup " . getConst4 k . ")"+      alg (Make σ a k)             = "(Make " . shows σ . " " . shows a . " " . getConst4 k . ")"+      alg (Get σ a k)              = "(Get " . shows σ . " " . shows a . " " . getConst4 k . ")"+      alg (Put σ a k)              = "(Put " . shows σ . " " . shows a . " " . getConst4 k . ")"+      alg (LogEnter _ k)           = getConst4 k+      alg (LogExit _ k)            = getConst4 k+      alg (MetaInstr BlockCoins k) = getConst4 k+      alg (MetaInstr m k)          = "[" . shows m . "] " . getConst4 k  instance Show (Handler o (Const4 (String -> String)) (o : xs) n r a) where   show (Same yes no) = "(Dup (Tell (Lift2 same (If " (getConst4 yes (" " (getConst4 no "))))")))@@ -425,3 +441,4 @@   show (DrainCoins n)   = "Using " ++ show n ++ " coins"   show (GiveBursary n)  = "Bursary of " ++ show n ++ " coins"   show (PrefetchChar b) = "Prefetch character " ++ (if b then "with" else "without") ++ " length-check"+  show BlockCoins       = ""

@@ -50,8 +50,14 @@ newtype Reg (r :: Type) a = Reg (ΣVar a)  data MetaCombinator where+  -- | After this combinator exits, a cut has happened   Cut         :: MetaCombinator+  -- | This combinator requires a cut from below to respect parsec semantics   RequiresCut :: MetaCombinator+  -- | This combinator denotes that within its scope, cut semantics are not enforced+  -- +  -- @since 1.6.0.0+  CutImmune   :: MetaCombinator  -- Instances instance IFunctor Combinator where@@ -107,6 +113,7 @@ instance Show MetaCombinator where   show Cut = "coins after"   show RequiresCut = "requires cut"+  show CutImmune = "immune to cuts"  {-# INLINE traverseCombinator #-} traverseCombinator :: Applicative m => (forall a. f a -> m (k a)) -> Combinator f a -> m (Combinator k a)

@@ -19,7 +19,7 @@ import Parsley.Internal.Frontend.Analysis.Cut          (cutAnalysis) import Parsley.Internal.Frontend.Analysis.Dependencies (dependencyAnalysis) -import Parsley.Internal.Frontend.Analysis.Flags as Flags (emptyFlags, AnalysisFlags(letBound))+import Parsley.Internal.Frontend.Analysis.Flags as Flags (emptyFlags, AnalysisFlags)  {-| Performs Cut-Analysis on the combinator tree (See "Parsley.Internal.Frontend.Analysis.Cut")@@ -27,4 +27,4 @@ @since 1.5.0.0 -} analyse :: AnalysisFlags -> Fix Combinator a -> Fix Combinator a-analyse flags = cutAnalysis (letBound flags)+analyse _ = cutAnalysis

@@ -25,9 +25,8 @@  @since 1.5.0.0 -}-cutAnalysis :: Bool -- ^ Whether or not the parser in question is a let-bound parser.-            -> Fix Combinator a -> Fix Combinator a-cutAnalysis letBound = fst . ($ letBound) . doCut . zygo (CutAnalysis . cutAlg) compliance+cutAnalysis :: Fix Combinator a -> Fix Combinator a+cutAnalysis = fst . ($ True) . doCut . zygo (CutAnalysis . cutAlg) compliance  data Compliance (k :: Type) = DomComp | NonComp | Comp | FullPure deriving stock (Show, Eq) newtype CutAnalysis a = CutAnalysis { doCut :: Bool -> (Fix Combinator a, Bool) }@@ -75,11 +74,24 @@ cutAlg (Satisfy f) cut = (mkCut cut (In (Satisfy f)), True) cutAlg Empty _ = (In Empty, False) cutAlg (Let r μ p) cut = (mkCut (not cut) (In (Let r μ (fst (doCut (ifst p) True)))), False) -- If there is no cut, we generate a piggy for the continuation-cutAlg (Try p) _ = False <$ rewrap Try False (ifst p)-cutAlg ((p :*: NonComp) :<|>: (q :*: FullPure)) _ = (requiresCut (In (fst (doCut p True) :<|>: fst (doCut q False))), True)+cutAlg (Try p) cut = (In (Try (mkImmune cut (fst (doCut (ifst p) False)))), False)+-- Special case of below, but we know immunity is useless within `q`+cutAlg ((p :*: NonComp) :<|>: (q :*: FullPure)) _ = (requiresCut (In (fst (doCut p True) :<|>: fst (doCut q False))), False)+-- both branches have to handle a cut, if `p` fails having consumed input that satisfies a cut+-- but if it doesn't, then `q` will need to handle the cut instead. When `q` has no cut to handle,+-- then that means it is immune to cuts, which is handy!+cutAlg ((p :*: NonComp) :<|>: q) cut =+  let (p', handled) = doCut p True+      (q', handled') = doCut (ifst q) cut+  in (requiresCut (In (p' :<|>: mkImmune (not cut) q')), handled && handled')+-- Why cut in both branches? Good question+-- The point here is that, even though `p` doesn't require a cut, this will enable an immunity+-- allowing for internal factoring  of input. However, if we are not under a cut requirement, we'd+-- like this input to be factored out further. cutAlg (p :<|>: q) cut =-  let (q', handled) = doCut (ifst q) cut-  in (In (fst (doCut (ifst p) False) :<|>: q'), handled)+  let (p', handled) = doCut (ifst p) cut+      (q', handled') = doCut (ifst q) cut+  in (In (p' :<|>: q'), handled && handled') cutAlg (l :<*>: r) cut = seqCutAlg (:<*>:) cut (ifst l) (ifst r) cutAlg (l :<*: r) cut = seqCutAlg (:<*:) cut (ifst l) (ifst r) cutAlg (l :*>: r) cut = seqCutAlg (:*>:) cut (ifst l) (ifst r)@@ -88,16 +100,18 @@ cutAlg (Debug msg p) cut = rewrap (Debug msg) cut (ifst p) cutAlg (ChainPre (op :*: NonComp) p) _ =   let (op', _) = doCut op True-      (p', _) = doCut (ifst p) False-  in (requiresCut (In (ChainPre op' p')), True)+      (p', handled) = doCut (ifst p) False+  -- the loop could terminate having read no `op`s, so only `p` can decide if its handled.+  in (requiresCut (In (ChainPre op' p')), handled) cutAlg (ChainPre op p) cut =   let (op', _) = doCut (ifst op) False       (p', handled) = doCut (ifst p) cut   in (mkCut (not cut) (In (ChainPre op' p')), handled) cutAlg (ChainPost p (op :*: NonComp)) cut =-  let (p', _) = doCut (ifst p) cut+  let (p', handled) = doCut (ifst p) cut       (op', _) = doCut op True-  in (requiresCut (In (ChainPost p' op')), True)+  -- the loop could terminate having read no `op`s, so only `p` can decide if its handled.+  in (requiresCut (In (ChainPost p' op')), handled) cutAlg (ChainPost p op) cut =   let (p', handled) = doCut (ifst p) cut       (op', _) = doCut (ifst op) False@@ -120,6 +134,10 @@ mkCut :: Bool -> Fix Combinator a -> Fix Combinator a mkCut True = In . MetaCombinator Cut mkCut False = id++mkImmune :: Bool -> Fix Combinator a -> Fix Combinator a+mkImmune True = In . MetaCombinator CutImmune+mkImmune False = id  requiresCut :: Fix Combinator a -> Fix Combinator a requiresCut = In . MetaCombinator RequiresCut

@@ -9,20 +9,15 @@  @since 1.5.0.0 -}-module Parsley.Internal.Frontend.Analysis.Flags (AnalysisFlags(letBound), emptyFlags) where+module Parsley.Internal.Frontend.Analysis.Flags (AnalysisFlags, emptyFlags) where  {-| The packaged flags object.  @since 1.5.0.0 -}-newtype AnalysisFlags = AnalysisFlags {-  {-|-  Is the binding used in this analysis let-bound?+data AnalysisFlags = AnalysisFlags { -  @since 1.5.0.0-  -}-  letBound :: Bool }  {-|@@ -31,4 +26,4 @@ @since 1.5.0.0 -} emptyFlags :: AnalysisFlags-emptyFlags = AnalysisFlags False+emptyFlags = AnalysisFlags {}

@@ -25,7 +25,6 @@ import Data.HashSet                        (HashSet) import Data.IORef                          (IORef, newIORef, readIORef, writeIORef) import Data.Kind                           (Type)-import Data.Maybe                          (isJust) import Data.Set                            (Set) import Control.Arrow                       (first, second) import Control.Monad                       (void, when)@@ -40,7 +39,7 @@ import Parsley.Internal.Common.Indexed     (Fix(In), cata, cata', IFunctor(imap), (:+:)(..), (\/), Const1(..)) import Parsley.Internal.Common.State       (State, get, gets, runState, execState, modify', MonadState) import Parsley.Internal.Frontend.Optimiser (optimise)-import Parsley.Internal.Frontend.Analysis  (analyse, emptyFlags, letBound, dependencyAnalysis)+import Parsley.Internal.Frontend.Analysis  (analyse, emptyFlags, dependencyAnalysis) import Parsley.Internal.Trace              (Trace(trace)) import System.IO.Unsafe                    (unsafePerformIO) @@ -71,7 +70,7 @@     freeRegs = maybe Set.empty (\(MVar v) -> frs Map.! v)      codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x-    codeGen' letBound p = codeGen letBound (analyse (emptyFlags {letBound = isJust letBound}) p) (freeRegs letBound) (maxV + 1) (maxΣ + 1)+    codeGen' letBound p = codeGen letBound (analyse emptyFlags p) (freeRegs letBound) (maxV + 1) (maxΣ + 1)  preprocess :: Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar) preprocess p =

@@ -0,0 +1,104 @@+{-# LANGUAGE GADTs, MultiParamTypeClasses #-}+module Regression.Issue27 where++import Prelude hiding (pure, (*>))++import Test.Tasty+import Test.Tasty.HUnit++import Parsley.Internal+import Parsley.Internal.Core.CombinatorAST (Parser(unParser), Combinator)+import Parsley.Internal.Common (Fix(In), Fix4(In4), cata, (\/))+import Parsley.Internal.Backend.CodeGenerator (codeGen)+import Parsley.Internal.Backend.Machine.LetBindings (Binding, body)+import Parsley.Internal.Backend.Machine.Types.Coins (willConsume)+import Parsley.Internal.Backend.Machine.Instructions+import Parsley.Internal.Frontend.Analysis.Cut (cutAnalysis)++import qualified Data.Set as Set (empty)++import Parsley.Internal.Verbose+--instance {-# INCOHERENT #-} Trace where trace = const id++-- Hand optimised version of string, so we don't have to run the frontend+string :: String -> Parser String+string str = foldr (\c p -> satisfy (EQ_H (LIFTED c)) *> p) (pure (LIFTED str)) str++-- No registers allowed!+toAST :: Parser a -> Fix Combinator a+toAST = cata (In \/ undefined) . unParser++codeGen' :: Fix Combinator a -> Binding o a a+codeGen' p = body (codeGen Nothing p Set.empty 0 0)++ex1_p :: Fix Combinator String+ex1_p = toAST $ try $ string "123" <|> string "45"++ex2_p :: Fix Combinator String+ex2_p = toAST $ try $ try (string "123") <|> string "45"++ex3_p :: Fix Combinator String+ex3_p = toAST $ string "123" <|> string "45"++ex4_p :: Fix Combinator String+ex4_p = toAST $ try (string "123") <|> try (string "45")++ex5_p :: Fix Combinator String+ex5_p = toAST $ (string "a" <|> pure (LIFTED "")) *> string "1234"++ex6_p :: Fix Combinator String+ex6_p = toAST $ (string "abc" <|> string "def") *> string "123"++ex7_p :: Fix Combinator String+ex7_p = toAST $ (string "abc" <|> string "123") *> string "..." <|> string "def"++ex8_p :: Fix Combinator String+ex8_p = toAST $ (try (string "abc") <|> string "ade") *> string "..." <|> string "def"++leadingCoinsUnderCatch :: Fix4 (Instr o) xs n r a -> Maybe Int+leadingCoinsUnderCatch (In4 (Catch (In4 (MetaInstr (AddCoins c) _)) _)) = Just (willConsume c)+leadingCoinsUnderCatch _ = Nothing++leadingCoins :: Fix4 (Instr o) xs n r a -> Maybe Int+leadingCoins (In4 (MetaInstr (AddCoins c) _)) = Just (willConsume c)+leadingCoins _ = Nothing++test1 :: Assertion+test1 = let coins = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex1_p))+        in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins++test2 :: Assertion+test2 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex2_p)) @?= Just 2++test3 :: Assertion+test3 = let coins = leadingCoins (codeGen' (cutAnalysis ex3_p))+        in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins++test4 :: Assertion+test4 = let coins = leadingCoins (codeGen' (cutAnalysis ex4_p))+        in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins++test5 :: Assertion+test5 = let coins = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex5_p))+        in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins++test6 :: Assertion+test6 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex6_p)) @?= Nothing++test7 :: Assertion+test7 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex7_p)) @?= Nothing++test8 :: Assertion+test8 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex8_p)) @?= Nothing++tests :: TestTree+tests = testGroup "#27 Input checks in `Frontend` and `Backend` are not properly respecting cuts"+  [ testCase "under try max 1 coins should be factored without try" test1+  , testCase "under try 2 coins should be factored with try" test2+  , testCase "max 1 coins should be factored without try" test3+  , testCase "max 1 coins should be factored with try" test4+  --, testCase "" test5+  --, testCase "" test6+  --, testCase "" test7+  --, testCase "" test8+  ]

@@ -0,0 +1,11 @@+module Main where++import Test.Tasty+import qualified Regression.Issue27 as Issue27++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Regression Tests" [ Issue27.tests+                                     ]