parsley-core 1.7.2.0 → 1.8.0.0

raw patch · 32 files changed

+888/−335 lines, 32 filesdep +deepseqdep +th-test-utilsdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, th-test-utils

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• parsley-core.cabal +22/−4
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/BindingOps.hs +46/−40
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs +8/−8
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +37/−28
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs +15/−15
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs +65/−58
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/PosOps.hs +89/−0
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Base.hs +27/−5
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs +9/−8
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Dynamics.hs +1/−1
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input.hs +57/−0
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input/Offset.hs +100/−0
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Offset.hs +0/−100
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/State.hs +2/−2
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Statics.hs +34/−32
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs +10/−5
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs +38/−24
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types/State.hs +4/−3
• src/ghc/Parsley/Internal.hs +1/−0
• src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs +1/−0
• src/ghc/Parsley/Internal/Backend/Analysis/Inliner.hs +1/−0
• src/ghc/Parsley/Internal/Backend/Analysis/Relevancy.hs +1/−0
• src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +1/−0
• src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +8/−1
• src/ghc/Parsley/Internal/Core/CombinatorAST.hs +9/−0
• src/ghc/Parsley/Internal/Core/Primitives.hs +9/−1
• src/ghc/Parsley/Internal/Frontend/Analysis/Cut.hs +2/−0
• src/ghc/Parsley/Internal/Frontend/Analysis/Inliner.hs +1/−0
• test/Primitive.hs +142/−0
• test/Primitive/Parsers.hs +50/−0
• test/TestUtils.hs +88/−0

@@ -121,3 +121,13 @@  * Added `reclaimable` to backend analysis, this allows `lookAhead` to calculate reclaim ignoring `BlockCoins` * Fixed small bug in coin analysis that meant that `lookAhead` always contributes `0` coins (`min 0` vs `max 0`).++## 1.8.0.0 -- 2021-11-13++* Reversed order of arguments on `Subroutine#`, offset comes last.+* Added `Pos` type, and threaded it through+* Added `Input o` and `Input# o`, which package an `Offset o` or `Code (Rep o)` with `Pos` information.+* Added cabal flag to control the packed or unpacked representation of positions+* Added `PosSelector`+* Added `line` and `col` to primitives and `Position` to Combinator AST, as well as `SelectPos` to instructions.+* Changed `OFFSET` to `INPUT` in `Defunc`

@@ -5,7 +5,7 @@ --                   | +------- breaking internal API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.7.2.0+version:             1.8.0.0 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         This package contains the internals of the @parsley@ package.                      .@@ -28,9 +28,14 @@                      README.md tested-with:         GHC == 8.6.1,  GHC == 8.6.2,  GHC == 8.6.3,  GHC == 8.6.4,  GHC == 8.6.5,                      GHC == 8.8.1,  GHC == 8.8.2,  GHC == 8.8.3,  GHC == 8.8.4,-                     GHC == 8.10.4, GHC == 8.10.5,+                     GHC == 8.10.4, GHC == 8.10.5, GHC == 8.10.7,                      GHC == 9.0.1 +flag full-width-positions+  description: Make line and column numbers 64-bit (on 64-bit platforms): normally they are 32-bits each for line and column.+  default:     False+  manual:      True+ library   exposed-modules:     Parsley.Internal,                        Parsley.Internal.Trace,@@ -95,13 +100,17 @@    if impl(ghc >= 8.10)     exposed-modules:   Parsley.Internal.Backend.Machine.BindingOps,+                       Parsley.Internal.Backend.Machine.PosOps,                         Parsley.Internal.Backend.Machine.Types.Base,                        Parsley.Internal.Backend.Machine.Types.Context,                        Parsley.Internal.Backend.Machine.Types.Dynamics,-                       Parsley.Internal.Backend.Machine.Types.Offset,-                       Parsley.Internal.Backend.Machine.Types.Statics+                       Parsley.Internal.Backend.Machine.Types.Input,+                       Parsley.Internal.Backend.Machine.Types.Statics, +                       Parsley.Internal.Backend.Machine.Types.Input.Offset+                       --Parsley.Internal.Backend.Machine.Types.Input.Pos+   default-extensions:  BangPatterns,                        DataKinds,                        GADTs,@@ -156,6 +165,8 @@     ghc-options:       -Wno-missing-safe-haskell-mode                        -Wno-prepositive-qualified-module                        -Wno-unused-packages+  if flag(full-width-positions)+    cpp-options:       -DFULL_WIDTH_POSITIONS  common test-common   build-depends:       base >=4.10 && <5,@@ -163,6 +174,13 @@                        tasty   hs-source-dirs:      test   default-language:    Haskell2010++test-suite primitives-test+  import:              test-common+  type:                exitcode-stdio-1.0+  build-depends:       tasty-hunit, tasty-quickcheck, th-test-utils, deepseq, template-haskell+  main-is:             Primitive.hs+  other-modules:       Primitive.Parsers, TestUtils  test-suite common-test   import:              test-common

@@ -1,7 +1,8 @@ {-# OPTIONS_GHC -Wno-monomorphism-restriction #-} {-# LANGUAGE AllowAmbiguousTypes,              CPP,-             MagicHash #-}+             MagicHash,+             UnboxedTuples #-} {-| Module      : Parsley.Internal.Backend.Machine.BindingOps Description : Various functions that handle levity-polymorphic code bindings@@ -27,9 +28,10 @@ import Data.ByteString.Internal                        (ByteString) import Data.Text                                       (Text) import Parsley.Internal.Backend.Machine.InputRep       (Rep)-import Parsley.Internal.Backend.Machine.Types.Base     (Handler#)+import Parsley.Internal.Backend.Machine.Types.Base     (Handler#, Pos) import Parsley.Internal.Backend.Machine.Types.Dynamics (DynSubroutine, DynCont, DynHandler)-import Parsley.Internal.Backend.Machine.Types.Statics  (StaCont#, StaHandler#)+import Parsley.Internal.Backend.Machine.Types.Input    (Input#(..))+import Parsley.Internal.Backend.Machine.Types.Statics  (StaCont#, StaHandler#, StaSubroutine#) import Parsley.Internal.Common.Utils                   (Code) import Parsley.Internal.Core.InputTypes                (Text16, CharList, Stream) @@ -60,13 +62,14 @@                -> (DynHandler s o a -> Code b) -- ^ The continuation that expects the bound handler                -> Code b -#define deriveHandlerOps(_o)                    \-instance HandlerOps _o where                    \-{                                               \-  bindHandler# h k = [||                        \-    let handler (o# :: Rep _o) = $$(h [||o#||]) \-    in $$(k [||handler||])                      \-  ||];                                          \+#define deriveHandlerOps(_o)                  \+instance HandlerOps _o where                  \+{                                             \+  bindHandler# h k = [||                      \+    let handler (pos :: Pos) (o# :: Rep _o) = \+          $$(h (Input# [||o#||] [||pos||]))   \+    in $$(k [||handler||])                    \+  ||];                                        \ }; inputInstances(deriveHandlerOps) @@ -85,11 +88,12 @@                   -> (DynCont s o a x -> Code b) -- ^ The continuation that expects the bound join point                   -> Code b -#define deriveJoinBuilder(_o)                                                             \-instance JoinBuilder _o where                                                             \-{                                                                                         \-  setupJoinPoint# binding k =                                                             \-    [|| let join x !(o# :: Rep _o) = $$(binding [||x||] [||o#||]) in $$(k [||join||]) ||] \+#define deriveJoinBuilder(_o)                                                         \+instance JoinBuilder _o where                                                         \+{                                                                                     \+  setupJoinPoint# binding k =                                                         \+    [|| let join x (pos :: Pos) !(o# :: Rep _o) =                                     \+              $$(binding [||x||] (Input# [||o#||] [||pos||])) in $$(k [||join||]) ||] \ }; inputInstances(deriveJoinBuilder) @@ -106,8 +110,8 @@    @since 1.4.0.0   -}-  bindIterHandler# :: (Code (Rep o) -> StaHandler# s o a)        -- ^ The iter handler to bind-                   -> (Code (Rep o -> Handler# s o a) -> Code b) -- ^ The continuation that accepts the bound handler+  bindIterHandler# :: (Input# o -> StaHandler# s o a)                   -- ^ The iter handler to bind+                   -> (Code (Pos -> Rep o -> Handler# s o a) -> Code b) -- ^ The continuation that accepts the bound handler                    -> Code b    {-|@@ -115,31 +119,33 @@    @since 1.4.0.0   -}-  bindIter# :: Code (Rep o)                                                -- ^ Initial offset for the loop.-            -> (DynHandler s o a -> Code (Rep o) -> Code (ST s (Maybe a))) -- ^ The code for the loop given handler and offset.-            -> Code (ST s (Maybe a))                                       -- ^ Code of the executing loop.+  bindIter# :: Input# o                                                                     -- ^ Initial offset for the loop.+            -> (Code (Pos -> Rep o -> ST s (Maybe a)) -> Input# o -> Code (ST s (Maybe a))) -- ^ The code for the loop given self-call and offset.+            -> Code (ST s (Maybe a))                                                        -- ^ Code of the executing loop.    {-|   Creates a binding for a regular let-bound parser.    @since 1.4.0.0   -}-  bindRec#  :: (DynSubroutine s o a x -> DynCont s o a x -> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a))) -- ^ Code for the binding, accepting itself as an argument.-            -> DynSubroutine s o a x                                                                                   -- ^ The code that represents this binding's name.+  bindRec#  :: (DynSubroutine s o a x -> StaSubroutine# s o a x) -- ^ Code for the binding, accepting itself as an argument.+            -> DynSubroutine s o a x                             -- ^ The code that represents this binding's name. -#define deriveRecBuilder(_o)                                                                           \-instance RecBuilder _o where                                                                           \-{                                                                                                      \-  bindIterHandler# h k = [||                                                                           \-      let handler (c# :: Rep _o) (o# :: Rep _o) = $$(h [||c#||] [||o#||]) in $$(k [||handler||])       \-    ||];                                                                                               \-  bindIter# o l = [||                                                                                  \-      let loop !(o# :: Rep _o) = $$(l [||loop||] [||o#||])                                             \-      in loop $$o                                                                                      \-    ||];                                                                                               \-  bindRec# binding =                                                                                   \-    {- The idea here is to try and reduce the number of times registers have to be passed around -}    \-    [|| let self ret !(o# :: Rep _o) h = $$(binding [||self||] [||ret||] [||o#||] [||h||]) in self ||] \+#define deriveRecBuilder(_o)                                                                        \+instance RecBuilder _o where                                                                        \+{                                                                                                   \+  bindIterHandler# h k = [||                                                                        \+      let handler (posc :: Pos) (c# :: Rep _o) (poso :: Pos) (o# :: Rep _o) =                       \+            $$(h (Input# [||c#||] [||posc||]) (Input# [||o#||] [||poso||])) in $$(k [||handler||])  \+    ||];                                                                                            \+  bindIter# inp l = [||                                                                             \+      let loop (pos :: Pos) !(o# :: Rep _o) = $$(l [||loop||] (Input# [||o#||] [||pos||]))          \+      in loop $$(pos# inp) $$(off# inp)                                                             \+    ||];                                                                                            \+  bindRec# binding =                                                                                \+    {- The idea here is to try and reduce the number of times registers have to be passed around -} \+    [|| let self ret h (pos :: Pos) !(o# :: Rep _o) =                                               \+              $$(binding [||self||] [||ret||] [||h||] (Input# [||o#||] [||pos||])) in self ||]      \ }; inputInstances(deriveRecBuilder) @@ -166,10 +172,10 @@   -}   dynCont# :: StaCont# s o a x -> DynCont s o a x -#define deriveMarshalOps(_o)                                          \-instance MarshalOps _o where                                          \-{                                                                     \-  dynHandler# sh = [||\ (o# :: Rep _o) -> $$(sh [||o#||]) ||];        \-  dynCont# sk = [||\ x (o# :: Rep _o) -> $$(sk [||x||] [||o#||]) ||]; \+#define deriveMarshalOps(_o)                                                                          \+instance MarshalOps _o where                                                                          \+{                                                                                                     \+  dynHandler# sh = [||\ (pos :: Pos) (o# :: Rep _o) -> $$(sh (Input# [||o#||] [||pos||])) ||];        \+  dynCont# sk = [||\ x (pos :: Pos) (o# :: Rep _o) -> $$(sk [||x||] (Input# [||o#||] [||pos||])) ||]; \ }; inputInstances(deriveMarshalOps)

@@ -20,9 +20,9 @@     pattern NormLam, pattern FREEVAR   ) where -import Parsley.Internal.Backend.Machine.Types.Offset (Offset)-import Parsley.Internal.Common.Utils                 (Code)-import Parsley.Internal.Core.Lam                     (Lam, normaliseGen, normalise)+import Parsley.Internal.Backend.Machine.Types.Input (Input(off))+import Parsley.Internal.Common.Utils                (Code)+import Parsley.Internal.Core.Lam                    (Lam, normaliseGen, normalise)  import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm, lamTermBool) import qualified Parsley.Internal.Core.Lam    as Lam  (Lam(..))@@ -48,14 +48,14 @@   -}   BOTTOM  :: Defunc a   {-|-  Allows the static `Offset`s to be pushed onto the operand stack, which+  Allows the static `Input`s to be pushed onto the operand stack, which   is the easiest way to get them to persist as arguments to handlers, and   interact with `Parsley.Internal.Backend.Machine.Instructions.Seek` and   `Parsley.Internal.Backend.Machine.Instructions.Tell`. -  @since 1.4.0.0+  @since 1.8.0.0   -}-  OFFSET  :: Offset o -> Defunc o+  INPUT  :: Input o -> Defunc o  {-| Promotes a @Defunc@ value from the Frontend API into a Backend one.@@ -110,7 +110,7 @@ genDefunc :: Defunc a -> Code a genDefunc (LAM x)    = normaliseGen x genDefunc BOTTOM      = [||undefined||]-genDefunc (OFFSET _)  = error "Cannot materialise an unboxed offset in the regular way"+genDefunc (INPUT _)  = error "Cannot materialise an input in the regular way"  {-| Pattern that normalises a `Lam` before returning it.@@ -135,4 +135,4 @@   show (LAM x) = show x   show BOTTOM = "[[irrelevant]]"   show (FREEVAR _) = "x"-  show (OFFSET o)  = "offset " ++ show o+  show (INPUT inp)  = "input " ++ show (off inp)

@@ -1,4 +1,5 @@ {-# LANGUAGE ImplicitParams,+             MagicHash,              MultiWayIf,              PatternSynonyms,              RecordWildCards,@@ -17,28 +18,30 @@ -} module Parsley.Internal.Backend.Machine.Eval (eval) where -import Data.Dependent.Map                             (DMap)-import Data.Functor                                   ((<&>))-import Data.Void                                      (Void)-import Control.Monad                                  (forM, liftM2, liftM3, when)-import Control.Monad.Reader                           (ask, asks, reader, local)-import Control.Monad.ST                               (runST)-import Parsley.Internal.Backend.Machine.Defunc        (Defunc(OFFSET), pattern FREEVAR, genDefunc, ap, ap2, _if)-import Parsley.Internal.Backend.Machine.Identifiers   (MVar(..), ΦVar, ΣVar)-import Parsley.Internal.Backend.Machine.InputOps      (InputDependant, InputOps(InputOps))-import Parsley.Internal.Backend.Machine.InputRep      (Rep)-import Parsley.Internal.Backend.Machine.Instructions  (Instr(..), MetaInstr(..), Access(..), Handler(..))-import Parsley.Internal.Backend.Machine.LetBindings   (LetBinding(body))-import Parsley.Internal.Backend.Machine.LetRecBuilder (letRec)+import Data.Dependent.Map                                  (DMap)+import Data.Functor                                        ((<&>))+import Data.Void                                           (Void)+import Control.Monad                                       (forM, liftM2, liftM3, when)+import Control.Monad.Reader                                (ask, asks, reader, local)+import Control.Monad.ST                                    (runST)+import Parsley.Internal.Backend.Machine.Defunc             (Defunc(INPUT), pattern FREEVAR, genDefunc, ap, ap2, _if)+import Parsley.Internal.Backend.Machine.Identifiers        (MVar(..), ΦVar, ΣVar)+import Parsley.Internal.Backend.Machine.InputOps           (InputDependant, InputOps(InputOps))+import Parsley.Internal.Backend.Machine.InputRep           (Rep)+import Parsley.Internal.Backend.Machine.Instructions       (Instr(..), MetaInstr(..), Access(..), Handler(..), PosSelector(..))+import Parsley.Internal.Backend.Machine.LetBindings        (LetBinding(body))+import Parsley.Internal.Backend.Machine.LetRecBuilder      (letRec) import Parsley.Internal.Backend.Machine.Ops-import Parsley.Internal.Backend.Machine.Types         (MachineMonad, Machine(..), run)+import Parsley.Internal.Backend.Machine.Types              (MachineMonad, Machine(..), run)+import Parsley.Internal.Backend.Machine.PosOps             (initPos, extractCol, extractLine) import Parsley.Internal.Backend.Machine.Types.Context-import Parsley.Internal.Backend.Machine.Types.Coins   (willConsume, int)-import Parsley.Internal.Backend.Machine.Types.Offset  (mkOffset, offset)-import Parsley.Internal.Backend.Machine.Types.State   (Γ(..), OpStack(..))-import Parsley.Internal.Common                        (Fix4, cata4, One, Code, Vec(..), Nat(..))-import Parsley.Internal.Trace                         (Trace(trace))-import System.Console.Pretty                          (color, Color(Green))+import Parsley.Internal.Backend.Machine.Types.Coins        (willConsume, int)+import Parsley.Internal.Backend.Machine.Types.Input        (Input(Input, off, pos))+import Parsley.Internal.Backend.Machine.Types.Input.Offset (mkOffset)+import Parsley.Internal.Backend.Machine.Types.State        (Γ(..), OpStack(..))+import Parsley.Internal.Common                             (Fix4, cata4, One, Code, Vec(..), Nat(..))+import Parsley.Internal.Trace                              (Trace(trace))+import System.Console.Pretty                               (color, Color(Green))  import qualified Debug.Trace (trace) @@ -58,7 +61,7 @@         in letRec fs              nameLet              (\μ exp rs names -> buildRec μ rs (emptyCtx names) (readyMachine exp))-             (run (readyMachine (body binding)) (Γ Empty halt (mkOffset [||offset||] 0) (VCons fatal VNil)) . nextUnique . emptyCtx))+             (run (readyMachine (body binding)) (Γ Empty halt (Input (mkOffset [||offset||] 0) initPos) (VCons fatal VNil)) . nextUnique . emptyCtx))   ||]   where     nameLet :: MVar x -> String@@ -90,6 +93,7 @@     alg (Make σ c k)        = evalMake σ c k     alg (Get σ c k)         = evalGet σ c k     alg (Put σ c k)         = evalPut σ c k+    alg (SelectPos sel k)   = evalSelectPos sel k     alg (LogEnter name k)   = evalLogEnter name k     alg (LogExit name k)    = evalLogExit name k     alg (MetaInstr m k)     = evalMeta m k@@ -101,7 +105,7 @@ evalCall μ (Machine k) = freshUnique $ \u -> liftM2 (callCC u) (askSub μ) k  evalJump :: forall s o a x n. MarshalOps o => MVar x -> MachineMonad s o '[] (Succ n) x a-evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation @o sub retCont (offset input) handlers+evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation @o sub retCont input handlers  evalPush :: Defunc x -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a evalPush x (Machine k) = k <&> \m γ -> m (γ {operands = Op x (operands γ)})@@ -137,7 +141,7 @@                       -> MachineMonad s o xs (Succ n) r a     emitCheckAndFetch n mk = do       sat <- satFetch mk-      return $ \γ -> emitLengthCheck n (sat γ) (raise γ) (input γ)+      return $ \γ -> emitLengthCheck n (sat γ) (raise γ) (off (input γ))      continue mk γ c input' = run mk (γ {input = input', operands = Op c (operands γ)}) @@ -155,10 +159,10 @@     liftM3 (\mk myes mno γ -> bindSameHandler γ gyes (buildYesHandler γ myes u) gno (buildHandler γ mno u) mk) k yes no  evalTell :: Machine s o (o : xs) n r a -> MachineMonad s o xs n r a-evalTell (Machine k) = k <&> \mk γ -> mk (γ {operands = Op (OFFSET (input γ)) (operands γ)})+evalTell (Machine k) = k <&> \mk γ -> mk (γ {operands = Op (INPUT (input γ)) (operands γ)})  evalSeek :: Machine s o xs n r a -> MachineMonad s o (o : xs) n r a-evalSeek (Machine k) = k <&> \mk γ -> let Op (OFFSET input) xs = operands γ in mk (γ {operands = xs, input = input})+evalSeek (Machine k) = k <&> \mk γ -> let Op (INPUT input) xs = operands γ in mk (γ {operands = xs, input = input})  evalCase :: Machine s o (x : xs) n r a -> Machine s o (y : xs) n r a -> MachineMonad s o (Either x y : xs) n r a evalCase (Machine p) (Machine q) = liftM2 (\mp mq γ ->@@ -214,6 +218,11 @@   let Op x xs = operands γ   in writeΣ σ a x (run k (γ {operands = xs})) ctx +-- TODO: FREEVAR is the wrong abstraction really...+evalSelectPos :: PosSelector -> Machine s o (Int : xs) n r a -> MachineMonad s o xs n r a+evalSelectPos Line (Machine k) = k <&> \m γ -> m (γ {operands = Op (FREEVAR (extractLine (pos (input γ)))) (operands γ)})+evalSelectPos Col (Machine k) = k <&> \m γ -> m (γ {operands = Op (FREEVAR (extractCol (pos (input γ)))) (operands γ)})+ evalLogEnter :: (?ops :: InputOps (Rep o), LogHandler o, HandlerOps o)              => String -> Machine s o xs (Succ (Succ n)) r a -> MachineMonad s o xs (Succ n) r a evalLogEnter name (Machine mk) = freshUnique $ \u ->@@ -231,13 +240,13 @@ evalMeta (AddCoins coins) (Machine k) =   do requiresPiggy <- asks hasCoin      if requiresPiggy then local (storePiggy coins) k-     else local (giveCoins coins) k <&> \mk γ -> emitLengthCheck (willConsume coins) (mk γ) (raise γ) (input γ)+     else local (giveCoins coins) k <&> \mk γ -> emitLengthCheck (willConsume coins) (mk γ) (raise γ) (off (input γ)) evalMeta (RefundCoins coins) (Machine k) = local (refundCoins coins) k -- No interaction with input reclamation here! evalMeta (DrainCoins coins) (Machine k) =   -- If there are enough coins left to cover the cost, no length check is required   -- Otherwise, the full length check is required (partial doesn't work until the right offset is reached)-  liftM2 (\canAfford mk γ -> if canAfford then mk γ else emitLengthCheck (willConsume coins) (mk γ) (raise γ) (input γ))+  liftM2 (\canAfford mk γ -> if canAfford then mk γ else emitLengthCheck (willConsume coins) (mk γ) (raise γ) (off (input γ)))          (asks (canAfford (willConsume coins)))          k evalMeta (GiveBursary coins) (Machine k) = local (giveCoins coins) k@@ -246,7 +255,7 @@      when (not bankrupt && check) (error "must be bankrupt to generate a prefetch check")      mkCheck check (reader $ \ctx γ -> prefetch (input γ) ctx (run k γ))   where-    mkCheck True  k = local (giveCoins (int 1)) k <&> \mk γ -> emitLengthCheck 1 (mk γ) (raise γ) (input γ)+    mkCheck True  k = local (giveCoins (int 1)) k <&> \mk γ -> emitLengthCheck 1 (mk γ) (raise γ) (off (input γ))     mkCheck False k = k     prefetch o ctx k = fetch o (\c o' -> k (addChar c o' ctx)) evalMeta BlockCoins (Machine k) = k

@@ -18,23 +18,23 @@ module Parsley.Internal.Backend.Machine.InputOps (     InputPrep(..), PositionOps(..), LogOps(..),     InputOps(..), more, next,-    InputDependant,+    InputDependant   ) where -import Data.Array.Base                           (UArray(..), listArray)-import Data.ByteString.Internal                  (ByteString(..))-import Data.Text.Array                           (aBA{-, empty-})-import Data.Text.Internal                        (Text(..))-import Data.Text.Unsafe                          (iter, Iter(..){-, iter_, reverseIter_-})-import GHC.Exts                                  (Int(..), Char(..), TYPE, Int#)-import GHC.ForeignPtr                            (ForeignPtr(..))-import GHC.Prim                                  (indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#), (-#))-import Parsley.Internal.Backend.Machine.InputRep (Stream(..), CharList(..), Text16(..), Rep, UnpackedLazyByteString,-                                                  offWith, emptyUnpackedLazyByteString, intSame, intLess,-                                                  offsetText, offWithSame, offWithShiftRight, dropStream,-                                                  textShiftRight, textShiftLeft, byteStringShiftRight,-                                                  byteStringShiftLeft, max#)-import Parsley.Internal.Common.Utils             (Code)+import Data.Array.Base                             (UArray(..), listArray)+import Data.ByteString.Internal                    (ByteString(..))+import Data.Text.Array                             (aBA{-, empty-})+import Data.Text.Internal                          (Text(..))+import Data.Text.Unsafe                            (iter, Iter(..){-, iter_, reverseIter_-})+import GHC.Exts                                    (Int(..), Char(..), TYPE, Int#)+import GHC.ForeignPtr                              (ForeignPtr(..))+import GHC.Prim                                    (indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#), (-#))+import Parsley.Internal.Backend.Machine.InputRep   (Stream(..), CharList(..), Text16(..), Rep, UnpackedLazyByteString,+                                                    offWith, emptyUnpackedLazyByteString, intSame, intLess,+                                                    offsetText, offWithSame, offWithShiftRight, dropStream,+                                                    textShiftRight, textShiftLeft, byteStringShiftRight,+                                                    byteStringShiftLeft, max#)+import Parsley.Internal.Common.Utils               (Code)  import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..)) --import qualified Data.Text                     as Text (length, index)

@@ -8,7 +8,8 @@              NamedFieldPuns,              PatternSynonyms,              RecordWildCards,-             TypeApplications #-}+             TypeApplications,+             UnboxedTuples #-} {-| Module      : Parsley.Internal.Backend.Machine.Ops Description : Higher-level operations used by evaluation.@@ -68,22 +69,24 @@ import GHC.Exts                                        (Int(..), (-#)) import Language.Haskell.TH.Syntax                      (liftTyped) import Parsley.Internal.Backend.Machine.BindingOps-import Parsley.Internal.Backend.Machine.Defunc         (Defunc(OFFSET), genDefunc, _if, pattern FREEVAR)+import Parsley.Internal.Backend.Machine.Defunc         (Defunc(INPUT), genDefunc, _if, pattern FREEVAR) import Parsley.Internal.Backend.Machine.Identifiers    (MVar, ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps       (PositionOps(..), LogOps(..), InputOps, next, more) import Parsley.Internal.Backend.Machine.InputRep       (Rep) import Parsley.Internal.Backend.Machine.Instructions   (Access(..)) import Parsley.Internal.Backend.Machine.LetBindings    (Regs(..), Metadata(failureInputCharacteristic, successInputCharacteristic), InputCharacteristic(..))+import Parsley.Internal.Backend.Machine.PosOps         (updatePos) import Parsley.Internal.Backend.Machine.THUtils        (eta) import Parsley.Internal.Backend.Machine.Types          (MachineMonad, Machine(..), run) import Parsley.Internal.Backend.Machine.Types.Context import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynCont, DynHandler)+import Parsley.Internal.Backend.Machine.Types.Input    (Input(..), Input#(..), toInput, fromInput) import Parsley.Internal.Backend.Machine.Types.State    (Γ(..), OpStack(..)) import Parsley.Internal.Backend.Machine.Types.Statics import Parsley.Internal.Common                         (One, Code, Vec(..), Nat(..)) import System.Console.Pretty                           (color, Color(Green, White, Red, Blue)) -import Parsley.Internal.Backend.Machine.Types.Offset as Offset (Offset(..), moveOne, mkOffset, moveN)+import Parsley.Internal.Backend.Machine.Types.Input.Offset as Offset (Offset(..), moveOne, moveN)  {- General Operations -} {-|@@ -94,7 +97,7 @@ -} dup :: Defunc x -> (Defunc x -> Code r) -> Code r dup (FREEVAR x) k = k (FREEVAR x)-dup (OFFSET o) k = k (OFFSET o)+dup (INPUT o) k = k (INPUT o) dup x k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]  {-|@@ -115,24 +118,25 @@ from the input within @γ@, executing the failure code if it does not exist or does not match. -@since 1.5.0.0+@since 1.8.0.0 -}-sat :: (Defunc Char -> Defunc Bool)                         -- ^ Predicate to test the character with.-    -> ((Code Char -> Offset o -> aux -> Code b) -> Code b) -- ^ The source of the character-    -> (Defunc Char -> Offset o -> aux -> Code b)           -- ^ Code to execute on success.-    -> Code b                                               -- ^ Code to execute on failure.+sat :: (Defunc Char -> Defunc Bool)                        -- ^ Predicate to test the character with.+    -> ((Code Char -> Input o -> aux -> Code b) -> Code b) -- ^ The source of the character+    -> (Defunc Char -> Input o -> aux -> Code b)           -- ^ Code to execute on success.+    -> Code b                                              -- ^ Code to execute on failure.     -> Code b sat p src good bad = src $ \c input' aux -> let v = FREEVAR c in _if (p v) (good v input' aux) bad  {-| Consumes the next character and adjusts the offset to match. -@since 1.5.0.0+@since 1.8.0.0 -} fetch :: (?ops :: InputOps (Rep o))-      => Offset o -> (Code Char -> Offset o -> Code b) -> Code b-fetch input k = next (offset input) $ \c offset' -> k c (moveOne input offset')-+      => Input o -> (Code Char -> Input o -> Code b) -> Code b+fetch input k = next (offset (off input)) $ \c offset' ->+  k c (input {off = moveOne (off input) offset',+              pos = updatePos (pos input) c}) {-| Emits a length check for a number of characters \(n\) in the most efficient way it can. It takes two continuations a @good@ and a @bad@: the @good@ is used@@ -227,7 +231,7 @@              -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a))) -- ^ Partial parser accepting the modified state.              -> Word                                            -- ^ The unique identifier for the offset on failure.              -> StaHandlerBuilder s o a-buildHandler γ h u c = fromStaHandler# $ \o# -> h (γ {operands = Op (OFFSET c) (operands γ), input = mkOffset o# u})+buildHandler γ h u c = fromStaHandler# $ \inp -> h (γ {operands = Op (INPUT c) (operands γ), input = toInput u inp})  {-| Converts a partially evaluated parser into a "yes" handler: this means that@@ -240,7 +244,7 @@                 -> (Γ s o xs n r a -> Code (ST s (Maybe a)))                 -> Word                 -> StaHandler s o a-buildYesHandler γ h u = fromStaHandler# $ \o# -> h (γ {input = mkOffset o# u})+buildYesHandler γ h u = fromStaHandler# $ \inp -> h (γ {input = toInput u inp})  -- Handler binding {-|@@ -276,9 +280,9 @@                 -> (Γ s o xs (Succ n) r a -> Code b) -- ^ The parser to receive the composite handler.                 -> Code b bindSameHandler γ yesNeeded yes noNeeded no k =-  bindYesInline# yesNeeded (staHandler# yes (offset (input γ))) $ \qyes ->+  bindYesInline# yesNeeded (staHandler# yes (fromInput (input γ))) $ \qyes ->     bindHandlerInline# noNeeded (staHandler# (no (input γ))) $ \qno ->-      let handler o = [||if $$(same (offset (input γ)) o) then $$qyes else $$(staHandler# qno o)||]+      let handler inp = [||if $$(same (offset (off (input γ))) (off# inp)) then $$qyes else $$(staHandler# qno inp)||]       in bindHandlerInline# @o True handler $ \qhandler ->           k (γ {handlers = VCons (augmentHandlerFull (input γ) qhandler qyes qno) (handlers γ)}) @@ -311,33 +315,33 @@ @since 1.2.0.0 -} resume :: StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))-resume k γ = let Op x _ = operands γ in staCont# k (genDefunc x) (offset (input γ))+resume k γ = let Op x _ = operands γ in staCont# k (genDefunc x) (fromInput (input γ))  {-| A form of @callCC@, this calls a subroutine with a given return continuation passed to it. This may be the current continuation, but also may just be a previous return continuation in the case of a tail call. -@since 1.2.0.0+@since 1.8.0.0 -} callWithContinuation :: MarshalOps o                      => StaSubroutine s o a x           -- ^ The subroutine @sub@ that will be called.                      -> StaCont s o a x                 -- ^ The return continuation for the subroutine.-                     -> Code (Rep o)                    -- ^ The input to feed to @sub@.+                     -> Input o                         -- ^ The input to feed to @sub@.                      -> Vec (Succ n) (AugmentedStaHandler s o a) -- ^ The stack from which to obtain the handler to pass to @sub@.                      -> Code (ST s (Maybe a))-callWithContinuation sub ret input (VCons h _) = staSubroutine# sub (dynCont ret) input (dynHandler h (failureInputCharacteristic (meta sub)))+callWithContinuation sub ret input (VCons h _) = staSubroutine# sub (dynCont ret) (dynHandler h (failureInputCharacteristic (meta sub))) (fromInput input)  -- Continuation preparation {-| Converts a partial parser into a return continuation in a manner similar to `buildHandler`. -@since 1.5.0.0+@since 1.8.0.0 -} suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -- ^ The partial parser to turn into a return continuation.         -> Γ s o xs n r a                                  -- ^ The state to execute the continuation with.-        -> (Code (Rep o) -> Offset o)                      -- ^ Function used to generate the offset+        -> (Input# o -> Input o)                           -- ^ Function used to generate the offset         -> StaCont s o a x suspend m γ off = mkStaCont $ \x o# -> m (γ {operands = Op (FREEVAR x) (operands γ), input = off o#}) @@ -353,15 +357,18 @@        -> (Γ s o (x : xs) (Succ n) r a -> Code (ST s (Maybe a))) -- ^ The return continuation to generate        -> Γ s o xs (Succ n) r a                                  --        -> Code (ST s (Maybe a))-callCC u sub k γ = callWithContinuation sub (suspend k γ (chooseOffset (successInputCharacteristic (meta sub)) o)) (offset o) (handlers γ)+callCC u sub k γ = callWithContinuation sub (suspend k γ (chooseOffset (successInputCharacteristic (meta sub)))) inp (handlers γ)   where-    o :: Offset o-    o = input γ+    inp :: Input o+    inp = input γ -    chooseOffset :: InputCharacteristic -> Offset o -> Code (Rep o) -> Offset o-    chooseOffset (AlwaysConsumes n) o qo# = moveN n o qo#-    chooseOffset NeverConsumes      o qo# = o {offset = qo#}-    chooseOffset MayConsume         _ qo# = mkOffset qo# u+    -- TODO: move to Offset module (along with Input#?)+    chooseOffset :: InputCharacteristic -> Input# o -> Input o+    chooseOffset (AlwaysConsumes n) inp#  = inp { off = moveN n (off inp) (off# inp#), pos = pos# inp# }+    -- Technically, in this case, we know the whole input is unchanged. This essentially ignores the continuation arguments+    -- hopefully GHC could optimise this better?+    chooseOffset NeverConsumes      _inp# = inp -- { off = (off inp) {offset = off# inp# }, pos = pos# inp# }+    chooseOffset MayConsume         inp#  = toInput u inp#  {- Join Point Operations -} {-|@@ -378,7 +385,7 @@ setupJoinPoint φ (Machine k) mx = freshUnique $ \u ->     liftM2 (\mk ctx γ ->       setupJoinPoint# @o-        (\qx qo# -> mk (γ {operands = Op (FREEVAR qx) (operands γ), input = mkOffset qo# u}))+        (\qx inp -> mk (γ {operands = Op (FREEVAR qx) (operands γ), input = toInput u inp}))         (\qjoin -> run mx γ (insertΦ φ (mkStaContDyn qjoin) ctx)))       (local voidCoins k) ask @@ -389,7 +396,7 @@ using failure, and this failure does not discriminate whether or not the loop consumed input in its final iteration. -@since 1.4.0.0+@since 1.8.0.0 -} bindIterAlways :: forall s o a. RecBuilder o                => Ctx s o a                  -- ^ The context to keep the binding@@ -397,21 +404,21 @@                -> Machine s o '[] One Void a -- ^ The body of the loop.                -> Bool                       -- ^ Does loop exit require a binding?                -> StaHandlerBuilder s o a    -- ^ What to do after the loop exits (by failing)-               -> Offset o                   -- ^ The initial offset to provide to the loop+               -> Input o                    -- ^ The initial offset to provide to the loop                -> Word                       -- ^ The unique name for captured offset /and/ iteration offset                -> Code (ST s (Maybe a))-bindIterAlways ctx μ l needed h o u =-  bindIterHandlerInline# @o needed (\qc# -> staHandler# (h (mkOffset qc# u))) $ \qhandler ->-    bindIter# @o (offset o) $ \qloop qo# ->-      let off = mkOffset qo# u-      in run l (Γ Empty noreturn off (VCons (augmentHandler (Just off) (qhandler qo#)) VNil))-               (voidCoins (insertSub μ (mkStaSubroutine $ \_ o# _ -> [|| $$qloop $$(o#) ||]) ctx))+bindIterAlways ctx μ l needed h inp u =+  bindIterHandlerInline# @o needed (staHandler# . h . toInput u) $ \qhandler ->+    bindIter# @o (fromInput inp) $ \qloop inp# ->+      let inp = toInput u inp#+      in run l (Γ Empty noreturn inp (VCons (augmentHandler (Just inp) (qhandler inp#)) VNil))+               (voidCoins (insertSub μ (mkStaSubroutine $ \_ _ inp -> [|| $$qloop $$(pos# inp) $$(off# inp) ||]) ctx))  {-| Similar to `bindIterAlways`, but builds a handler that performs in the same way as `bindSameHandler`. -@since 1.4.0.0+@since 1.8.0.0 -} bindIterSame :: forall s o a. (RecBuilder o, HandlerOps o, PositionOps (Rep o))              => Ctx s o a                  -- ^ The context to store the binding in.@@ -421,18 +428,18 @@              -> StaHandler s o a           -- ^ The handler when input is the same.              -> Bool                       -- ^ Is a binding required for the differing handler?              -> StaHandlerBuilder s o a    -- ^ The handler when input differs.-             -> Offset o                   -- ^ The initial offset of the loop.+             -> Input o                   -- ^ The initial offset of the loop.              -> Word                       -- ^ The unique name of the captured offsets /and/ the iteration offset.              -> Code (ST s (Maybe a))-bindIterSame ctx μ l neededYes yes neededNo no o u =+bindIterSame ctx μ l neededYes yes neededNo no inp u =   bindHandlerInline# @o neededYes (staHandler# yes) $ \qyes ->-    bindIterHandlerInline# neededNo (\qc# -> staHandler# (no (mkOffset qc# u))) $ \qno ->-      let handler qc# o = [||if $$(same qc# o) then $$(staHandler# qyes qc#) else $$(staHandler# (qno qc#) o)||]+    bindIterHandlerInline# neededNo (staHandler# . no . toInput u) $ \qno ->+      let handler inpc inpo = [||if $$(same (off# inpc) (off# inpo)) then $$(staHandler# qyes inpc) else $$(staHandler# (qno inpc) inpo)||]       in bindIterHandlerInline# @o True handler $ \qhandler ->-        bindIter# @o (offset o) $ \qloop qo# ->-          let off = mkOffset qo# u-          in run l (Γ Empty noreturn off (VCons (augmentHandlerFull off (qhandler qo#) (staHandler# qyes qo#) (qno qo#)) VNil))-                   (voidCoins (insertSub μ (mkStaSubroutine $ \_ o# _ -> [|| $$qloop $$(o#) ||]) ctx))+        bindIter# @o (fromInput inp) $ \qloop inp# ->+          let off = toInput u inp#+          in run l (Γ Empty noreturn off (VCons (augmentHandlerFull off (qhandler inp#) (staHandler# qyes inp#) (qno inp#)) VNil))+                   (voidCoins (insertSub μ (mkStaSubroutine $ \_ _ inp -> [|| $$qloop $$(pos# inp) $$(off# inp) ||]) ctx))  {- Recursion Operations -} {-|@@ -452,9 +459,9 @@          -> DynFunc rs s o a r buildRec μ rs ctx k meta =   takeFreeRegisters rs ctx $ \ctx ->-    bindRec# @o $ \qself qret qo# qh ->-      run k (Γ Empty (mkStaContDyn qret) (mkOffset qo# 0) (VCons (augmentHandlerDyn Nothing qh) VNil))-            (insertSub μ (mkStaSubroutineMeta meta $ \k o# h -> [|| $$qself $$k $$(o#) $$h ||]) (nextUnique ctx))+    bindRec# @o $ \qself qret qh inp ->+      run k (Γ Empty (mkStaContDyn qret) (toInput 0 inp) (VCons (augmentHandlerDyn Nothing qh) VNil))+            (insertSub μ (mkStaSubroutineMeta meta $ \k h inp -> [|| $$qself $$k $$h $$(pos# inp) $$(off# inp) ||]) (nextUnique ctx))  {- Binding Operations -} bindHandlerInline# :: forall o s a b. HandlerOps o@@ -471,10 +478,10 @@  bindIterHandlerInline# :: forall o s a b. RecBuilder o                        => Bool-                       -> (Code (Rep o) -> StaHandler# s o a)-                       -> ((Code (Rep o) -> StaHandler s o a) -> Code b)+                       -> (Input# o -> StaHandler# s o a)+                       -> ((Input# o -> StaHandler s o a) -> Code b)                        -> Code b-bindIterHandlerInline# True  h k = bindIterHandler# @o h $ \qh -> k (\qo -> fromDynHandler [||$$qh $$qo||])+bindIterHandlerInline# True  h k = bindIterHandler# @o h $ \qh -> k (\inp -> fromDynHandler [||$$qh $$(pos# inp) $$(off# inp)||]) bindIterHandlerInline# False h k = k (fromStaHandler# . h)  {- Marshalling Operations -}@@ -508,8 +515,8 @@ @since 1.2.0.0 -} logHandler :: (?ops :: InputOps (Rep o), LogHandler o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Word -> StaHandlerBuilder s o a-logHandler name ctx γ u _ = let VCons h _ = handlers γ in fromStaHandler# $ \o# -> let o = mkOffset o# u in [||-    trace $$(preludeString name '<' (γ {input = o}) ctx (color Red " Fail")) $$(staHandlerEval h o)+logHandler name ctx γ u _ = let VCons h _ = handlers γ in fromStaHandler# $ \inp# -> let inp = toInput u inp# in [||+    trace $$(preludeString name '<' (γ {input = inp}) ctx (color Red " Fail")) $$(staHandlerEval h inp)   ||]  {-|@@ -527,7 +534,7 @@               -> Code String preludeString name dir γ ctx ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]   where-    offset          = Offset.offset (input γ)+    offset          = Offset.offset (off (input γ))     indent          = replicate (debugLevel ctx * 2) ' '     start           = shiftLeft offset [||5#||]     end             = shiftRight offset [||5#||]@@ -569,4 +576,4 @@  @since 1.2.0.0 -}-type StaHandlerBuilder s o a = Offset o -> StaHandler s o a+type StaHandlerBuilder s o a = Input o -> StaHandler s o a

@@ -0,0 +1,89 @@+{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NumericUnderscores #-}+{-|+Module      : Parsley.Internal.Backend.Machine.PosOps+Description : Collection of platform dependent position operations+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : experimental++This module contains the implementations of updates on positions: these depend on the number of+bits in a word, or if the @full-width-positions@ flag was set on the @parsley-core@ library.++@since 1.8.0.0+-}+module Parsley.Internal.Backend.Machine.PosOps (module Parsley.Internal.Backend.Machine.PosOps) where++#include "MachDeps.h"+#if WORD_SIZE_IN_BITS < 64+#define FULL_WIDTH_POSITIONS+#endif++import Parsley.Internal.Backend.Machine.Types.Base (Pos)+import Parsley.Internal.Common                     (Code)+import GHC.Exts                                    (Int(..))+import GHC.Prim                                    (plusWord#, and#, or#, word2Int#,+#ifdef FULL_WIDTH_POSITIONS+                                                    minusWord#+#else+                                                    uncheckedShiftRL#+#endif+                                                   )++{-|+Given a position and a character, returns the representation of the updated position.++@since 1.8.0.0+-}+updatePos :: Code Pos -> Code Char -> Code Pos+updatePos pos c = [||updatePos# $$pos $$c||]++{-|+The initial position used by the parser. This is some representation of (1, 1).++@since 1.8.0.0+-}+initPos :: Code Pos++{-# INLINEABLE updatePos# #-}+{-|+Updates a given position assuming the given character was read. Tab characters are aligned to the+nearest 4th space boundary.++@since 1.8.0.0+-}+updatePos# :: Pos -> Char -> Pos++{-|+Given the opaque representation of a position, extracts the line number out of it.++@since 1.8.0.0+-}+extractLine :: Code Pos -> Code Int++{-|+Given the opaque representation of a position, extracts the column number out of it.++@since 1.8.0.0+-}+extractCol :: Code Pos -> Code Int++#ifndef FULL_WIDTH_POSITIONS+initPos = [|| 0x00000001_00000001## ||]++updatePos# pos '\n' = (pos `and#` 0xffffffff_00000000##) `plusWord#` 0x00000001_00000001##+updatePos# pos '\t' = ((pos `plusWord#` 0x00000000_00000003##) `and#` 0xffffffff_fffffffc##) `or#` 0x00000000_00000001##+updatePos# pos _    = pos `plusWord#` 0x00000000_00000001##++extractLine qpos = [||I# (word2Int# ($$qpos `uncheckedShiftRL#` 32#))||]+extractCol qpos = [||I# (word2Int# ($$qpos `and#` 0x00000000_ffffffff##))||]++#else+initPos = [|| (# 1##, 1## #) ||]++updatePos# (# line, _ #)   '\n' = (# line `plusWord#` 1##, 1## #)+updatePos# (# line, col #) '\t' = (# line, ((col `plusWord#` 3##) `and#` (0## `minusWord#` 4##)) `or#` 1## #) -- nearest tab boundary `c + (4 - (c - 1) % 4)`+updatePos# (# line, col #) _    = (# line, col `plusWord#` 1## #)++extractLine qpos = [|| case $$qpos of (# line, _ #) -> I# (word2Int# line) ||]+extractCol qpos = [|| case $$qpos of (# _, col #) -> I# (word2Int# col) ||]+#endif

@@ -1,5 +1,7 @@-{-# LANGUAGE MagicHash,-             TypeFamilies #-}+{-# LANGUAGE CPP,+             MagicHash,+             TypeFamilies,+             UnboxedTuples #-} {-| Module      : Parsley.Internal.Backend.Machine.Types.Base Description : Base types representing core machine components@@ -19,17 +21,35 @@ import Control.Monad.ST                          (ST) import Data.STRef                                (STRef) import Data.Kind                                 (Type)+import GHC.Prim                                  (Word#) import Parsley.Internal.Backend.Machine.InputRep (Rep) +#include "MachDeps.h"+#if WORD_SIZE_IN_BITS < 64+#define FULL_WIDTH_POSITIONS+#endif+ {-|+The type of positions within a parser. This may or may not be packed into a single `Word#`++@since 1.8.0.0+-}+#ifndef FULL_WIDTH_POSITIONS+type Pos = Word#+#else+type Pos = (# Word#, Word# #)+#endif++{-| @Handler#@ represents the functions that handle failure within a-parser. For most of their life, handlers are represented as +parser. For most of their life, handlers are represented as `Parsley.Internal.Backend.Machine.Types.Statics.StaHandler`, but @Handler#@ is used at the boundaries, such as for recursion.  @since 1.4.0.0 -}-type Handler# s o a =  Rep o          -- ^ The current input on failure +type Handler# s o a =  Pos            -- ^ The current position+                    -> Rep o          -- ^ The current input on failure                     -> ST s (Maybe a)  {-|@@ -39,6 +59,7 @@ @since 1.4.0.0 -} type Cont# s o a x =  x              -- ^ The value to be returned to the caller+                   -> Pos            -- ^ The current position                    -> Rep o          -- ^ The new input after the call is executed                    -> ST s (Maybe a) @@ -49,8 +70,9 @@ @since 1.4.0.0 -} type Subroutine# s o a x =  Cont# s o a x  -- ^ What to do when this parser returns-                         -> Rep o          -- ^ The input on entry to the call                          -> Handler# s o a -- ^ How to handle failure within the call+                         -> Pos            -- ^ The current position+                         -> Rep o          -- ^ The input on entry to the call                          -> ST s (Maybe a)  {-|

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass,              MagicHash,-             DerivingStrategies #-}+             DerivingStrategies,+             UnboxedTuples #-} {-| Module      : Parsley.Internal.Backend.Machine.Types.Context Description : Fully static context required to generate a parser@@ -66,7 +67,7 @@ import Parsley.Internal.Backend.Machine.LetBindings    (Regs(..)) import Parsley.Internal.Backend.Machine.Types.Coins    (Coins, willConsume, canReclaim) import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynSubroutine)-import Parsley.Internal.Backend.Machine.Types.Offset   (Offset)+import Parsley.Internal.Backend.Machine.Types.Input    (Input) import Parsley.Internal.Backend.Machine.Types.Statics  (QSubroutine(..), StaFunc, StaSubroutine, StaCont) import Parsley.Internal.Common                         (Queue, enqueue, dequeue, Code, RewindQueue) @@ -89,7 +90,7 @@                      , coins      :: Int                               -- ^ Number of tokens free to consume without length check.                      , offsetUniq :: Word                              -- ^ Next unique offset identifier.                      , piggies    :: Queue Coins                       -- ^ Queue of future length check credit.-                     , knownChars :: RewindQueue (Code Char, Offset o) -- ^ Characters that can be reclaimed on backtrack.+                     , knownChars :: RewindQueue (Code Char, Input o) -- ^ Characters that can be reclaimed on backtrack.                      }  {-|@@ -409,7 +410,7 @@ {-| Asks if the current coin total can afford a charge of \(n\) characters. -This is used by `DrainCoins`, which will have to emit a full length check+This is used by `Parsley.Internal.Backend.Instructions.DrainCoins`, which will have to emit a full length check of size \(n\) if this quota cannot be reached.  @since 1.5.0.0@@ -423,7 +424,7 @@  @since 1.5.0.0 -}-addChar :: Code Char -> Offset o -> Ctx s o a -> Ctx s o a+addChar :: Code Char -> Input o -> Ctx s o a -> Ctx s o a addChar c o ctx = ctx { knownChars = enqueue (c, o) (knownChars ctx) }  {-|@@ -433,9 +434,9 @@  @since 1.5.0.0 -}-readChar :: Ctx s o a                                      -- ^ The original context.-         -> ((Code Char -> Offset o -> Code b) -> Code b)  -- ^ The fallback source of input.-         -> (Code Char -> Offset o -> Ctx s o a -> Code b) -- ^ The continuation that needs the read characters and updated context.+readChar :: Ctx s o a                                     -- ^ The original context.+         -> ((Code Char -> Input o -> Code b) -> Code b)  -- ^ The fallback source of input.+         -> (Code Char -> Input o -> Ctx s o a -> Code b) -- ^ The continuation that needs the read characters and updated context.          -> Code b readChar ctx fallback k   | reclaimable = unsafeReadChar ctx k

@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-} {-| Module      : Parsley.Internal.Backend.Machine.Types.Dynamics Description : Representation of components that cross function boundaries

@@ -0,0 +1,57 @@+{-# LANGUAGE UnboxedTuples, MagicHash, RecordWildCards #-}+{-|+Module      : Parsley.Internal.Backend.Machine.Types.Input+Description : Packaging of offsets and positions.+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : experimental++Exposes abstractions for working with combined offset and position information. `Input` is used+for static augmented information, and `Input#` is a raw combination of the two components.++@since 1.8.0.0+-}+module Parsley.Internal.Backend.Machine.Types.Input (module Parsley.Internal.Backend.Machine.Types.Input) where++import Parsley.Internal.Backend.Machine.InputRep           (Rep)+import Parsley.Internal.Backend.Machine.Types.Base         (Pos)+import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset(offset), mkOffset)+--import Parsley.Internal.Backend.Machine.Types.Input.Pos    ()+import Parsley.Internal.Common.Utils                       (Code)++{-|+Packages known static information about offsets (via `Offset`) with static information about positions+(currently unavailable).++@since 1.8.0.0+-}+data Input o = Input {+    off  :: Offset o,+    pos :: Code Pos+  }++{-|+Packages a dynamic offset with a dynamic position.++@since 1.8.0.0+-}+data Input# o = Input# {+    off#  :: Code (Rep o),+    pos#  :: Code Pos+  }++{-|+Strips away static information, returning the raw dynamic components.++@since 1.8.0.0+-}+fromInput :: Input o -> Input# o+fromInput Input{..} = Input# (offset off) pos++{-|+Given a unique identifier, forms a plainly annotated static combination of position and offset.++@since 1.8.0.0+-}+toInput :: Word -> Input# o -> Input o+toInput u Input#{..} = Input (mkOffset off# u) pos#

@@ -0,0 +1,100 @@+{-# LANGUAGE DerivingStrategies, UnboxedTuples #-}+{-|+Module      : Parsley.Internal.Backend.Machine.Types.Input.Offset+Description : Statically refined offsets.+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : experimental++This module contains the statically refined `Offset` type,+which can be used to reason about input in different parts of+a parser as it is evaluated.++@since 1.8.0.0+-}+module Parsley.Internal.Backend.Machine.Types.Input.Offset (+    Offset, mkOffset, offset, moveOne, moveN, same,+  ) where++import Parsley.Internal.Backend.Machine.InputRep   (Rep)+import Parsley.Internal.Common.Utils               (Code)++{-|+Augments a regular @'Code' ('Rep' o)@ with information about its origins and+how much input is known to have been consumed since it came into existence.+This can be used to statically evaluate handlers (see+`Parsley.Internal.Backend.Machine.Types.Statics.staHandlerEval`).++@since 1.5.0.0+-}+data Offset o = Offset {+    -- | The underlying code that represents the current offset into the input.+    offset :: Code (Rep o),+    -- | The unique identifier that determines where this offset originated from.+    unique :: Word,+    -- | The amount of input that has been consumed on this offset since it was born.+    moved  :: Amount+  }++data Amount = Amount Word {- ^ The multiplicity. -} Word {- ^ The additive offset. -}+  deriving stock Eq++{-|+Given two `Offset`s, this determines whether or not they represent the same+offset into the input stream at runtime. This comparison only makes sense when+both `Offset`s share the same origin, hence the @Maybe@.++@since 1.4.0.0+-}+same :: Offset o -> Offset o -> Maybe Bool+same o1 o2+  | unique o1 == unique o2 = Just (moved o1 == moved o2)+  | otherwise = Nothing++{-|+Updates an `Offset` with its new underlying representation of a real+runtime offset and records that another character has been consumed.++@since 1.4.0.0+-}+moveOne :: Offset o -> Code (Rep o) -> Offset o+moveOne = moveN (Just 1)++{-|+Updates an `Offset` with its new underlying representation of a real+runtime offset and records that several more characters have been consumed.+Here, `Nothing` represents an unknown but non-zero amount of characters.++@since 1.5.0.0+-}+moveN :: Maybe Word -> Offset o -> Code (Rep o) -> Offset o+moveN n off o = off { offset = o, moved = moved off `add` toAmount n }+  where+    toAmount :: Maybe Word -> Amount+    toAmount Nothing = Amount 1 0+    toAmount (Just n) = Amount 0 n++{-|+Makes a fresh `Offset` that has not had any input consumed off of it+yet.++@since 1.4.0.0+-}+mkOffset :: Code (Rep o) -> Word -> Offset o+mkOffset offset unique = Offset offset unique (Amount 0 0)++add :: Amount -> Amount -> Amount+add a1@(Amount n i) a2@(Amount m j)+  -- If the multiplicites don't match then this is _even_ more unknowable+  | n /= m, n /= 0, m /= 0 = Amount (n + m) 0+  -- This is a funny case, it shouldn't happen and it's not really clear what happens if it does+  | n /= 0, m /= 0         = error ("adding " ++ show a1 ++ " and " ++ show a2 ++ " makes no sense?")+  -- If one of the multiplicites is 0 then the offset can be added+  | otherwise              = Amount (max n m) (i + j)++-- Instances+instance Show (Offset o) where+  show o = show (unique o) ++ "+" ++ show (moved o)++instance Show Amount where+  show (Amount n m) = show n ++ "*n+" ++ show m

@@ -1,100 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-|-Module      : Parsley.Internal.Backend.Machine.Types.Offset-Description : Statically refined offsets.-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : experimental--This module contains the statically refined `Offset` type,-which can be used to reason about input in different parts of-a parser as it is evaluated.--@since 1.4.0.0--}-module Parsley.Internal.Backend.Machine.Types.Offset (-    Offset, mkOffset, offset, moveOne, moveN, same-  ) where--import Parsley.Internal.Backend.Machine.InputRep    (Rep)-import Parsley.Internal.Common.Utils                (Code)--{-|-Augments a regular @'Code' ('Rep' o)@ with information about its origins and-how much input is known to have been consumed since it came into existence.-This can be used to statically evaluate handlers (see-`Parsley.Internal.Backend.Machine.Types.Statics.staHandlerEval`).--@since 1.5.0.0--}-data Offset o = Offset {-    -- | The underlying code that represents the current offset into the input.-    offset :: Code (Rep o),-    -- | The unique identifier that determines where this offset originated from.-    unique :: Word,-    -- | The amount of input that has been consumed on this offset since it was born.-    moved  :: Amount-  }--data Amount = Amount Word {- ^ The multiplicity. -} Word {- ^ The additive offset. -}-  deriving stock Eq--{-|-Given two `Offset`s, this determines whether or not they represent the same-offset into the input stream at runtime. This comparison only makes sense when-both `Offset`s share the same origin, hence the @Maybe@.--@since 1.4.0.0--}-same :: Offset o -> Offset o -> Maybe Bool-same o1 o2-  | unique o1 == unique o2 = Just (moved o1 == moved o2)-  | otherwise = Nothing--{-|-Updates an `Offset` with its new underlying representation of a real-runtime offset and records that another character has been consumed.--@since 1.4.0.0--}-moveOne :: Offset o -> Code (Rep o) -> Offset o-moveOne = moveN (Just 1)--{-|-Updates an `Offset` with its new underlying representation of a real-runtime offset and records that several more characters have been consumed.-Here, `Nothing` represents an unknown but non-zero amount of characters.--@since 1.5.0.0--}-moveN :: Maybe Word -> Offset o -> Code (Rep o) -> Offset o-moveN n off o = off { offset = o, moved = moved off `add` toAmount n }-  where-    toAmount :: Maybe Word -> Amount-    toAmount Nothing = Amount 1 0-    toAmount (Just n) = Amount 0 n--{-|-Makes a fresh `Offset` that has not had any input consumed off of it-yet.--@since 1.4.0.0--}-mkOffset :: Code (Rep o) -> Word -> Offset o-mkOffset offset unique = Offset offset unique (Amount 0 0)--add :: Amount -> Amount -> Amount-add a1@(Amount n i) a2@(Amount m j)-  -- If the multiplicites don't match then this is _even_ more unknowable-  | n /= m, n /= 0, m /= 0 = Amount (n + m) 0-  -- This is a funny case, it shouldn't happen and it's not really clear what happens if it does-  | n /= 0, m /= 0         = error ("adding " ++ show a1 ++ " and " ++ show a2 ++ " makes no sense?")-  -- If one of the multiplicites is 0 then the offset can be added-  | otherwise              = Amount (max n m) (i + j)---- Instances-instance Show (Offset o) where-  show o = show (unique o) ++ "+" ++ show (moved o)--instance Show Amount where-  show (Amount n m) = show n ++ "*n+" ++ show m

@@ -17,7 +17,7 @@   ) where  import Parsley.Internal.Backend.Machine.Defunc        (Defunc)-import Parsley.Internal.Backend.Machine.Types.Offset  (Offset)+import Parsley.Internal.Backend.Machine.Types.Input   (Input) import Parsley.Internal.Backend.Machine.Types.Statics (StaCont, AugmentedStaHandler) import Parsley.Internal.Common.Vec                    (Vec) @@ -43,6 +43,6 @@ -} data Γ s o xs n r a = Γ { operands :: OpStack xs                        -- ^ The current values available for applicative application.                         , retCont  :: StaCont s o a r                   -- ^ The current return continuation when this parser is finished.-                        , input    :: Offset o                          -- ^ The current offset into the input of the parser.+                        , input    :: Input o                           -- ^ The current offset into the input of the parser.                         , handlers :: Vec n (AugmentedStaHandler s o a) -- ^ The failure handlers that are used to process failure during a parser.                         }

@@ -1,7 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes,              MagicHash,+             RecordWildCards,              TypeApplications,-             TypeFamilies #-}+             TypeFamilies,+             UnboxedTuples #-} {-| Module      : Parsley.Internal.Backend.Machine.Types.Statics Description : Representation of components that exist within a statically known component@@ -44,15 +46,15 @@     staSubroutine#, meta,   ) where -import Control.Monad.ST                                (ST)-import Data.STRef                                      (STRef)-import Data.Kind                                       (Type)-import Data.Maybe                                      (fromMaybe)-import Parsley.Internal.Backend.Machine.InputRep       (Rep)-import Parsley.Internal.Backend.Machine.LetBindings    (Regs(..), Metadata, newMeta, InputCharacteristic(..))-import Parsley.Internal.Backend.Machine.Types.Dynamics (DynCont, DynHandler, DynFunc)-import Parsley.Internal.Backend.Machine.Types.Offset   (Offset(offset), same)-import Parsley.Internal.Common.Utils                   (Code)+import Control.Monad.ST                                    (ST)+import Data.STRef                                          (STRef)+import Data.Kind                                           (Type)+import Data.Maybe                                          (fromMaybe)+import Parsley.Internal.Backend.Machine.LetBindings        (Regs(..), Metadata, newMeta, InputCharacteristic(..))+import Parsley.Internal.Backend.Machine.Types.Dynamics     (DynCont, DynHandler, DynFunc)+import Parsley.Internal.Backend.Machine.Types.Input        (Input(..), Input#(..), fromInput)+import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset, same)+import Parsley.Internal.Common.Utils                       (Code)  -- Handlers {-|@@ -60,12 +62,12 @@ but where the static function structure has been exposed. This allows for β-reduction on handlers, a simple form of inlining optimisation. -@since 1.4.0.0+@since 1.8.0.0 -}-type StaHandler# s o a = Code (Rep o) -> Code (ST s (Maybe a))+type StaHandler# s o a = Input# o -> Code (ST s (Maybe a))  mkStaHandler# :: forall o s a. DynHandler s o a -> StaHandler# s o a-mkStaHandler# dh qo# = [||$$dh $$(qo#)||]+mkStaHandler# dh inp = [||$$dh $$(pos# inp) $$(off# inp)||]  {-| Encapsulates a static handler with its possible dynamic origin for costless conversion.@@ -119,9 +121,9 @@ the handler has captured. This is a purely static handler, which is not derived from a dynamic one. -@since 1.7.0.0+@since 1.8.0.0 -}-augmentHandlerSta :: Maybe (Offset o) -> StaHandler# s o a -> AugmentedStaHandler s o a+augmentHandlerSta :: Maybe (Input o) -> StaHandler# s o a -> AugmentedStaHandler s o a augmentHandlerSta o = augmentHandler o . fromStaHandler#  {-|@@ -133,7 +135,7 @@  @since 1.7.0.0 -}-augmentHandlerDyn :: forall s o a. Maybe (Offset o) -> DynHandler s o a -> AugmentedStaHandler s o a+augmentHandlerDyn :: forall s o a. Maybe (Input o) -> DynHandler s o a -> AugmentedStaHandler s o a augmentHandlerDyn c = augmentHandler c . fromDynHandler  {-|@@ -141,8 +143,8 @@  @since 1.7.0.0 -}-augmentHandler :: Maybe (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a-augmentHandler c = AugmentedStaHandler c . mkUnknown+augmentHandler :: Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a+augmentHandler c = AugmentedStaHandler (fmap off c) . mkUnknown  {-| When the behaviours of a handler given input that matches or does not match@@ -153,18 +155,18 @@  @since 1.7.0.0 -}-augmentHandlerFull :: Offset o                  -- ^ The offset captured by the creation of the handler.+augmentHandlerFull :: Input o                   -- ^ The offset captured by the creation of the handler.                    -> StaHandler s o a          -- ^ The full handler, which can be used when offsets are incomparable and must perform the check.                    -> Code (ST s (Maybe a))     -- ^ The code that is executed when the captured offset matches the input.                    -> StaHandler s o a          -- ^ The handler to be executed when offsets are known not to match.                    -> AugmentedStaHandler s o a -- ^ A handler that carries this information around for later refinement.-augmentHandlerFull c handler yes no = AugmentedStaHandler (Just c)+augmentHandlerFull c handler yes no = AugmentedStaHandler (Just (off c))   (mkFull handler           yes           no)  {-|-Unlike `staHandler#`, which returns a handler that accepts @'Code' ('Rep' o)@, this+Unlike `staHandler#`, which returns a handler that accepts @'Input' o@, this function accepts a full `Parsley.Internal.Backend.Machine.Types.Offset.Offset`, which can be used to refine the outcome of the execution of the handler as follows: @@ -178,11 +180,11 @@  @since 1.7.0.0 -}-staHandlerEval :: AugmentedStaHandler s o a -> Offset o -> Code (ST s (Maybe a))-staHandlerEval (AugmentedStaHandler (Just c) sh) o-  | Just True <- same c o                   = maybe (staHandler# (unknown sh)) const (yesSame sh) (offset o)-  | Just False <- same c o                  = staHandler# (fromMaybe (unknown sh) (notSame sh)) (offset o)-staHandlerEval (AugmentedStaHandler _ sh) o = staHandler# (unknown sh) (offset o)+staHandlerEval :: AugmentedStaHandler s o a -> Input o -> Code (ST s (Maybe a))+staHandlerEval (AugmentedStaHandler (Just c) sh) inp+  | Just True <- same c (off inp)             = maybe (staHandler# (unknown sh)) const (yesSame sh) (fromInput inp)+  | Just False <- same c (off inp)            = staHandler# (fromMaybe (unknown sh) (notSame sh)) (fromInput inp)+staHandlerEval (AugmentedStaHandler _ sh) inp = staHandler# (unknown sh) (fromInput inp)  {-| Selects the correct case out of a `AugmentedStaHandler` depending on what the `InputCharacteristic` that@@ -242,9 +244,9 @@ but where the static function structure has been exposed. This allows for β-reduction on continuations, a simple form of inlining optimisation. -@since 1.4.0.0+@since 1.8.0.0 -}-type StaCont# s o a x = Code x -> Code (Rep o) -> Code (ST s (Maybe a))+type StaCont# s o a x = Code x -> Input# o -> Code (ST s (Maybe a))  {-| Compared with `StaCont#`, this type also bundles the static continuation@@ -263,7 +265,7 @@ @since 1.4.0.0 -} mkStaContDyn :: DynCont s o a x -> StaCont s o a x-mkStaContDyn dk = StaCont (\x o# -> [|| $$dk $$x $$(o#) ||]) (Just dk)+mkStaContDyn dk = StaCont (\x inp -> [|| $$dk $$x $$(pos# inp) $$(off# inp) ||]) (Just dk)  {-| Given a static continuation, extracts the underlying continuation which@@ -290,9 +292,9 @@ but where the static function structure has been exposed. This allows for β-reduction on subroutines, a simple form of inlining optimisation: useful for iteration. -@since 1.5.0.0+@since 1.8.0.0 -}-type StaSubroutine# s o a x = DynCont s o a x -> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a))+type StaSubroutine# s o a x = DynCont s o a x -> DynHandler s o a -> Input# o -> Code (ST s (Maybe a))  {-| Packages a `StaSubroutine#` along with statically determined metadata that describes it derived from@@ -352,5 +354,5 @@ qSubroutine func frees meta = QSubroutine (staFunc frees func) frees   where     staFunc :: forall rs. Regs rs -> DynFunc rs s o a x -> StaFunc rs s o a x-    staFunc NoRegs func = StaSubroutine (\dk o# dh -> [|| $$func $$dk $$(o#) $$dh ||]) meta+    staFunc NoRegs func = StaSubroutine (\dk dh inp -> [|| $$func $$dk $$dh $$(pos# inp) $$(off# inp) ||]) meta     staFunc (FreeReg _ witness) func = \r -> staFunc witness [|| $$func $$r ||]

@@ -14,7 +14,7 @@ import Parsley.Internal.Backend.Machine.Defunc        (Defunc(LAM, SAME), pattern FREEVAR, genDefunc, ap, ap2, _if) import Parsley.Internal.Backend.Machine.Identifiers   (MVar(..), ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps      (InputDependant(..), PositionOps, BoxOps, LogOps, InputOps(InputOps))-import Parsley.Internal.Backend.Machine.Instructions  (Instr(..), MetaInstr(..), Access(..))+import Parsley.Internal.Backend.Machine.Instructions  (Instr(..), MetaInstr(..), Access(..), PosSelector(..)) import Parsley.Internal.Backend.Machine.LetBindings   (LetBinding(..)) import Parsley.Internal.Backend.Machine.LetRecBuilder import Parsley.Internal.Backend.Machine.Ops@@ -36,7 +36,7 @@         in letRec fs              nameLet              (\μ exp rs names _meta -> buildRec μ rs (emptyCtx names) (readyMachine exp))-             (run (readyMachine (body binding)) (Γ Empty (halt @o) [||offset||] (VCons (fatal @o) VNil)) . emptyCtx))+             (run (readyMachine (body binding)) (Γ Empty (halt @o) [||offset||] ([||1||], [||1||]) (VCons (fatal @o) VNil)) . emptyCtx))   ||]   where     nameLet :: MVar x -> String@@ -68,6 +68,7 @@     alg (Make σ c k)        = evalMake σ c k     alg (Get σ c k)         = evalGet σ c k     alg (Put σ c k)         = evalPut σ c k+    alg (SelectPos sel k)   = evalSelectPos sel k     alg (LogEnter name k)   = evalLogEnter name k     alg (LogExit name k)    = evalLogExit name k     alg (MetaInstr m k)     = evalMeta m k@@ -76,10 +77,10 @@ evalRet = return $! retCont >>= resume  evalCall :: ContOps o => MVar x -> Machine s o (x : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a-evalCall μ (Machine k) = liftM2 (\mk sub γ@Γ{..} -> callWithContinuation sub (suspend mk γ) input handlers) k (askSub μ)+evalCall μ (Machine k) = liftM2 (\mk sub γ@Γ{..} -> callWithContinuation sub (suspend mk γ) input pos handlers) k (askSub μ)  evalJump :: ContOps o => MVar x -> MachineMonad s o '[] (Succ n) x a-evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation sub retCont input handlers+evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation sub retCont input pos handlers  evalPush :: Defunc x -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a evalPush x (Machine k) = k <&> \m γ -> m (γ {operands = Op x (operands γ)})@@ -143,7 +144,7 @@ evalIter :: (RecBuilder o, ReturnOps o, HandlerOps o)          => MVar Void -> Machine s o '[] One Void a -> Machine s o (o : xs) n r a          -> MachineMonad s o xs n r a-evalIter μ l (Machine h) = liftM2 (\mh ctx γ -> buildIter ctx μ l (buildHandler γ mh) (input γ)) h ask+evalIter μ l (Machine h) = liftM2 (\mh ctx γ -> buildIter ctx μ l (buildHandler γ mh) (input γ) (pos γ)) h ask  evalJoin :: ContOps o => ΦVar x -> MachineMonad s o (x : xs) n r a evalJoin φ = askΦ φ <&> resume@@ -171,6 +172,10 @@ evalPut σ a k = asks $ \ctx γ ->   let Op x xs = operands γ   in writeΣ σ a x (run k (γ {operands = xs})) ctx++evalSelectPos :: PosSelector -> Machine s o (Int : xs) n r a -> MachineMonad s o xs n r a+evalSelectPos Line (Machine k) = k <&> \m γ -> m (γ {operands = Op (FREEVAR (fst (pos γ))) (operands γ)})+evalSelectPos Col (Machine k) = k <&> \m γ -> m (γ {operands = Op (FREEVAR (snd (pos γ))) (operands γ)})  evalLogEnter :: (?ops :: InputOps o, LogHandler o) => String -> Machine s o xs (Succ (Succ n)) r a -> MachineMonad s o xs (Succ n) r a evalLogEnter name (Machine mk) =

@@ -7,12 +7,14 @@              MagicHash,              PatternSynonyms,              RecordWildCards,-             TypeApplications #-}+             TypeApplications,+             UnboxedTuples #-} module Parsley.Internal.Backend.Machine.Ops (module Parsley.Internal.Backend.Machine.Ops) where  import Control.Monad                                 (liftM2) import Control.Monad.Reader                          (ask, local) import Control.Monad.ST                              (ST)+import Data.Bits                                     ((.&.), (.|.)) import Data.STRef                                    (writeSTRef, readSTRef, newSTRef) import Data.Text                                     (Text) import Data.Void                                     (Void)@@ -37,9 +39,21 @@  type Ops o = (LogHandler o, ContOps o, HandlerOps o, JoinBuilder o, RecBuilder o, ReturnOps o, PositionOps o, BoxOps o, LogOps o) +updatePos# :: Int -> Int -> Char -> (# Int, Int #)+updatePos# !line !_ '\n' = (# line + 1, 1 #)+updatePos# !line !col '\t' = (# line, ((col + 3) .&. (-4)) .|. 1 #) -- nearest tab boundary `c + (4 - (c - 1) % 4)`+updatePos# !line !col _    = (# line, col + 1 #)++updatePos :: (Code Int, Code Int) -> Code Char -> ((Code Int, Code Int) -> Code r) -> Code r+updatePos (qline, qcol) qc k = [|| case updatePos# $$qline $$qcol $$qc of (# line', col' #) -> $$(k ([||line'||], [||col'||])) ||]+ {- Input Operations -} sat :: (?ops :: InputOps o) => (Defunc Char -> Defunc Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))-sat p k bad γ@Γ{..} = next input $ \c input' -> let v = FREEVAR c in _if (p v) (k (γ {operands = Op v operands, input = input'})) bad+sat p k bad γ@Γ{..} = next input $ \c input' -> let v = FREEVAR c in+                        updatePos pos c $ \pos' ->+                          _if (p v)+                              (k (γ {operands = Op v operands, input = input', pos = pos'}))+                              bad  emitLengthCheck :: (?ops :: InputOps o, PositionOps o) => Int -> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a)) emitLengthCheck 0 good _ γ   = good γ@@ -99,12 +113,12 @@ #define deriveHandlerOps(_o)                         \ instance HandlerOps _o where                         \ {                                                    \-  buildHandler γ h c = [||\(o# :: Unboxed _o) ->     \+  buildHandler γ h c = [||\(o# :: Unboxed _o) !(line :: Int) !(col :: Int) ->     \     $$(h (γ {operands = Op (FREEVAR c) (operands γ), \-             input = [||$$box o#||]}))||];           \-  fatal = [||\(!_) -> returnST Nothing ||];          \+             input = [||$$box o#||], pos = ([||line||], [||col||])}))||];           \+  fatal = [||\(!_) !_ !_ -> returnST Nothing ||];          \   raise γ = let VCons h _ = handlers γ               \-            in [|| $$h ($$unbox $$(input γ)) ||];    \+            in [|| $$h ($$unbox $$(input γ)) $$(fst (pos γ)) $$(snd (pos γ)) ||];    \ }; inputInstances(deriveHandlerOps) @@ -112,7 +126,7 @@ class BoxOps o => ContOps o where   suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -> Γ s o xs n r a -> Code (Cont s o a x)   resume :: Code (Cont s o a x) -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))-  callWithContinuation :: Code (Subroutine s o a x) -> Code (Cont s o a x) -> Code o -> Vec (Succ n) (Code (Handler s o a)) -> Code (ST s (Maybe a))+  callWithContinuation :: Code (Subroutine s o a x) -> Code (Cont s o a x) -> Code o -> (Code Int, Code Int) -> Vec (Succ n) (Code (Handler s o a)) -> Code (ST s (Maybe a))  class ReturnOps o where   halt :: Code (Cont s o a a)@@ -121,18 +135,18 @@ #define deriveContOps(_o)                                                                      \ instance ContOps _o where                                                                      \ {                                                                                              \-  suspend m γ = [|| \x (!o#) -> $$(m (γ {operands = Op (FREEVAR [||x||]) (operands γ),         \-                                         input = [||$$box o#||]})) ||];                        \-  resume k γ = let Op x _ = operands γ in [|| $$k $$(genDefunc x) ($$unbox $$(input γ)) ||];   \-  callWithContinuation sub ret input (VCons h _) = [||$$sub $$ret ($$unbox $$input) $! $$h||]; \+  suspend m γ = [|| \x (!o#) !l !c -> $$(m (γ {operands = Op (FREEVAR [||x||]) (operands γ),         \+                                             input = [||$$box o#||], pos = ([||l||], [||c||])})) ||];                        \+  resume k γ = let Op x _ = operands γ in [|| $$k $$(genDefunc x) ($$unbox $$(input γ)) $$(fst (pos γ)) $$(snd (pos γ)) ||];   \+  callWithContinuation sub ret input (ql, qc) (VCons h _) = [||$$sub $$ret ($$unbox $$input) $$ql $$qc $! $$h||]; \ }; inputInstances(deriveContOps)  #define deriveReturnOps(_o)                                      \ instance ReturnOps _o where                                      \ {                                                                \-  halt = [||\x _ -> returnST $! Just x||];                       \-  noreturn = [||\_ _ -> error "Return is not permitted here"||]; \+  halt = [||\x _ _ _ -> returnST $! Just x||];                       \+  noreturn = [||\_ _ _ _ -> error "Return is not permitted here"||]; \ }; inputInstances(deriveReturnOps) @@ -143,7 +157,7 @@ class BoxOps o => RecBuilder o where   buildIter :: ReturnOps o             => Ctx s o a -> MVar Void -> Machine s o '[] One Void a-            -> (Code o -> Code (Handler s o a)) -> Code o -> Code (ST s (Maybe a))+            -> (Code o -> Code (Handler s o a)) -> Code o -> (Code Int, Code Int) -> Code (ST s (Maybe a))   buildRec  :: MVar r             -> Regs rs             -> Ctx s o a@@ -155,8 +169,8 @@ {                                                                                         \   setupJoinPoint φ (Machine k) mx =                                                       \     liftM2 (\mk ctx γ -> [||                                                              \-      let join x !(o# :: Unboxed _o) =                                                    \-        $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||$$box o#||]})) \+      let join x !(o# :: Unboxed _o) !(line :: Int) !(col :: Int) =                                                    \+        $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||$$box o#||], pos = ([||line||], [||col||])})) \       in $$(run mx γ (insertΦ φ [||join||] ctx))                                          \     ||]) (local voidCoins k) ask;                                                         \ };@@ -165,17 +179,17 @@ #define deriveRecBuilder(_o)                                                     \ instance RecBuilder _o where                                                     \ {                                                                                \-  buildIter ctx μ l h o = let bx = box in [||                                    \-      let handler !o# = $$(h [||$$bx o#||]);                                     \-          loop !o# =                                                             \+  buildIter ctx μ l h o (line, col) = let bx = box in [||                                    \+      let handler !o# !line !col = $$(h [||$$bx o#||]) line col;                                     \+          loop !o# !line !col =                                                             \         $$(run l                                                                 \-            (Γ Empty (noreturn @_o) [||$$bx o#||] (VCons [||handler o#||] VNil)) \-            (voidCoins (insertSub μ [||\_ (!o#) _ -> loop o#||] ctx)))           \-      in loop ($$unbox $$o)                                                      \+            (Γ Empty (noreturn @_o) [||$$bx o#||] ([||line||], [||col||]) (VCons [||handler o#||] VNil)) \+            (voidCoins (insertSub μ [||\_ (!o#) !line !col _ -> loop o# line col||] ctx)))           \+      in loop ($$unbox $$o) $$line $$col                                                      \     ||];                                                                         \   buildRec _ rs ctx k = let bx = box in takeFreeRegisters rs ctx (\ctx ->        \-    [|| \(!ret) (!o#) h ->                                                       \-      $$(run k (Γ Empty [||ret||] [||$$bx o#||] (VCons [||h||] VNil)) ctx) ||]); \+    [|| \(!ret) (!o#) !line !col h ->                                                       \+      $$(run k (Γ Empty [||ret||] [||$$bx o#||] ([||line||], [||col||]) (VCons [||h||] VNil)) ctx) ||]); \ }; inputInstances(deriveRecBuilder) 

@@ -33,9 +33,9 @@ import qualified Parsley.Internal.Common.Queue as Queue (empty, null)  type HandlerStack n s o a = Vec n (Code (Handler s o a))-type Handler s o a = Unboxed o -> ST s (Maybe a)-type Cont s o a x = x -> Unboxed o -> ST s (Maybe a)-type Subroutine s o a x = Cont s o a x -> Unboxed o -> Handler s o a -> ST s (Maybe a)+type Handler s o a = Unboxed o -> Int -> Int -> ST s (Maybe a)+type Cont s o a x = x -> Unboxed o -> Int -> Int -> ST s (Maybe a)+type Subroutine s o a x = Cont s o a x -> Unboxed o -> Int -> Int -> Handler s o a -> ST s (Maybe a) type MachineMonad s o xs n r a = Reader (Ctx s o a) (Γ s o xs n r a -> Code (ST s (Maybe a)))  type family Func (rs :: [Type]) s o a x where@@ -63,6 +63,7 @@ data Γ s o xs n r a = Γ { operands :: OpStack xs                         , retCont  :: Code (Cont s o a r)                         , input    :: Code o+                        , pos      :: (Code Int, Code Int)                         , handlers :: HandlerStack n s o a }  data Ctx s o a = Ctx { μs         :: DMap MVar (QSubroutine s o a)

@@ -48,6 +48,7 @@     loop,     Reg, newRegister, get, put,     conditional, branch,+    line, col,     debug   ) import Parsley.Internal.Common.Utils    as THUtils    (Quapplicative(..), WQ, Code, makeQ)

@@ -68,6 +68,7 @@ alg _     (Make _ _ k)                            = getConst4 k alg _     (Get _ _ k)                             = getConst4 k alg _     (Put _ _ k)                             = getConst4 k+alg _     (SelectPos _ k)                         = getConst4 k alg _     (LogEnter _ k)                          = getConst4 k alg _     (LogExit _ k)                           = getConst4 k alg _     (MetaInstr (AddCoins _) (Const4 k))     = k

@@ -53,6 +53,7 @@ alg (Make _ Hard k)    = 1 % 3 + getWeight k alg (Get _ Hard k)     = 1 % 3 + getWeight k alg (Put _ Hard k)     = 1 % 3 + getWeight k+alg (SelectPos _ k)    = 1 % 5 + getWeight k alg (Make _ Soft k)    = 1 % 10 + getWeight k alg (Get _ Soft k)     = 0 + getWeight k alg (Put _ Soft k)     = 1 % 10 + getWeight k

@@ -68,6 +68,7 @@ alg (Make _ _ k)       (SSucc n) = VCons False (getStack k n) alg (Get _ _ k)        n         = let VCons _ xs = getStack k (SSucc n) in xs alg (Put _ _ k)        (SSucc n) = VCons False (getStack k n)+alg (SelectPos _ k)    n         = let VCons _ xs = getStack k (SSucc n) in xs alg (LogEnter _ k)     n         = getStack k n alg (LogExit _ k)      n         = getStack k n alg (MetaInstr _ k)    n         = getStack k n

@@ -154,6 +154,7 @@ 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 (Position sel)               m = do return $! In4 (SelectPos sel 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

@@ -24,7 +24,9 @@     -- * Smart Instructions     _App, _Fmap, _Modify, _Make, _Put, _Get,     -- * Smart Meta-Instructions-    addCoins, refundCoins, drainCoins, giveBursary, prefetchChar, blockCoins+    addCoins, refundCoins, drainCoins, giveBursary, prefetchChar, blockCoins,+    -- * Re-exports+    PosSelector(..)   ) where  import Data.Kind                                    (Type)@@ -32,6 +34,7 @@ import Parsley.Internal.Backend.Machine.Identifiers (MVar, ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.Types.Coins (Coins(Coins)) import Parsley.Internal.Common                      (IFunctor4, Fix4(In4), Const4(..), imap4, cata4, Nat(..), One, intercalateDiff)+import Parsley.Internal.Core.CombinatorAST          (PosSelector(..))  import Parsley.Internal.Backend.Machine.Defunc as Machine (Defunc, user) import Parsley.Internal.Core.Defunc            as Core    (Defunc(ID), pattern FLIP_H)@@ -168,6 +171,7 @@             -> Access     {- ^ Whether or not the value needs to be stored in a concrete register. -}             -> k xs n r a             -> Instr o k (x : xs) n r a+  SelectPos :: PosSelector -> k (Int : xs) n r a -> Instr o k xs n r a   {-| Begins a debugging scope, the inner scope requires /two/ handlers,       the first is the log handler itself, and then the second is the       "real" fail handler for when the log handler is executed.@@ -396,6 +400,7 @@   imap4 f (Make σ a k)        = Make σ a (f k)   imap4 f (Get σ a k)         = Get σ a (f k)   imap4 f (Put σ a k)         = Put σ a (f k)+  imap4 f (SelectPos sel k)   = SelectPos sel (f k)   imap4 f (LogEnter name k)   = LogEnter name (f k)   imap4 f (LogExit name k)    = LogExit name (f k)   imap4 f (MetaInstr m k)     = MetaInstr m (f k)@@ -430,6 +435,8 @@       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 (SelectPos Line k)       = "(Line " . getConst4 k . ")"+      alg (SelectPos Col k)        = "(Col " . getConst4 k . ")"       alg (LogEnter _ k)           = getConst4 k       alg (LogExit _ k)            = getConst4 k       alg (MetaInstr BlockCoins k) = getConst4 k

@@ -32,12 +32,17 @@   MakeRegister   :: ΣVar a -> k a -> k b -> Combinator k b   GetRegister    :: ΣVar a -> Combinator k a   PutRegister    :: ΣVar a -> k a -> Combinator k ()+  Position       :: PosSelector -> Combinator k Int   Debug          :: String -> k a -> Combinator k a   MetaCombinator :: MetaCombinator -> k a -> Combinator k a  data ScopeRegister (k :: Type -> Type) (a :: Type) where   ScopeRegister :: k a -> (forall r. Reg r a -> k b) -> ScopeRegister k b +data PosSelector where+  Line :: PosSelector+  Col  :: PosSelector+ {-| This is an opaque representation of a parsing register. It cannot be manipulated as a user, and the type parameter @r@ is used to ensure that it cannot leak out of the scope it has been created in.@@ -76,6 +81,7 @@   imap f (MakeRegister σ p q) = MakeRegister σ (f p) (f q)   imap _ (GetRegister σ)      = GetRegister σ   imap f (PutRegister σ p)    = PutRegister σ (f p)+  imap _ (Position sel)       = Position sel   imap f (Debug name p)       = Debug name (f p)   imap f (MetaCombinator m p) = MetaCombinator m (f p) @@ -100,6 +106,8 @@       alg (MakeRegister σ (Const1 p) (Const1 q))    = "make " . shows σ . " (" . p . ") (" . q . ")"       alg (GetRegister σ)                           = "get " . shows σ       alg (PutRegister σ (Const1 p))                = "put " . shows σ . " (" . p . ")"+      alg (Position Line)                           = "line"+      alg (Position Col)                            = "col"       alg (Debug _ (Const1 p))                      = p       alg (MetaCombinator m (Const1 p))             = p . " [" . shows m . "]" @@ -127,6 +135,7 @@ traverseCombinator expose (MakeRegister σ p q) = MakeRegister σ <$> expose p <*> expose q traverseCombinator _      (GetRegister σ)      = pure (GetRegister σ) traverseCombinator expose (PutRegister σ p)    = PutRegister σ <$> expose p+traverseCombinator _      (Position sel)       = pure (Position sel) traverseCombinator expose (Debug name p)       = Debug name <$> expose p traverseCombinator _      (Pure x)             = pure (Pure x) traverseCombinator _      (Satisfy f)          = pure (Satisfy f)

@@ -7,7 +7,7 @@  import Prelude hiding                      (pure, (<*>)) import Control.Arrow                       (first)-import Parsley.Internal.Core.CombinatorAST (Combinator(..), ScopeRegister(..), Reg(..), Parser(..))+import Parsley.Internal.Core.CombinatorAST (Combinator(..), ScopeRegister(..), Reg(..), Parser(..), PosSelector(..)) #if MIN_VERSION_parsley_core(2,0,0) import Parsley.Internal.Core.Defunc        (Defunc) #else@@ -133,6 +133,14 @@ {-# INLINE put #-} put :: Reg r a -> Parser a -> Parser () put (Reg reg) (Parser p) = Parser (In (L (PutRegister reg p)))++{-# INLINE line #-}+line :: Parser Int+line = Parser (In (L (Position Line)))++{-# INLINE col #-}+col :: Parser Int+col = Parser (In (L (Position Col)))  {-# INLINE debug #-} debug :: String -> Parser a -> Parser a

@@ -64,6 +64,7 @@ compliance (Match p _ qs def)       = seqCompliance p (foldr1 caseCompliance (def:qs)) compliance (MakeRegister _ l r)     = seqCompliance l r compliance (GetRegister _)          = FullPure+compliance (Position _)             = FullPure compliance (PutRegister _ c)        = coerce c compliance (MetaCombinator _ c)     = c @@ -118,6 +119,7 @@ cutAlg (MakeRegister σ l r) cut = seqCutAlg (MakeRegister σ) cut (ifst l) (ifst r) cutAlg (GetRegister σ) _ = (In (GetRegister σ), False) cutAlg (PutRegister σ p) cut = rewrap (PutRegister σ) cut (ifst p)+cutAlg (Position sel) _ = (In (Position sel), False) cutAlg (MetaCombinator m p) cut = rewrap (MetaCombinator m) cut (ifst p)  mkCut :: Bool -> Fix Combinator a -> Fix Combinator a

@@ -53,4 +53,5 @@ alg (MakeRegister _ l r) = 1 % 3 + getWeight l + getWeight r alg (GetRegister _)      = 1 % 3 alg (PutRegister _ c)    = 1 % 3 + getWeight c+alg (Position _)         = 1 % 5 alg (MetaCombinator _ c) = getWeight c

@@ -0,0 +1,142 @@+{-# LANGUAGE TemplateHaskell, UnboxedTuples, ScopedTypeVariables, TypeApplications #-}+module Main where+import Test.Tasty+import Test.Tasty.HUnit+import TestUtils+import qualified Primitive.Parsers as Parsers++import Parsley.Internal (empty, line, col)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Primitive Combinator Tests" [ pureTests+                                               , apTests+                                               , thenTests+                                               , prevTests+                                               , altTests+                                               , emptyTests+                                               , satisfyTests+                                               , lookAheadTests+                                               , notFollowedByTests+                                               , tryTests+                                               , branchTests+                                               , conditionalTests+                                               , recursionTests+                                               , positionTests+                                               ]++pure7 :: String -> Maybe Int+pure7 = $$(parseMocked Parsers.pure7 [||Parsers.pure7||])++pureTests :: TestTree+pureTests = testGroup "pure should"+  [ testCase "not need to consume input" $ pure7 "" @?= Just 7+  , testCase "not fail if there is input" $ pure7 "a" @?= Just 7+  ]++apTests :: TestTree+apTests = testGroup "<*> should" []++thenTests :: TestTree+thenTests = testGroup "*> should" []++prevTests :: TestTree+prevTests = testGroup "<* should" []++abOrC :: String -> Maybe String+abOrC = $$(parseMocked Parsers.abOrC [||Parsers.abOrC||])++abOrCThenD :: String -> Maybe String+abOrCThenD = $$(parseMocked Parsers.abOrCThenD [||Parsers.abOrCThenD||])++altTests :: TestTree+altTests = testGroup "<|> should"+  [ testCase "take the left branch if it succeeds" $ do+      abOrC "ab" @?= Just "ab"+      abOrCThenD "abd" @?= Just "ab"+  , testCase "take the right branch if left failed without consumption" $ do+      abOrC "c" @?= Just "c"+      abOrC "d" @?= Nothing+      abOrCThenD "cd" @?= Just "c"+      abOrCThenD "d" @?= Nothing+  , testCase "fail if the left branch fails and consumes input" $ abOrC "a" @?= Nothing+  ]++constNothing :: String -> Maybe ()+constNothing = $$(parseMocked empty [||empty||])++emptyTests :: TestTree+emptyTests = testGroup "empty should"+  [ testCase "fail the parser with no input" $ constNothing "" @?= Nothing+  , testCase "fail the parser with input" $ constNothing "a" @?= Nothing+  ]++digit :: String -> Maybe Char+digit = $$(parseMocked Parsers.digit [||Parsers.digit||])++twoDigits :: String -> Maybe Char+twoDigits = $$(parseMocked Parsers.twoDigits [||Parsers.twoDigits||])++satisfyTests :: TestTree+satisfyTests = testGroup "satisfy should"+  [ testCase "fail when given no input" $ digit "" @?= Nothing+  , testCase "fail when given incorrect input" $ digit "a" @?= Nothing+  , testCase "succeed when given correct input" $ digit "1" @?= Just '1'+  , testCase "actually consume input" $ twoDigits "1" @?= Nothing+  , testCase "consume more than 1 piece of input with two" $ twoDigits "12" @?= Just '2'+  ]++lookAheadDigit :: String -> Maybe Char+lookAheadDigit = $$(parseMocked Parsers.lookAheadDigit [||Parsers.lookAheadDigit||])++lookAheadTests :: TestTree+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" []++tryTests :: TestTree+tryTests = testGroup "try should" []++branchTests :: TestTree+branchTests = testGroup "branch should" []++conditionalTests :: TestTree+conditionalTests = testGroup "conditional should" []++manyAny :: String -> Maybe String+manyAny = $$(parseMocked Parsers.recursive [||Parsers.recursive||])++recursionTests :: TestTree+recursionTests = testGroup "recursion should"+  [ testCase "work properly" $ manyAny "abc" @?= Just "abc"+  ]++lineStarts1 :: String -> Maybe Int+lineStarts1 = $$(parseMocked line [||line||])++columnStarts1 :: String -> Maybe Int+columnStarts1 = $$(parseMocked col [||col||])++posAfterA :: String -> Maybe (Int, Int)+posAfterA = $$(parseMocked Parsers.posAfterA  [||Parsers.posAfterA||])++posAfterNewline :: String -> Maybe ((Int, Int), (Int, Int))+posAfterNewline = $$(parseMocked Parsers.posAfterNewline  [||Parsers.posAfterNewline||])++posAfterTab :: String -> Maybe ((Int, Int), (Int, Int))+posAfterTab = $$(parseMocked Parsers.posAfterTab  [||Parsers.posAfterTab||])++positionTests :: TestTree+positionTests = testGroup "position combinators should"+  [ testCase "start at line 1" $ lineStarts1 "" @?= Just 1+  , testCase "start at column 1" $ columnStarts1 "" @?= Just 1+  , testCase "advance by 1 column only after regular character" $ posAfterA "a" @?= Just (1, 2)+  , testCase "advance by 1 line and reset column after newline" $ posAfterNewline "a\n\n" @?= Just ((2, 1), (3, 1))+  , testCase "advance to nearest tab boundary on tab" $ posAfterTab "\ta\t" @?= Just ((1, 5), (1, 9))+  ]

@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell #-}+module Primitive.Parsers where++import Prelude hiding (pure, (<*>), (*>), (<*))+import Data.Char (isDigit)+import Parsley.Internal (Parser, Defunc(EMPTY, LIFTED, EQ_H, CONS, LAM_S), makeQ, pure, satisfy, (*>), (<*), (<|>), (<*>), satisfy, lookAhead, line, col)++char :: Char -> Parser Char+char c = satisfy (EQ_H (LIFTED c))++item :: Parser Char+item = satisfy (LAM_S (const (LIFTED True)))++pure7 :: Parser Int+pure7 = pure (LIFTED 7)++digit :: Parser Char+digit = satisfy (makeQ isDigit [||isDigit||])++twoDigits :: Parser Char+twoDigits = digit *> digit++abOrC :: Parser String+abOrC = (char 'a' *> char 'b' *> pure (LIFTED "ab")) <|> (char 'c' *> pure (LIFTED "c"))++abOrCThenD :: Parser String+abOrCThenD = abOrC <* char 'd'++recursive :: Parser [Char]+recursive =+  let r = pure CONS <*> item <*> r <|> pure EMPTY+  in r++lookAheadDigit :: Parser Char+lookAheadDigit = lookAhead digit *> digit++(<~>) :: Parser a -> Parser b -> Parser (a, b)+mx <~> my = pure (makeQ (,) [||(,)||]) <*> mx <*> my++pos :: Parser (Int, Int)+pos = line <~> col++posAfterA :: Parser (Int, Int)+posAfterA = char 'a' *> pos++posAfterNewline :: Parser ((Int, Int), (Int, Int))+posAfterNewline = (char 'a' *> char '\n' *> pos) <~> (char '\n' *> pos)++posAfterTab :: Parser ((Int, Int), (Int, Int))+posAfterTab = (char '\t' *> pos) <~> (char 'a' *> char '\t' *> pos)

@@ -0,0 +1,88 @@+{-# LANGUAGE TemplateHaskell, TypeApplications, DeriveAnyClass, StandaloneDeriving, CPP, FlexibleInstances, MonoLocalBinds, MultiParamTypeClasses #-}+module TestUtils where++import Parsley.Internal (parse, Parser, Code)+import Parsley.Internal.Trace (Trace(..))+import Language.Haskell.TH.Syntax+#if MIN_VERSION_template_haskell(2,17,0)+  hiding (Code)+#endif+import Language.Haskell.TH.TestUtils+import Language.Haskell.TH.TestUtils.QMode+import Control.DeepSeq++#if MIN_VERSION_template_haskell(2,16,0)+import GHC.ForeignPtr+#endif++#if MIN_VERSION_template_haskell(2,17,0)+#else+unTypeCode = unTypeQ+#endif++instance {-# INCOHERENT #-} Trace where+  trace = flip const++-- TODO Use WQ: requires lift plugin to not require any Lift instance for variables (if missing)+parseMocked :: Trace => Parser a -> Code (Parser a) -> Code (String -> Maybe a)+parseMocked p qp = [|| \s ->+    parseMocked' $$qp `deepseq` $$(parse p) s+  ||]++parseMocked' :: Parser a -> Exp+parseMocked' = runTestQ (QState MockQ [] []) . unTypeCode . parse @String++deriving instance NFData Exp+deriving instance NFData Name+deriving instance NFData OccName+deriving instance NFData NameFlavour+deriving instance NFData ModName+deriving instance NFData NameSpace+deriving instance NFData PkgName+deriving instance NFData Lit+#if MIN_VERSION_template_haskell(2,16,0)+deriving instance NFData Bytes+instance NFData (ForeignPtr a) where rnf = rwhnf+#endif+deriving instance NFData Type+#if MIN_VERSION_template_haskell(2,17,0)+deriving instance NFData a => NFData (TyVarBndr a)+deriving instance NFData Specificity+#else+deriving instance NFData TyVarBndr+#endif+deriving instance NFData Pat+deriving instance NFData TyLit+deriving instance NFData Match+deriving instance NFData Body+deriving instance NFData Guard+deriving instance NFData Stmt+deriving instance NFData Dec+deriving instance NFData Clause+deriving instance NFData Con+deriving instance NFData Bang+deriving instance NFData SourceUnpackedness+deriving instance NFData SourceStrictness+deriving instance NFData DerivClause+deriving instance NFData Range+deriving instance NFData DerivStrategy+deriving instance NFData FunDep+deriving instance NFData Overlap+deriving instance NFData Foreign+deriving instance NFData Callconv+deriving instance NFData Fixity+deriving instance NFData FixityDirection+deriving instance NFData Safety+deriving instance NFData Pragma+deriving instance NFData Inline+deriving instance NFData TySynEqn+deriving instance NFData RuleMatch+deriving instance NFData TypeFamilyHead+deriving instance NFData FamilyResultSig+deriving instance NFData Phases+deriving instance NFData Role+deriving instance NFData InjectivityAnn+deriving instance NFData RuleBndr+deriving instance NFData PatSynArgs+deriving instance NFData AnnTarget+deriving instance NFData PatSynDir