parsley-core 1.7.0.0 → 1.7.1.0

raw patch · 12 files changed

+197/−304 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−3
• parsley-core.cabal +1/−1
• src/ghc/Parsley/Internal.hs +28/−3
• src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +20/−37
• src/ghc/Parsley/Internal/Core.hs +8/−0
• src/ghc/Parsley/Internal/Core/CombinatorAST.hs +23/−28
• src/ghc/Parsley/Internal/Core/Primitives.hs +69/−178
• src/ghc/Parsley/Internal/Frontend/Analysis/Cut.hs +11/−22
• src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs +5/−6
• src/ghc/Parsley/Internal/Frontend/Analysis/Inliner.hs +19/−20
• src/ghc/Parsley/Internal/Frontend/Compiler.hs +5/−5
• test/Regression/Issue27.hs +1/−1

@@ -97,7 +97,7 @@ * Changed how cut compliance is determined, and stopped some incorrect factoring. * Removed unneeded flags for analysis. -## 1.7.0.0 -- TBD+## 1.7.0.0 -- 2021-10-28  * Added fields to the handlers to signify if they should generate a binding or not. * Added two `Inliner` modules to handle inlining in front- and back-ends.@@ -105,5 +105,9 @@ * Refactored the internal representation of static handlers, making them more uniform. * Added basic eta-reduction capabilities to the low-level generators: this can be improved and expanded! * Renamed `buildIterAlways` and `buildIterSame` to `bindIterAlways` and `bindIterSame`.-* Renamed `StaHandler` to `AugmentedStaHandler`-* +* Renamed `StaHandler` to `AugmentedStaHandler`.++## 1.7.1.0 -- 2021-10-29++* Moved `parse` into core API, this will reduce the area of incompatibility.+* Added `loop` combinator.

@@ -5,7 +5,7 @@ --                   | +------- breaking internal API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.7.0.0+version:             1.7.1.0 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         This package contains the internals of the @parsley@ package.                      .

@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PatternSynonyms, CPP #-} {-| Module      : Parsley.Internal Description : The gateway into the internals: here be monsters!@@ -16,21 +16,46 @@     module Primitives,     module THUtils,     module Trace,+#if MIN_VERSION_parsley_core(2,0,0)+#else     module Frontend,-    module Backend+#endif+    module Backend,+    parse   ) where -import Parsley.Internal.Backend         as Backend    (codeGen, Input, eval)+#if MIN_VERSION_parsley_core(2,0,0)+import Parsley.Internal.Backend  (codeGen, eval)+import Parsley.Internal.Frontend (compile)+#endif++import Parsley.Internal.Backend         as Backend    (+    Input,+#if MIN_VERSION_parsley_core(2,0,0)+#else+    codeGen, eval+#endif+  ) import Parsley.Internal.Core            as Core import Parsley.Internal.Core.Primitives as Primitives (     pure, (<*>), (*>), (<*),     (<|>), empty,     satisfy, lookAhead, try, notFollowedBy,+#if MIN_VERSION_parsley_core(2,0,0)+#else     chainPre, chainPost,+#endif+    loop,     Reg, newRegister, get, put,     conditional, branch,     debug   ) import Parsley.Internal.Common.Utils    as THUtils    (Quapplicative(..), WQ, Code, makeQ)+#if MIN_VERSION_parsley_core(2,0,0)+#else import Parsley.Internal.Frontend        as Frontend   (compile)+#endif import Parsley.Internal.Trace           as Trace      (Trace(trace))++parse :: (Trace, Input input) => Parser a -> Code (input -> Maybe a)+parse p = [||\input -> $$(eval [||input||] (compile (try p) codeGen))||]

@@ -17,22 +17,22 @@ 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,+                                            _Fmap, _App, _Get, _Put, _Make,                                             addCoins, refundCoins, drainCoins, giveBursary, blockCoins,                                             minus, minCoins, maxCoins, zero,-                                            IMVar, IΦVar, IΣVar, MVar(..), ΦVar(..), ΣVar(..), SomeΣVar)+                                            IMVar, IΦVar, MVar(..), ΦVar(..), SomeΣVar) import Parsley.Internal.Backend.Analysis   (coinsNeeded, shouldInline)-import Parsley.Internal.Common.Fresh       (VFreshT, HFresh, evalFreshT, evalFresh, construct, MonadFresh(..), mapVFreshT)+import Parsley.Internal.Common.Fresh       (VFreshT, VFresh, evalFreshT, evalFresh, construct, MonadFresh(..), mapVFreshT) import Parsley.Internal.Common.Indexed     (Fix, Fix4(In4), Cofree(..), Nat(..), imap, histo, extract, (|>)) import Parsley.Internal.Core.CombinatorAST (Combinator(..), MetaCombinator(..))-import Parsley.Internal.Core.Defunc        (Defunc(COMPOSE, ID), pattern FLIP_H, pattern UNIT)+import Parsley.Internal.Core.Defunc        (pattern UNIT) import Parsley.Internal.Trace              (Trace(trace))  import Parsley.Internal.Core.Defunc as Core (Defunc) -type CodeGenStack a = VFreshT IΦVar (VFreshT IMVar (HFresh IΣVar)) a-runCodeGenStack :: CodeGenStack a -> IMVar -> IΦVar -> IΣVar -> a-runCodeGenStack m μ0 φ0 = evalFresh (evalFreshT (evalFreshT m φ0) μ0)+type CodeGenStack a = VFreshT IΦVar (VFresh IMVar) a+runCodeGenStack :: CodeGenStack a -> IMVar -> IΦVar -> a+runCodeGenStack m μ0 φ0 = evalFresh (evalFreshT m φ0) μ0  newtype CodeGen o a x =   CodeGen {runCodeGen :: forall xs n r. Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)}@@ -48,9 +48,8 @@         -> Fix Combinator x -- ^ The definition of the parser.         -> Set SomeΣVar     -- ^ The free registers it requires to run.         -> IMVar            -- ^ The binding identifier to start name generation from.-        -> IΣVar            -- ^ The register identifier to start name generation from.         -> LetBinding o a x-codeGen letBound p rs μ0 σ0 = trace ("GENERATING " ++ name ++ ": " ++ show p ++ "\nMACHINE: " ++ show (elems rs) ++ " => " ++ show m) $ makeLetBinding m rs newMeta+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     m = finalise (histo alg p)@@ -58,7 +57,7 @@     alg = deep |> (\x -> CodeGen (shallow (imap extract x)))     -- 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+    finalise cg = 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@@ -90,26 +89,15 @@      let dq = nq `minus` minCoins np nq      return $! binder (In4 (Catch (addCoins dp pc) (handler (addCoins dq qc)))) -chainPreCompile :: CodeGen o a (x -> x) -> CodeGen o a x-                -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a)-                -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a)-                -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)-chainPreCompile op p preOp preP m =-  do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (_Fmap (user (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))-     pc <- freshM (runCodeGen p (In4 (_App m)))-     return $! In4 (Push (user ID) (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preP pc)))))))))--chainPostCompile :: CodeGen o a x -> CodeGen o a (x -> x)-                 -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a)-                 -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a)-                 -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)-chainPostCompile p op preOp preM m =+loopCompile :: CodeGen o a () -> CodeGen o a x+            -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a)+            -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a)+            -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)+loopCompile body exit prebody preExit m =   do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (_Modify σ (In4 (Jump μ)))))-     freshM (runCodeGen p (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preM m)))))))))+     bodyc <- freshM (runCodeGen body (In4 (Pop (In4 (Jump μ)))))+     exitc <- freshM (runCodeGen exit m)+     return $! In4 (Iter μ (prebody bodyc) (parsecHandler (preExit exitc)))  deep :: Trace => Combinator (Cofree Combinator (CodeGen o a)) x -> Maybe (CodeGen o a x) deep (f :<$>: (p :< _)) = Just $ CodeGen $ \m -> runCodeGen p (In4 (_Fmap (user f) m))@@ -121,9 +109,8 @@      pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))      qc <- freshΦ (runCodeGen q φ)      return $! binder (In4 (Catch pc (parsecHandler qc)))-deep (MetaCombinator RequiresCut (_ :< ChainPre (op :< _) (p :< _))) = Just $ CodeGen $ chainPreCompile op p id addCoinsNeeded-deep (MetaCombinator RequiresCut (_ :< ChainPost (p :< _) (op :< _))) = Just $ CodeGen $ chainPostCompile p op id addCoinsNeeded-deep (MetaCombinator Cut (_ :< ChainPre (op :< _) (p :< _))) = Just $ CodeGen $ chainPreCompile op p addCoinsNeeded addCoinsNeeded+deep (MetaCombinator RequiresCut (_ :< Loop (body :< _) (exit :< _))) = Just $ CodeGen $ loopCompile body exit id addCoinsNeeded+deep (MetaCombinator Cut (_ :< Loop (body :< _) (exit :< _))) = Just $ CodeGen $ loopCompile body exit addCoinsNeeded addCoinsNeeded deep _ = Nothing  addCoinsNeeded :: Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a@@ -163,8 +150,7 @@      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 (Loop body exit)             m = do loopCompile body exit 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))))@@ -210,6 +196,3 @@     elidable (In4 (Pop (In4 (Jump _)))) = True     elidable _                          = False-} makeΦ m = let n = coinsNeeded m in fmap (\φ -> (In4 . MkJoin φ (giveBursary n m), drainCoins n (In4 (Join φ)))) askΦ--freshΣ :: CodeGenStack (ΣVar a)-freshΣ = lift (lift (construct ΣVar))

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-| Module      : Parsley.Internal.Core Description : The main AST and datatypes are found here@@ -9,11 +10,18 @@ -} module Parsley.Internal.Core (     Parser,+#if MIN_VERSION_parsley_core(2,0,0)+#else     ParserOps,+#endif     module Parsley.Internal.Core.Defunc,     module Parsley.Internal.Core.InputTypes   ) where  import Parsley.Internal.Core.Defunc hiding (lamTerm, lamTermBool) import Parsley.Internal.Core.InputTypes+#if MIN_VERSION_parsley_core(2,0,0)+import Parsley.Internal.Core.Primitives (Parser)+#else import Parsley.Internal.Core.Primitives (Parser, ParserOps)+#endif

@@ -1,5 +1,4 @@-{-# LANGUAGE ApplicativeDo,-             OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} module Parsley.Internal.Core.CombinatorAST (module Parsley.Internal.Core.CombinatorAST) where  import Data.Kind                         (Type)@@ -29,8 +28,7 @@   NotFollowedBy  :: k a -> Combinator k ()   Branch         :: k (Either a b) -> k (a -> c) -> k (b -> c) -> Combinator k c   Match          :: k a -> [Defunc (a -> Bool)] -> [k b] -> k b -> Combinator k b-  ChainPre       :: k (a -> a) -> k a -> Combinator k a-  ChainPost      :: k a -> k (a -> a) -> Combinator k a+  Loop           :: k () -> k a -> Combinator k a   MakeRegister   :: ΣVar a -> k a -> k b -> Combinator k b   GetRegister    :: ΣVar a -> Combinator k a   PutRegister    :: ΣVar a -> k a -> Combinator k ()@@ -74,8 +72,7 @@   imap f (NotFollowedBy p)    = NotFollowedBy (f p)   imap f (Branch b p q)       = Branch (f b) (f p) (f q)   imap f (Match p fs qs d)    = Match (f p) fs (map f qs) (f d)-  imap f (ChainPre op p)      = ChainPre (f op) (f p)-  imap f (ChainPost p op)     = ChainPost (f p) (f op)+  imap f (Loop body exit)     = Loop (f body) (f exit)   imap f (MakeRegister σ p q) = MakeRegister σ (f p) (f q)   imap _ (GetRegister σ)      = GetRegister σ   imap f (PutRegister σ p)    = PutRegister σ (f p)@@ -99,8 +96,7 @@       alg (NotFollowedBy (Const1 p))                = "(notFollowedBy " . p . ")"       alg (Branch (Const1 b) (Const1 p) (Const1 q)) = "(branch " . b . " " . p . " " . q . ")"       alg (Match (Const1 p) fs qs (Const1 def))     = "(match " . p . " " . shows fs . " [" . intercalateDiff ", " (map getConst1 qs) . "] "  . def . ")"-      alg (ChainPre (Const1 op) (Const1 p))         = "(chainPre " . op . " " . p . ")"-      alg (ChainPost (Const1 p) (Const1 op))        = "(chainPost " . p . " " . op . ")"+      alg (Loop (Const1 body) (Const1 exit))        = "(loop " . body . " " . exit . ")"       alg (MakeRegister σ (Const1 p) (Const1 q))    = "(make " . shows σ . " " . p . " " . q . ")"       alg (GetRegister σ)                           = "(get " . shows σ . ")"       alg (PutRegister σ (Const1 p))                = "(put " . shows σ . " " . p . ")"@@ -117,23 +113,22 @@  {-# INLINE traverseCombinator #-} traverseCombinator :: Applicative m => (forall a. f a -> m (k a)) -> Combinator f a -> m (Combinator k a)-traverseCombinator expose (pf :<*>: px)        = do pf' <- expose pf; px' <- expose px; pure (pf' :<*>: px')-traverseCombinator expose (p :*>: q)           = do p' <- expose p; q' <- expose q; pure (p' :*>: q')-traverseCombinator expose (p :<*: q)           = do p' <- expose p; q' <- expose q; pure (p' :<*: q')-traverseCombinator expose (p :<|>: q)          = do p' <- expose p; q' <- expose q; pure (p' :<|>: q')-traverseCombinator _      Empty                = do pure Empty-traverseCombinator expose (Try p)              = do p' <- expose p; pure (Try p')-traverseCombinator expose (LookAhead p)        = do p' <- expose p; pure (LookAhead p')-traverseCombinator expose (NotFollowedBy p)    = do p' <- expose p; pure (NotFollowedBy p')-traverseCombinator expose (Branch b p q)       = do b' <- expose b; p' <- expose p; q' <- expose q; pure (Branch b' p' q')-traverseCombinator expose (Match p fs qs d)    = do p' <- expose p; qs' <- traverse expose qs; d' <- expose d; pure (Match p' fs qs' d')-traverseCombinator expose (ChainPre op p)      = do op' <- expose op; p' <- expose p; pure (ChainPre op' p')-traverseCombinator expose (ChainPost p op)     = do p' <- expose p; op' <- expose op; pure (ChainPost p' op')-traverseCombinator expose (MakeRegister σ p q) = do p' <- expose p; q' <- expose q; pure (MakeRegister σ p' q')-traverseCombinator _      (GetRegister σ)      = do pure (GetRegister σ)-traverseCombinator expose (PutRegister σ p)    = do p' <- expose p; pure (PutRegister σ p')-traverseCombinator expose (Debug name p)       = do p' <- expose p; pure (Debug name p')-traverseCombinator _      (Pure x)             = do pure (Pure x)-traverseCombinator _      (Satisfy f)          = do pure (Satisfy f)-traverseCombinator _      (Let r v)            = do pure (Let r v)-traverseCombinator expose (MetaCombinator m p) = do p' <- expose p; pure (MetaCombinator m p')+traverseCombinator expose (pf :<*>: px)        = (:<*>:) <$> expose pf <*> expose px+traverseCombinator expose (p :*>: q)           = (:*>:) <$> expose p <*> expose q+traverseCombinator expose (p :<*: q)           = (:<*:) <$> expose p <*> expose q+traverseCombinator expose (p :<|>: q)          = (:<|>:) <$> expose p <*> expose q+traverseCombinator _      Empty                = pure Empty+traverseCombinator expose (Try p)              = Try <$> expose p+traverseCombinator expose (LookAhead p)        = LookAhead <$> expose p+traverseCombinator expose (NotFollowedBy p)    = NotFollowedBy <$> expose p+traverseCombinator expose (Branch b p q)       = Branch <$> expose b <*> expose p <*> expose q+traverseCombinator expose (Match p fs qs d)    = Match <$> expose p <*> pure fs <*> traverse expose qs <*> expose d+traverseCombinator expose (Loop body exit)     = Loop <$> expose body <*> expose exit+traverseCombinator expose (MakeRegister σ p q) = MakeRegister σ <$> expose p <*> expose q+traverseCombinator _      (GetRegister σ)      = pure (GetRegister σ)+traverseCombinator expose (PutRegister σ p)    = PutRegister σ <$> expose p+traverseCombinator expose (Debug name p)       = Debug name <$> expose p+traverseCombinator _      (Pure x)             = pure (Pure x)+traverseCombinator _      (Satisfy f)          = pure (Satisfy f)+traverseCombinator _      (Let r v)            = pure (Let r v)+traverseCombinator expose (MetaCombinator m p) = MetaCombinator m <$> expose p

@@ -1,68 +1,47 @@+{-# LANGUAGE PatternSynonyms, CPP #-} module Parsley.Internal.Core.Primitives (     Parser,     Reg,     module Parsley.Internal.Core.Primitives   ) where -import Prelude hiding                      (pure)+import Prelude hiding                      (pure, (<*>)) import Parsley.Internal.Core.CombinatorAST (Combinator(..), ScopeRegister(..), Reg(..), Parser(..))-import Parsley.Internal.Core.Defunc        (Defunc(BLACK))-import Parsley.Internal.Common.Indexed     (Fix(In), (:+:)(..))+#if MIN_VERSION_parsley_core(2,0,0)+import Parsley.Internal.Core.Defunc        (Defunc)+#else+import Parsley.Internal.Core.Defunc        (Defunc(BLACK, ID, COMPOSE), pattern FLIP_H) import Parsley.Internal.Common.Utils       (WQ)--{-|-This typeclass is used to allow abstraction of the representation of user-level functions.-See the instances for information on what these representations are. This may be required-as a constraint on custom built combinators that make use of one of the minimal required methods-of this class.--@since 0.1.0.0--}-class ParserOps rep where-  {-|-  Lift a value into the parser world without consuming input or having any other effect.--  @since 0.1.0.0-  -}-  pure :: rep a -> Parser a--  {-|-  Attempts to read a single character matching the provided predicate. If it succeeds, the-  character will be returned and consumed, otherwise the parser will fail having consumed no input.+#endif -  @since 0.1.0.0-  -}-  satisfy :: rep (Char -> Bool) -- ^ The predicate that a character must satisfy to be parsed-          -> Parser Char        -- ^ A parser that matches a single character matching the predicate+import Parsley.Internal.Common.Indexed     (Fix(In), (:+:)(..)) -  {-|-  @conditional fqs p def@ first parses @p@, then it will try each of the predicates in @fqs@ in turn-  until one of them returns @True@. The corresponding parser for the first predicate that succeeded-  is then executes, or if none of the predicates succeeded then the @def@ parser is executed.+#if MIN_VERSION_parsley_core(2,0,0)+-- Core smart constructors+{-# INLINE pure #-}+pure :: Defunc a -> Parser a+pure = Parser . In . L . Pure -  @since 0.1.0.0-  -}-  conditional :: [(rep (a -> Bool), Parser b)] -- ^ A list of predicates and their outcomes-              -> Parser a                      -- ^ A parser whose result is used to choose an outcome-              -> Parser b                      -- ^ A parser who will be executed if no predicates succeed-              -> Parser b+{-# INLINE satisfy #-}+satisfy :: Defunc (Char -> Bool) -> Parser Char+satisfy = Parser . In . L . Satisfy -{-|-This is the default representation used for user-level functions and values: plain old code.+{-# INLINE conditional #-}+conditional :: [(Defunc (a -> Bool), Parser b)] -> Parser a -> Parser b -> Parser b+conditional cs (Parser p) (Parser def) =+  let (fs, qs) = unzip cs+  in Parser (In (L (Match p fs (map unParser qs) def)))+#else+class ParserOps rep where+  pure :: rep a -> Parser a+  satisfy :: rep (Char -> Bool) -> Parser Char+  conditional :: [(rep (a -> Bool), Parser b)] -> Parser a -> Parser b -> Parser b -@since 0.1.0.0--} instance ParserOps WQ where   pure = pure . BLACK   satisfy = satisfy . BLACK   conditional = conditional . map (\(f, t) -> (BLACK f, t)) -{-|-This is used to allow defunctionalised versions of many standard Haskell functions to be used-directly as an argument to relevant combinators.--@since 0.1.0.0--} instance {-# INCOHERENT #-} x ~ Defunc => ParserOps x where   pure = _pure   satisfy = _satisfy@@ -73,175 +52,87 @@ _pure :: Defunc a -> Parser a _pure = Parser . In . L . Pure -{-|-Sequential application of one parser's result to another's. The parsers must both succeed, one after-the other to combine their results. If either parser fails then the combinator will fail.+{-# INLINE _satisfy #-}+_satisfy :: Defunc (Char -> Bool) -> Parser Char+_satisfy = Parser . In . L . Satisfy -@since 0.1.0.0--}-infixl 4 <*>+{-# INLINE _conditional #-}+_conditional :: [(Defunc (a -> Bool), Parser b)] -> Parser a -> Parser b -> Parser b+_conditional cs (Parser p) (Parser def) =+  let (fs, qs) = unzip cs+  in Parser (In (L (Match p fs (map unParser qs) def)))+#endif++{-# INLINE (<*>) #-} (<*>) :: Parser (a -> b) -> Parser a -> Parser b Parser p <*> Parser q = Parser (In (L (p :<*>: q))) -{-|-Sequence two parsers, keeping the result of the second and discarding the result of the first.--@since 0.1.0.0--}-infixl 4 <*+{-# INLINE (<*) #-} (<*) :: Parser a -> Parser b -> Parser a Parser p <* Parser q = Parser (In (L (p :<*: q))) -{-|-Sequence two parsers, keeping the result of the first and discarding the result of the second.--@since 0.1.0.0--}-infixl 4 *>+{-# INLINE (*>) #-} (*>) :: Parser a -> Parser b -> Parser b Parser p *> Parser q = Parser (In (L (p :*>: q))) -{-|-This combinator always fails.--@since 0.1.0.0--}+{-# INLINE empty #-} empty :: Parser a empty = Parser (In (L Empty)) -{-|-This combinator implements branching within a parser. It is left-biased, so that if the first branch-succeeds, the second will not be attempted. In accordance with @parsec@ semantics, if the first-branch failed having consumed input the second branch cannot be taken. (see `try`)--@since 0.1.0.0--}-infixr 3 <|>+{-# INLINE (<|>) #-} (<|>) :: Parser a -> Parser a -> Parser a Parser p <|> Parser q = Parser (In (L (p :<|>: q))) -{-# INLINE _satisfy #-}-_satisfy :: Defunc (Char -> Bool) -> Parser Char-_satisfy = Parser . In . L . Satisfy--{-|-This combinator will attempt to parse a given parser. If it succeeds, the result is returned without-having consumed any input. If it fails, however, any consumed input remains consumed.--@since 0.1.0.0--}+{-# INLINE lookAhead #-} lookAhead :: Parser a -> Parser a lookAhead = Parser . In . L . LookAhead . unParser -{-|-This combinator will ensure that a given parser fails. If the parser does fail, a @()@ is returned-and no input is consumed. If the parser succeeded, then this combinator will fail, however it will-not consume any input.--@since 0.1.0.0--}+{-# INLINE notFollowedBy #-} notFollowedBy :: Parser a -> Parser () notFollowedBy = Parser . In . L . NotFollowedBy . unParser -{-|-This combinator allows a parser to backtrack on failure, which is to say that it will-not have consumed any input if it were to fail. This is important since @parsec@ semantics demand-that the second branch of @(`<|>`)@ can only be taken if the first did not consume input on failure.--Excessive use of `try` will reduce the efficiency of the parser and effect the generated error-messages. It should only be used in one of two circumstances:--* When two branches of a parser share a common leading prefix (in which case, it is often better-  to try and factor this out).-* When a parser needs to be executed atomically (for example, tokens).--@since 0.1.0.0--}+{-# INLINE try #-} try :: Parser a -> Parser a try = Parser . In . L . Try . unParser -{-# INLINE _conditional #-}-_conditional :: [(Defunc (a -> Bool), Parser b)] -> Parser a -> Parser b -> Parser b-_conditional cs (Parser p) (Parser def) =-  let (fs, qs) = unzip cs-  in Parser (In (L (Match p fs (map unParser qs) def)))--{-|-One of the core @Selective@ operations. The behaviour of @branch p l r@ is to first to parse-@p@, if it fails then the combinator fails. If @p@ succeeded then if its result is a @Left@, then-the parser @l@ is executed and applied to the result of @p@, otherwise @r@ is executed and applied-to the right from a @Right@.--Crucially, only one of @l@ or @r@ will be executed on @p@'s success.--@since 0.1.0.0--}-branch :: Parser (Either a b) -- ^ The first parser to execute-       -> Parser (a -> c)     -- ^ The parser to execute if the first returned a @Left@-       -> Parser (b -> c)     -- ^ The parser to execute if the first returned a @Right@-       -> Parser c+{-# INLINE branch #-}+branch :: Parser (Either a b) -> Parser (a -> c) -> Parser (b -> c) -> Parser c branch (Parser c) (Parser p) (Parser q) = Parser (In (L (Branch c p q))) -{-|-This combinator parses repeated applications of an operator to a single final operand. This is-primarily used to parse prefix operators in expressions.--@since 0.1.0.0--}+#if MIN_VERSION_parsley_core(2,0,0)+#else+{-# INLINE chainPre #-} chainPre :: Parser (a -> a) -> Parser a -> Parser a-chainPre (Parser op) (Parser p) = Parser (In (L (ChainPre op p)))--{-|-This combinator parses repeated applications of an operator to a single initial operand. This is-primarily used to parse postfix operators in expressions.+chainPre op p =+  newRegister (pure ID) (\r ->+    loop (put r (pure (FLIP_H COMPOSE) <*> op <*> get r))+         (get r))+  <*> p -@since 0.1.0.0--}+{-# INLINE chainPost #-} chainPost :: Parser a -> Parser (a -> a) -> Parser a-chainPost (Parser p) (Parser op) = Parser (In (L (ChainPost p op)))--{-|-Creates a new register initialised with the value obtained from parsing the first-argument. This register is provided to the second argument, a function that generates a parser-depending on operations derived from the register. This parser is then performed.+chainPost p op =+  newRegister p $ \r ->+    loop (put r (op <*> get r))+         (get r)+#endif -Note: The rank-2 type here serves a similar purpose to that in the @ST@ monad. It prevents the-register from leaking outside of the scope of the function, safely encapsulating the stateful-effect of the register.+{-# INLINE loop #-}+loop :: Parser () -> Parser a -> Parser a+loop (Parser body) (Parser exit) = Parser (In (L (Loop body exit))) -@since 0.1.0.0--}-newRegister :: Parser a                        -- ^ Parser with which to initialise the register-            -> (forall r. Reg r a -> Parser b) -- ^ Used to generate the second parser to execute-            -> Parser b+{-# INLINE newRegister #-}+newRegister :: Parser a -> (forall r. Reg r a -> Parser b) -> Parser b newRegister (Parser p) f = Parser (In (R (ScopeRegister p (unParser . f)))) -{-|-Fetches a value from a register and returns it as its result.--@since 0.1.0.0--}+{-# INLINE get #-} get :: Reg r a -> Parser a get (Reg reg) = Parser (In (L (GetRegister reg))) -{-|-Puts the result of the given parser into the given register. The old value in the register will be-lost.--@since 0.1.0.0--}+{-# INLINE put #-} put :: Reg r a -> Parser a -> Parser () put (Reg reg) (Parser p) = Parser (In (L (PutRegister reg p))) -{-|-This combinator can be used to debug parsers that have gone wrong. Simply-wrap a parser with @debug name@ and when that parser is executed it will-print a debug trace on entry and exit along with the current context of the-input.--@since 0.1.0.0--}-debug :: String   -- ^ The name that identifies the wrapped parser in the debug trace-      -> Parser a -- ^ The parser to track during execution-      -> Parser a+{-# INLINE debug #-}+debug :: String -> Parser a -> Parser a debug name (Parser p) = Parser (In (L (Debug name p)))

@@ -58,10 +58,8 @@ compliance (LookAhead c)            = c -- Lookahead will consume input on failure, so its compliance matches that which is beneath it compliance (NotFollowedBy _)        = FullPure compliance (Debug _ c)              = c-compliance (ChainPre NonComp p)     = seqCompliance Comp p-compliance (ChainPre _ p)           = seqCompliance NonComp p-compliance (ChainPost p NonComp)    = seqCompliance p Comp-compliance (ChainPost p _)          = seqCompliance p NonComp+compliance (Loop NonComp exit)      = seqCompliance Comp exit+compliance (Loop _ exit)            = seqCompliance NonComp exit compliance (Branch b p q)           = seqCompliance b (caseCompliance p q) compliance (Match p _ qs def)       = seqCompliance p (foldr1 caseCompliance (def:qs)) compliance (MakeRegister _ l r)     = seqCompliance l r@@ -98,24 +96,15 @@ cutAlg (LookAhead p) cut = rewrap LookAhead cut (ifst p) cutAlg (NotFollowedBy p) _ = False <$ rewrap NotFollowedBy False (ifst p) cutAlg (Debug msg p) cut = rewrap (Debug msg) cut (ifst p)-cutAlg (ChainPre (op :*: NonComp) p) _ =-  let (op', _) = doCut op 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', handled) = doCut (ifst p) cut-      (op', _) = doCut 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-  in (mkCut (cut && handled) (In (ChainPost p' op')), handled)+cutAlg (Loop (body :*: NonComp) exit) _ =+  let (body', _) = doCut body True+      (exit', handled) = doCut (ifst exit) False+  -- the loop could terminate having read no `body`s, so only `exit` can decide if its handled.+  in (requiresCut (In (Loop body' exit')), handled)+cutAlg (Loop body exit) cut =+  let (body', _) = doCut (ifst body) False+      (exit', handled) = doCut (ifst exit) cut+  in (mkCut (not cut) (In (Loop body' exit')), handled) cutAlg (Branch b p q) cut =   let (b', handled) = doCut (ifst b) cut       (p', handled') = doCut (ifst p) (cut && not handled)

@@ -28,11 +28,11 @@ import Parsley.Internal.Common.Indexed      (Fix, cata, Const1(..), (:*:)(..), zipper) import Parsley.Internal.Common.State        (State, MonadState, execState, modify') import Parsley.Internal.Core.CombinatorAST  (Combinator(..), traverseCombinator)-import Parsley.Internal.Core.Identifiers    (IMVar, MVar(..), IΣVar, ΣVar, SomeΣVar(..), getIΣVar)+import Parsley.Internal.Core.Identifiers    (IMVar, MVar(..), ΣVar, SomeΣVar(..))  import qualified Data.Dependent.Map as DMap (foldrWithKey, filterWithKey)-import qualified Data.Map.Strict    as Map  ((!), empty, insert, mapMaybeWithKey, findMax, elems, lookup, foldMapWithKey)-import qualified Data.Set           as Set  (elems, empty, insert, lookupMax)+import qualified Data.Map.Strict    as Map  ((!), empty, insert, mapMaybeWithKey, findMax, elems, lookup)+import qualified Data.Set           as Set  (elems, empty, insert)  type Graph = Array IMVar [IMVar] @@ -51,7 +51,7 @@ -} -- TODO This actually should be in the backend... dead bindings and the topological ordering can be computed here --      but the register stuff should come after register optimisation and instruction peephole-dependencyAnalysis :: Fix Combinator a -> DMap MVar (Fix Combinator) -> (DMap MVar (Fix Combinator), Map IMVar (Set SomeΣVar), IΣVar)+dependencyAnalysis :: Fix Combinator a -> DMap MVar (Fix Combinator) -> (DMap MVar (Fix Combinator), Map IMVar (Set SomeΣVar)) dependencyAnalysis toplevel μs =   let -- Step 1: find roots of the toplevel       roots = directDependencies toplevel@@ -79,8 +79,7 @@                              in Just $ (uses \\ defs) `union` (subUses \\ subDefs)         | otherwise        = Nothing       trueRegs = Map.mapMaybeWithKey addNewRegs usedRegisters-      largestRegister = maybe (-1) getIΣVar (Set.lookupMax (Map.foldMapWithKey (const id) definedRegisters))-  in (DMap.filterWithKey (\(MVar v) _ -> notMember v dead) μs, trueRegs, largestRegister)+  in (DMap.filterWithKey (\(MVar v) _ -> notMember v dead) μs, trueRegs)  minMax :: Ord a => [a] -> (a, a) minMax []     = error "cannot find minimum or maximum of empty list"

@@ -35,23 +35,22 @@  -- Ideally these should mirror those in the backend inliner, how can we unify them? alg :: Combinator InlineWeight a -> Rational-alg (Pure _)                 = 0-alg (Satisfy _)              = 1-alg Empty                    = 0-alg Let{}                    = 2 % 3-alg (Try p)                  = getWeight p-alg (l :<|>: r)              = 1 % 4 + 2 % 5 + getWeight l + getWeight r-alg (l :<*>: r)              = 1 % 5 + getWeight l + getWeight r-alg (l :<*: r)               = getWeight l + getWeight r-alg (l :*>: r)               = getWeight l + getWeight r-alg (LookAhead c)            = getWeight c-alg (NotFollowedBy p)        = 1 % 4 + getWeight p-alg (Debug _ c)              = 2 % 4 + getWeight c-alg (ChainPre op p)          = 2 % 5 + 6 % 3 + getWeight op + getWeight p-alg (ChainPost p op)         = 6 % 3 + getWeight op + getWeight p-alg (Branch b p q)           = 1 % 3 + 2 % 5 + getWeight b + getWeight p + getWeight q-alg (Match p _ qs def)       = fromIntegral (length qs + 1) % 3 + sum (map getWeight qs) + getWeight def + getWeight p-alg (MakeRegister _ l r)     = 1 % 3 + getWeight l + getWeight r-alg (GetRegister _)          = 1 % 3-alg (PutRegister _ c)        = 1 % 3 + getWeight c-alg (MetaCombinator _ c)     = getWeight c+alg (Pure _)             = 0+alg (Satisfy _)          = 1+alg Empty                = 0+alg Let{}                = 2 % 3+alg (Try p)              = getWeight p+alg (l :<|>: r)          = 1 % 4 + 2 % 5 + getWeight l + getWeight r+alg (l :<*>: r)          = 1 % 5 + getWeight l + getWeight r+alg (l :<*: r)           = getWeight l + getWeight r+alg (l :*>: r)           = getWeight l + getWeight r+alg (LookAhead c)        = getWeight c+alg (NotFollowedBy p)    = 1 % 4 + getWeight p+alg (Debug _ c)          = 2 % 4 + getWeight c+alg (Loop body exit)     = 2 % 3 + getWeight body + getWeight exit+alg (Branch b p q)       = 1 % 3 + 2 % 5 + getWeight b + getWeight p + getWeight q+alg (Match p _ qs def)   = fromIntegral (length qs + 1) % 3 + sum (map getWeight qs) + getWeight def + getWeight p+alg (MakeRegister _ l r) = 1 % 3 + getWeight l + getWeight r+alg (GetRegister _)      = 1 % 3+alg (PutRegister _ c)    = 1 % 3 + getWeight c+alg (MetaCombinator _ c) = getWeight c

@@ -57,19 +57,19 @@ -} {-# INLINEABLE compile #-} compile :: forall compiled a. Trace-        => Parser a                                                                                       -- ^ The parser to compile.-        -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set SomeΣVar -> IMVar -> IΣVar -> compiled x) -- ^ How to generate a compiled value with the distilled information.-        -> (compiled a, DMap MVar compiled)                                                               -- ^ The compiled top-level and all of the bindings.+        => Parser a                                                                              -- ^ The parser to compile.+        -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x) -- ^ How to generate a compiled value with the distilled information.+        -> (compiled a, DMap MVar compiled)                                                      -- ^ The compiled top-level and all of the bindings. compile (Parser p) codeGen = trace ("COMPILING NEW PARSER WITH " ++ show (DMap.size μs') ++ " LET BINDINGS") (codeGen' Nothing p', DMap.mapWithKey (codeGen' . Just) μs')   where     (p', μs, maxV) = preprocess p-    (μs', frs, maxΣ) = dependencyAnalysis p' μs+    (μs', frs) = dependencyAnalysis p' μs      freeRegs :: Maybe (MVar x) -> Set SomeΣVar     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 p) (freeRegs letBound) (maxV + 1) (maxΣ + 1)+    codeGen' letBound p = codeGen letBound (analyse emptyFlags p) (freeRegs letBound) (maxV + 1)  preprocess :: Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar) preprocess p =

@@ -29,7 +29,7 @@ toAST = cata (In \/ undefined) . unParser  codeGen' :: Fix Combinator a -> Binding o a a-codeGen' p = body (codeGen Nothing p Set.empty 0 0)+codeGen' p = body (codeGen Nothing p Set.empty 0)  ex1_p :: Fix Combinator String ex1_p = toAST $ try $ string "123" <|> string "45"