parsley 0.1.1.0 → 1.0.0.0

raw patch · 48 files changed

+28/−4801 lines, 48 filesdep +parsley-coredep −arraydep −bytestringdep −containersPVP ok

version bump matches the API change (PVP)

Dependencies added: parsley-core

Dependencies removed: array, bytestring, containers, dependent-map, dependent-sum, ghc-prim, hashable, mtl, pretty-terminal, unordered-containers

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.md +5/−13
• parsley.cabal +8/−74
• src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs +0/−49
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs +0/−53
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +0/−185
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs +0/−231
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputRep.hs +0/−155
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs +0/−233
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs +0/−160
• src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs +0/−50
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs +0/−39
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs +0/−183
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputOps.hs +0/−229
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputRep.hs +0/−131
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs +0/−221
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs +0/−160
• src/ghc/Parsley.hs +4/−6
• src/ghc/Parsley/Defunctionalized.hs +7/−2
• src/ghc/Parsley/Internal.hs +0/−36
• src/ghc/Parsley/Internal/Backend.hs +0/−16
• src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +0/−192
• src/ghc/Parsley/Internal/Backend/InstructionAnalyser.hs +0/−123
• src/ghc/Parsley/Internal/Backend/Machine/Identifiers.hs +0/−30
• src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +0/−141
• src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs +0/−32
• src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs +0/−50
• src/ghc/Parsley/Internal/Backend/Optimiser.hs +0/−17
• src/ghc/Parsley/Internal/Common.hs +0/−22
• src/ghc/Parsley/Internal/Common/Fresh.hs +0/−124
• src/ghc/Parsley/Internal/Common/Indexed.hs +0/−98
• src/ghc/Parsley/Internal/Common/Queue.hs +0/−41
• src/ghc/Parsley/Internal/Common/State.hs +0/−87
• src/ghc/Parsley/Internal/Common/Utils.hs +0/−116
• src/ghc/Parsley/Internal/Common/Vec.hs +0/−23
• src/ghc/Parsley/Internal/Core.hs +0/−19
• src/ghc/Parsley/Internal/Core/CombinatorAST.hs +0/−132
• src/ghc/Parsley/Internal/Core/Defunc.hs +0/−175
• src/ghc/Parsley/Internal/Core/Identifiers.hs +0/−44
• src/ghc/Parsley/Internal/Core/InputTypes.hs +0/−38
• src/ghc/Parsley/Internal/Core/Primitives.hs +0/−247
• src/ghc/Parsley/Internal/Frontend.hs +0/−14
• src/ghc/Parsley/Internal/Frontend/CombinatorAnalyser.hs +0/−241
• src/ghc/Parsley/Internal/Frontend/Compiler.hs +0/−179
• src/ghc/Parsley/Internal/Frontend/Dependencies.hs +0/−164
• src/ghc/Parsley/Internal/Frontend/Optimiser.hs +0/−177
• src/ghc/Parsley/Internal/Trace.hs +0/−20
• src/ghc/Parsley/Internal/Verbose.hs +0/−29

@@ -15,3 +15,7 @@ * Added `IF_S`, `LAM_S` and `LET_S` to `Defunc`, which can be used with overloaded syntax * Admin: Removed `idioms-plugin` and `lift-plugin` from the test suite, depending on `parsley-garnish` instead * Fixed building with GHC 9++## 1.0.0.0 -- 2021-06-12++* Factored all of the `Parsley.Internal` modules out into `parsley-core` package

@@ -1,21 +1,13 @@-# Parsley ![GitHub Workflow Status](https://img.shields.io/github/workflow/status/j-mie6/ParsleyHaskell/CI) ![GitHub release](https://img.shields.io/github/v/release/j-mie6/ParsleyHaskell) [![GitHub license](https://img.shields.io/github/license/j-mie6/ParsleyHaskell.svg)](https://github.com/j-mie6/ParsleyHaskell/blob/master/LICENSE) ![GitHub commits since latest release (by SemVer)](https://img.shields.io/github/commits-since/j-mie6/ParsleyHaskell/latest)+# Parsley  ## What is Parsley? Parsley is a very fast parser combinator library that outperforms the other libraries in both the parsec family, as well as Happy. To make this possible, it makes use of Typed Template Haskell to generate the code for the parsers. -## How do I use it? [![Hackage Version](https://img.shields.io/hackage/v/parsley)](https://hackage.haskell.org/package/parsley) ![Dependent repos (via libraries.io)](https://img.shields.io/librariesio/dependent-repos/hackage/parsley)+## How do I use it? Parsley is distributed on Hackage, and can be added by depending on the package `parsley`. -The version policy adheres to the regular Haskell PVP, but the two major versions are distinguished-in Parsley: the first is the _User API_ major version, which represents backwards incompatible changes-in the regular PVP sense that could affect any users of the library; the second version is the-_Internal API_ major version, which would only effect users who use part of the internal parsley-modules. As such, for people that are **not** explicitly importing anything from `Parsley.Internal`, or-its submodules, the second major version does not matter: `0.2.0.0` and `0.3.0.0` would be compatible,-for instance.- To use it, you'll need to write you parsers in another file from where they will be used: this is due to Template Haskell. @@ -51,7 +43,7 @@ char c = satisfy (WQ (== c) [||(== c)||]) ``` -Using `WQ` explicitly like this can get annoying, which is what the `parsley-garnish` package is for!+Using `WQ` explicitly like this can get annoying, which is what the [`parsley-garnish`](https://hackage.haskell.org/package/parsley-garnish) package is for! Currently, the garnish provides one plugin called `OverloadedQuotes`, which replaces the behaviour of the default _Untyped_ Template Haskell quotes in a file so that they produce one of `WQ` or `Defunc`. See the `Parsley.OverloadedQuotesPlugin` module in the [`parsley-garnish`](https://hackage.haskell.org/package/parsley-garnish) package for more information.@@ -66,8 +58,8 @@ ## Bug Reports If you encounter a bug when using Parsley, try and minimise the example of the parser (and the input) that triggers the bug. If possible, make a self contained example: this will help me to identify the-issue without too much issue. It might be helpful to import `Parsley.Internal.Verbose` to provide a-debug dump that I can check out.+issue without too much issue. It might be helpful to import `parsley-core:Parsley.Internal.Verbose` to provide a+debug dump that I can check out (see [`parsley-core`](https://hackage.haskell.org/package/parsley-core)).  ## References * This work spawned a paper at ICFP 2020: [**Staged Selective Parser Combinators**](https://dl.acm.org/doi/10.1145/3409002)

@@ -2,10 +2,10 @@ name:                parsley -- https://wiki.haskell.org/Package_versioning_policy -- PVP summary:      +--------- breaking API changes---                   | +------- breaking internal API changes+--                   | +------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.1.1.0+version:             1.0.0.0 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         Parsley is a staged selective parser combinator library, which means                      it does not support monadic operations, and relies on Typed Template@@ -14,18 +14,9 @@                      .                      Based on the work found in [/Staged Selective Parser Combinators/                      (Willis et al. 2020)](https://dl.acm.org/doi/10.1145/3409002)-                     .-                     While this library adheres to the Haskell PVP, it additionally-                     enforces an additional constraint: the version @M.I.m.p@ represents-                     a breaking change to the /user/ API @M@, a breaking change-                     to the /internal/ API @I@ (which will not affect most users), an addition-                     to either API @m@, and patches or performance improvements @p@.-                     As such, users should feel free to bound themselves on the next @M@-                     version of the library as opposed to the second @I@ version if they-                     do not make use of the "Parsley.Internal" package or any of its children.  -homepage:            https://github.com/j-mie6/ParsleyHaskell+homepage:            https://github.com/j-mie6/ParsleyHaskell/tree/master/parsley bug-reports:         https://github.com/j-mie6/ParsleyHaskell/issues license:             BSD-3-Clause license-file:        LICENSE@@ -35,9 +26,10 @@ build-type:          Simple extra-doc-files:     ChangeLog.md                      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+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 == 9.0.1  library   exposed-modules:     Parsley,@@ -51,48 +43,6 @@                        Parsley.InputExtras,                        Parsley.Precedence -                       Parsley.Internal,-                       Parsley.Internal.Trace,-                       Parsley.Internal.Verbose,--                       Parsley.Internal.Common,-                       Parsley.Internal.Common.Fresh,-                       Parsley.Internal.Common.Indexed,-                       Parsley.Internal.Common.Queue,-                       Parsley.Internal.Common.State,-                       Parsley.Internal.Common.Utils,-                       Parsley.Internal.Common.Vec,--                       Parsley.Internal.Core,-                       Parsley.Internal.Core.CombinatorAST,-                       Parsley.Internal.Core.Defunc,-                       Parsley.Internal.Core.Identifiers,-                       Parsley.Internal.Core.InputTypes,-                       Parsley.Internal.Core.Primitives,--                       Parsley.Internal.Frontend,-                       Parsley.Internal.Frontend.CombinatorAnalyser,-                       Parsley.Internal.Frontend.Compiler,-                       Parsley.Internal.Frontend.Dependencies,-                       Parsley.Internal.Frontend.Optimiser,--                       Parsley.Internal.Backend,-                       Parsley.Internal.Backend.CodeGenerator,-                       Parsley.Internal.Backend.InstructionAnalyser,-                       Parsley.Internal.Backend.Optimiser,--                       Parsley.Internal.Backend.Machine,-                       Parsley.Internal.Backend.Machine.Defunc,-                       Parsley.Internal.Backend.Machine.Eval,-                       Parsley.Internal.Backend.Machine.LetBindings,-                       Parsley.Internal.Backend.Machine.LetRecBuilder,-                       Parsley.Internal.Backend.Machine.Identifiers,-                       Parsley.Internal.Backend.Machine.InputOps,-                       Parsley.Internal.Backend.Machine.InputRep,-                       Parsley.Internal.Backend.Machine.Instructions,-                       Parsley.Internal.Backend.Machine.Ops,-                       Parsley.Internal.Backend.Machine.State-   default-extensions:  BangPatterns,                        DataKinds,                        GADTs,@@ -109,25 +59,10 @@  --                     ghc                  >= 8.6     && < 9.2,   build-depends:       base                 >= 4.10    && < 4.16,-                       mtl                  >= 2.2.1   && < 2.3,-                       hashable             >= 1.2.7.0 && < 1.4,-                       unordered-containers >= 0.2.13  && < 0.3,-                       array                >= 0.5.2   && < 0.6,-                       ghc-prim             >= 0.5.3   && < 1,+                       parsley-core         >= 1       && < 2,                        template-haskell     >= 2.14    && < 3,-                       containers           >= 0.6     && < 0.7,-                       dependent-map        >= 0.4.0   && < 0.5,-                       dependent-sum        >= 0.7.1   && < 0.8,-                       pretty-terminal      >= 0.1.0   && < 0.2,                        text                 >= 1.2.3   && < 1.3,-                       -- Not sure about this one, 0.11.0.0 introduced a type synonym for PS, so it _should_ work-                       bytestring           >= 0.10.8  && < 0.12-  build-tool-depends:  cpphs:cpphs          >= 1.18.8  && < 1.21   hs-source-dirs:      src/ghc-  if impl(ghc >= 8.10)-    hs-source-dirs:    src/ghc-8.10+-  else-    hs-source-dirs:    src/ghc-8.6+   default-language:    Haskell2010   ghc-options:         -Wall -Weverything -Wcompat                        -Wno-unticked-promoted-constructors@@ -141,7 +76,6 @@                        -Wno-missed-specialisations                        -Wno-all-missed-specialisations                        -Wno-incomplete-uni-patterns-                       -pgmP cpphs -optP --cpp                        -freverse-errors   if impl(ghc >= 8.10)     ghc-options:       -Wno-missing-safe-haskell-mode

@@ -1,49 +0,0 @@-{-|-Module      : Parsley.Internal.Backend.Machine-Description : The implementation of the low level parsing machinery is found here-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : unstable--@since 0.1.0.0--}-module Parsley.Internal.Backend.Machine (-    Input, eval,-    PositionOps,-    module Parsley.Internal.Backend.Machine.Instructions,-    module Parsley.Internal.Backend.Machine.Defunc,-    module Parsley.Internal.Backend.Machine.Identifiers,-    module Parsley.Internal.Backend.Machine.LetBindings-  ) where--import Data.Array.Unboxed                            (UArray)-import Data.ByteString                               (ByteString)-import Data.Dependent.Map                            (DMap)-import Data.Text                                     (Text)-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(..))-import Parsley.Internal.Backend.Machine.Identifiers-import Parsley.Internal.Backend.Machine.InputOps     (InputPrep(..), PositionOps)-import Parsley.Internal.Backend.Machine.Instructions-import Parsley.Internal.Backend.Machine.LetBindings  (LetBinding, makeLetBinding)-import Parsley.Internal.Backend.Machine.Ops          (Ops)-import Parsley.Internal.Common.Utils                 (Code)-import Parsley.Internal.Core.InputTypes-import Parsley.Internal.Trace                        (Trace)--import qualified Data.ByteString.Lazy as Lazy (ByteString)-import qualified Parsley.Internal.Backend.Machine.Eval as Eval (eval)--eval :: forall input a. (Input input, Trace) => Code input -> (LetBinding input a a, DMap MVar (LetBinding input a)) -> Code (Maybe a)-eval input (toplevel, bindings) = Eval.eval (prepare input) toplevel bindings--class (InputPrep input, Ops input) => Input input-instance Input [Char]-instance Input (UArray Int Char)-instance Input Text16-instance Input ByteString-instance Input CharList-instance Input Text---instance Input CacheText-instance Input Lazy.ByteString---instance Input Lazy.ByteString-instance Input Stream

@@ -1,53 +0,0 @@-{-# LANGUAGE StandaloneKindSignatures, TypeApplications #-}-module Parsley.Internal.Backend.Machine.Defunc (module Parsley.Internal.Backend.Machine.Defunc) where--import Data.Proxy                                (Proxy(Proxy))-import Parsley.Internal.Backend.Machine.InputOps (PositionOps(same))-import Parsley.Internal.Backend.Machine.InputRep (Rep)-import Parsley.Internal.Common.Utils             (Code, WQ(WQ))--import qualified Parsley.Internal.Core.Defunc as Core (Defunc(BLACK), ap, genDefunc, genDefunc1, genDefunc2)--data Defunc a where-  USER    :: Core.Defunc a -> Defunc a-  BOTTOM  :: Defunc a-  SAME    :: PositionOps o => Defunc (o -> o -> Bool)-  FREEVAR :: Code a -> Defunc a-  OFFSET  :: Code (Rep o) -> Defunc o--ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c-ap2 f@SAME (OFFSET o1) (OFFSET o2) = USER (black (apSame f o1 o2))-  where-    apSame :: forall o. Defunc (o -> o -> Bool) -> Code (Rep o) -> Code (Rep o) -> Code Bool-    apSame SAME = same (Proxy @o)-    apSame _    = undefined-ap2 f x y = USER (Core.ap (Core.ap (seal f) (seal x)) (seal y))-  where-    seal :: Defunc a -> Core.Defunc a-    seal (USER x) = x-    seal x        = black (genDefunc x)--black :: Code a -> Core.Defunc a-black = Core.BLACK . WQ undefined--genDefunc :: Defunc a -> Code a-genDefunc (USER x)    = Core.genDefunc x-genDefunc BOTTOM      = [||undefined||]-genDefunc (FREEVAR x) = x-genDefunc SAME        = error "Cannot materialise the same function in the regular way"-genDefunc (OFFSET _)  = error "Cannot materialise an unboxed offset in the regular way"--genDefunc1 :: Defunc (a -> b) -> Code a -> Code b-genDefunc1 (USER f) qx = Core.genDefunc1 f qx-genDefunc1 f qx        = [|| $$(genDefunc f) $$qx ||]--genDefunc2 :: Defunc (a -> b -> c) -> Code a -> Code b -> Code c-genDefunc2 (USER f) qx qy = Core.genDefunc2 f qx qy-genDefunc2 f qx qy        = [|| $$(genDefunc f) $$qx $$qy ||]--instance Show (Defunc a) where-  show (USER x) = show x-  show SAME = "same"-  show BOTTOM = "[[irrelevant]]"-  show (FREEVAR _) = "x"-  show (OFFSET _)  = "an offset"

@@ -1,185 +0,0 @@-{-# LANGUAGE ImplicitParams,-             MultiWayIf,-             RecordWildCards,-             TypeApplications,-             UnboxedTuples #-}-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)-import Control.Monad.Reader                           (ask, asks, local)-import Control.Monad.ST                               (runST)-import Parsley.Internal.Backend.Machine.Defunc        (Defunc(FREEVAR, OFFSET), genDefunc, genDefunc1, ap2)-import Parsley.Internal.Backend.Machine.Identifiers   (MVar(..), ΦVar, ΣVar)-import Parsley.Internal.Backend.Machine.InputOps      (InputDependant, PositionOps, LogOps, InputOps(InputOps))-import Parsley.Internal.Backend.Machine.InputRep      (Rep)-import Parsley.Internal.Backend.Machine.Instructions  (Instr(..), MetaInstr(..), Access(..))-import Parsley.Internal.Backend.Machine.LetBindings   (LetBinding(..))-import Parsley.Internal.Backend.Machine.LetRecBuilder-import Parsley.Internal.Backend.Machine.Ops-import Parsley.Internal.Backend.Machine.State-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)--eval :: forall o a. (Trace, Ops o) => Code (InputDependant (Rep o)) -> LetBinding o a a -> DMap MVar (LetBinding o a) -> Code (Maybe a)-eval input (LetBinding !p _) fs = trace ("EVALUATING TOP LEVEL") [|| runST $-  do let (# next, more, offset #) = $$input-     $$(let ?ops = InputOps [||more||] [||next||]-        in letRec fs-             nameLet-             (\exp rs names -> buildRec rs (emptyCtx names) (readyMachine exp))-             (\names -> run (readyMachine p) (Γ Empty (halt @o) [||offset||] (VCons (fatal @o) VNil)) (emptyCtx names)))-  ||]-  where-    nameLet :: MVar x -> String-    nameLet (MVar i) = "sub" ++ show i--readyMachine :: (?ops :: InputOps (Rep o), Ops o, Trace) => Fix4 (Instr o) xs n r a -> Machine s o xs n r a-readyMachine = cata4 (Machine . alg)-  where-    alg :: (?ops :: InputOps (Rep o), Ops o) => Instr o (Machine s o) xs n r a -> MachineMonad s o xs n r a-    alg Ret                 = evalRet-    alg (Call μ k)          = evalCall μ k-    alg (Jump μ)            = evalJump μ-    alg (Push x k)          = evalPush x k-    alg (Pop k)             = evalPop k-    alg (Lift2 f k)         = evalLift2 f k-    alg (Sat p k)           = evalSat p k-    alg Empt                = evalEmpt-    alg (Commit k)          = evalCommit k-    alg (Catch k h)         = evalCatch k h-    alg (Tell k)            = evalTell k-    alg (Seek k)            = evalSeek k-    alg (Case p q)          = evalCase p q-    alg (Choices fs ks def) = evalChoices fs ks def-    alg (Iter μ l k)        = evalIter μ l k-    alg (Join φ)            = evalJoin φ-    alg (MkJoin φ p k)      = evalMkJoin φ p k-    alg (Swap k)            = evalSwap k-    alg (Dup k)             = evalDup k-    alg (Make σ c k)        = evalMake σ c k-    alg (Get σ c k)         = evalGet σ c k-    alg (Put σ c k)         = evalPut σ c k-    alg (LogEnter name k)   = evalLogEnter name k-    alg (LogExit name k)    = evalLogExit name k-    alg (MetaInstr m k)     = evalMeta m k--evalRet :: MachineMonad s o (x : xs) n x a-evalRet = return $! retCont >>= resume--evalCall :: forall s o a x xs n r. 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 @o sub (suspend mk γ) input handlers) k (askSub μ)--evalJump :: forall s o a x n. MVar x -> MachineMonad s o '[] (Succ n) x a-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 γ)})--evalPop :: Machine s o xs n r a -> MachineMonad s o (x : xs) n r a-evalPop (Machine k) = k <&> \m γ -> m (γ {operands = let Op _ xs = operands γ in xs})--evalLift2 :: Defunc (x -> y -> z) -> Machine s o (z : xs) n r a -> MachineMonad s o (y : x : xs) n r a-evalLift2 f (Machine k) = k <&> \m γ -> m (γ {operands = let Op y (Op x xs) = operands γ in Op (ap2 f x y) xs})--evalSat :: (?ops :: InputOps (Rep o), PositionOps o, Trace) => Defunc (Char -> Bool) -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a-evalSat p (Machine k) = do-  bankrupt <- asks isBankrupt-  hasChange <- asks hasCoin-  if | bankrupt -> maybeEmitCheck (Just 1) <$> k-     | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k-     | otherwise -> trace "I have a piggy :)" $ local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)-  where-    maybeEmitCheck Nothing mk γ = sat (genDefunc1 p) mk (raise γ) γ-    maybeEmitCheck (Just n) mk γ =-      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (genDefunc1 p) mk [||bad||]) [||bad||] γ)||]--evalEmpt :: MachineMonad s o xs (Succ n) r a-evalEmpt = return $! raise--evalCommit :: Machine s o xs n r a -> MachineMonad s o xs (Succ n) r a-evalCommit (Machine k) = k <&> \mk γ -> let VCons _ hs = handlers γ in mk (γ {handlers = hs})--evalCatch :: HandlerOps o => Machine s o xs (Succ n) r a -> Machine s o (o : xs) n r a -> MachineMonad s o xs n r a-evalCatch (Machine k) (Machine h) = liftM2 (\mk mh γ -> setupHandler γ (buildHandler γ mh) mk) k h--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 γ)})--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})--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 γ ->-  let Op e xs = operands γ-  in [||case $$(genDefunc e) of-    Left x -> $$(mp (γ {operands = Op (FREEVAR [||x||]) xs}))-    Right y  -> $$(mq (γ {operands = Op (FREEVAR [||y||]) xs}))||]) p q--evalChoices :: [Defunc (x -> Bool)] -> [Machine s o xs n r a] -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a-evalChoices fs ks (Machine def) = liftM2 (\mdef mks γ -> let Op x xs = operands γ in go x fs mks mdef (γ {operands = xs}))-  def-  (forM ks getMachine)-  where-    go x (f:fs) (mk:mks) def γ = [||-        if $$(genDefunc1 f (genDefunc x)) then $$(mk γ)-        else $$(go x fs mks def γ)-      ||]-    go _ _ _ def γ = def γ--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--evalJoin :: ΦVar x -> MachineMonad s o (x : xs) n r a-evalJoin φ = askΦ φ <&> resume--evalMkJoin :: JoinBuilder o => ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a-evalMkJoin = setupJoinPoint--evalSwap :: Machine s o (x : y : xs) n r a -> MachineMonad s o (y : x : xs) n r a-evalSwap (Machine k) = k <&> \mk γ -> mk (γ {operands = let Op y (Op x xs) = operands γ in Op x (Op y xs)})--evalDup :: Machine s o (x : x : xs) n r a -> MachineMonad s o (x : xs) n r a-evalDup (Machine k) = k <&> \mk γ ->-  let Op x xs = operands γ-  in dup x $ \dupx -> mk (γ {operands = Op dupx (Op dupx xs)})--evalMake :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a-evalMake σ a k = asks $! \ctx γ ->-  let Op x xs = operands γ-  in newΣ σ a x (run k (γ {operands = xs})) ctx--evalGet :: ΣVar x -> Access -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a-evalGet σ a k = asks $! \ctx γ -> readΣ σ a (\x -> run k (γ {operands = Op x (operands γ)})) ctx--evalPut :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a-evalPut σ a k = asks $! \ctx γ ->-  let Op x xs = operands γ-  in writeΣ σ a x (run k (γ {operands = xs})) ctx--evalLogEnter :: (?ops :: InputOps (Rep 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) =-  liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '>' γ ctx "") $$(setupHandler γ (logHandler name ctx γ) k)||])-    (local debugUp mk)-    ask--evalLogExit :: (?ops :: InputOps (Rep o), PositionOps o, LogOps (Rep o)) => String -> Machine s o xs n r a -> MachineMonad s o xs n r a-evalLogExit name (Machine mk) =-  liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '<' γ (debugDown ctx) (color Green " Good")) $$(k γ) ||])-    (local debugDown mk)-    ask--evalMeta :: (?ops :: InputOps (Rep o), PositionOps o) => MetaInstr n -> Machine s o xs n r a -> MachineMonad s o xs n r a-evalMeta (AddCoins coins) (Machine k) =-  do requiresPiggy <- asks hasCoin-     if requiresPiggy then local (storePiggy coins) k-     else local (giveCoins coins) k <&> \mk γ -> emitLengthCheck coins mk (raise γ) γ-evalMeta (RefundCoins coins) (Machine k) = local (giveCoins coins) k-evalMeta (DrainCoins coins) (Machine k) = liftM2 (\n mk γ -> emitLengthCheck n mk (raise γ) γ) (asks ((coins -) . liquidate)) k

@@ -1,231 +0,0 @@-{-# LANGUAGE ImplicitParams,-             MagicHash,-             TypeApplications,-             UnboxedTuples #-}-module Parsley.Internal.Backend.Machine.InputOps (-    InputPrep(..), PositionOps(..), LogOps(..),-    InputOps(..), more, next,-    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 Data.Proxy                                (Proxy)-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-import Parsley.Internal.Common.Utils             (Code)-import Parsley.Internal.Core.InputTypes--import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))---import qualified Data.Text                     as Text (length, index)--{- Auxillary Representation -}-type InputDependant (rep :: TYPE r) = (# {-next-} rep -> (# Char, rep #)-                                       , {-more-} rep -> Bool-                                       , {-init-} rep-                                       #)--{- Typeclasses -}-class InputPrep input where-  prepare :: rep ~ Rep input => Code input -> Code (InputDependant rep)--class PositionOps input where-  same :: rep ~ Rep input => Proxy input -> Code rep -> Code rep -> Code Bool-  shiftRight :: rep ~ Rep input => Proxy input -> Code rep -> Code Int# -> Code rep--class LogOps (rep :: TYPE r) where-  shiftLeft :: Code rep -> Code Int# -> Code rep-  offToInt  :: Code rep -> Code Int--data InputOps (rep :: TYPE r) = InputOps { _more       :: Code (rep -> Bool)-                                         , _next       :: Code (rep -> (# Char, rep #))-                                         }-more :: forall r (rep :: TYPE r). (?ops :: InputOps rep) => Code (rep -> Bool)-more = _more ?ops-next :: forall r (rep :: TYPE r) a. (?ops :: InputOps rep) => Code rep -> (Code Char -> Code rep -> Code a) -> Code a-next ts k = [|| let !(# t, ts' #) = $$(_next ?ops) $$ts in $$(k [||t||] [||ts'||]) ||]--{- INSTANCES -}--- InputPrep Instances-instance InputPrep [Char] where-  prepare input = prepare @(UArray Int Char) [||listArray (0, length $$input-1) $$input||]--instance InputPrep (UArray Int Char) where-  prepare qinput = [||-      let UArray _ _ (I# size#) input# = $$qinput-          next i# = (# C# (indexWideCharArray# input# i#), i# +# 1# #)-      in (# next, \qi -> $$(intLess [||qi||] [||size#||]), 0# #)-    ||]--instance InputPrep Text16 where-  prepare qinput = [||-      let Text16 (Text arr (I# off#) (I# size#)) = $$qinput-          arr# = aBA arr-          next i# = (# C# (chr# (word2Int# (indexWord16Array# arr# i#))), i# +# 1# #)-      in (# next, \qi -> $$(intLess [||qi||] [||size#||]), off# #)-    ||]--instance InputPrep ByteString where-  prepare qinput = [||-      let PS (ForeignPtr addr# final) (I# off#) (I# size#) = $$qinput-          next i# =-            case readWord8OffAddr# (addr# `plusAddr#` i#) 0# realWorld# of-              (# s', x #) -> case touch# final s' of-                _ -> (# C# (chr# (word2Int# x)), i# +# 1# #)-      in  (# next, \qi -> $$(intLess [||qi||] [||size#||]), off# #)-    ||]--instance InputPrep CharList where-  prepare qinput = [||-      let CharList input = $$qinput-          next (# i#, c:cs #) = (# c, (# i# +# 1#, cs #) #)-          I# size# = length input-          more (# i#, _ #) = $$(intLess [||i#||] [||size#||])-          --more (OffWith _ []) = False-          --more _              = True-      in (# next, more, $$(offWith [||input||]) #)-    ||]--instance InputPrep Text where-  prepare qinput = [||-      let next t@(Text arr off unconsumed) = let !(Iter c d) = iter t 0 in (# c, Text arr (off+d) (unconsumed-d) #)-          more (Text _ _ unconsumed) = unconsumed > 0-      in (# next, more, $$qinput #)-    ||]--instance InputPrep Lazy.ByteString where-  prepare qinput = [||-      let next (# i#, addr#, final, off#, size#, cs #) =-            case readWord8OffAddr# addr# off# realWorld# of-              (# s', x #) -> case touch# final s' of-                _ -> (# C# (chr# (word2Int# x)),-                    if I# size# /= 1 then (# i# +# 1#, addr#, final, off# +# 1#, size# -# 1#, cs #)-                    else case cs of-                      Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' ->-                        (# i# +# 1#, addr'#, final', off'#, size'#, cs' #)-                      Lazy.Empty -> $$(emptyUnpackedLazyByteString [||i# +# 1#||])-                  #)-          more :: UnpackedLazyByteString -> Bool-          more (# _, _, _, _, 0#, _ #) = False-          more (# _, _, _, _, _, _ #) = True--          initial :: UnpackedLazyByteString-          initial = case $$qinput of-            Lazy.Chunk (PS (ForeignPtr addr# final) (I# off#) (I# size#)) cs -> (# 0#, addr#, final, off#, size#, cs #)-            Lazy.Empty -> $$(emptyUnpackedLazyByteString [||0#||])-      in (# next, more, initial #)-    ||]--instance InputPrep Stream where-  prepare qinput = [||-      let next (# o#, c :> cs #) = (# c, (# o# +# 1#, cs #) #)-      in (# next, \_ -> True, $$(offWith qinput) #)-    ||]--shiftRightInt :: Code Int# -> Code Int# -> Code Int#-shiftRightInt qo# qi# = [||$$(qo#) +# $$(qi#)||]---- PositionOps Instances-instance PositionOps [Char] where-  same _ = intSame-  shiftRight _ = shiftRightInt-instance PositionOps (UArray Int Char) where-  same _ = intSame-  shiftRight _ = shiftRightInt-instance PositionOps Text16 where-  same _ = intSame-  shiftRight _ = shiftRightInt-instance PositionOps ByteString where-  same _ = intSame-  shiftRight _ = shiftRightInt--instance PositionOps CharList where-  same _ = offWithSame-  shiftRight _ qo# qi# = offWithShiftRight [||drop||] qo# qi#--instance PositionOps Stream where-  same _ = offWithSame-  shiftRight _ qo# qi# = offWithShiftRight [||dropStream||] qo# qi#--instance PositionOps Text where-  same _ qt1 qt2 = [||$$(offsetText qt1) == $$(offsetText qt2)||]-  shiftRight _ qo# qi# = [||textShiftRight $$(qo#) (I# $$(qi#))||]--instance PositionOps Lazy.ByteString where-  same _ qx# qy# = [||-      case $$(qx#) of-        (# i#, _, _, _, _, _ #) -> case $$(qy#) of-          (# j#, _, _, _, _, _ #) -> $$(intSame [||i#||] [||j#||])-    ||]-  shiftRight _ qo# qi# = [||byteStringShiftRight $$(qo#) $$(qi#)||]---- LogOps Instances-instance LogOps Int# where-  shiftLeft qo# qi# = [||max# ($$(qo#) -# $$(qi#)) 0#||]-  offToInt qi# = [||I# $$(qi#)||]--instance LogOps (# Int#, ts #) where-  shiftLeft qo# _ = qo#-  offToInt qo# = [||case $$(qo#) of (# i#, _ #) -> I# i#||]--instance LogOps Text where-  shiftLeft qo qi# = [||textShiftLeft $$qo (I# $$(qi#))||]-  offToInt qo = [||case $$qo of Text _ off _ -> div off 2||]--instance LogOps UnpackedLazyByteString where-  shiftLeft qo# qi# = [||byteStringShiftLeft $$(qo#) $$(qi#)||]-  offToInt qo# = [||case $$(qo#) of (# i#, _, _, _, _, _ #) -> I# i# ||]--{- Old Instances -}-{-instance Input CacheText (Text, Stream) where-  prepare qinput = [||-      let (CacheText input) = $$qinput-          next (t@(Text arr off unconsumed), _) = let !(Iter c d) = iter t 0 in (# c, (Text arr (off+d) (unconsumed-d), nomore) #)-          more (Text _ _ unconsumed, _) = unconsumed > 0-          same (Text _ i _, _) (Text _ j _, _) = i == j-          (Text arr off unconsumed, _) << i = go i off unconsumed-            where-              go 0 off' unconsumed' = (Text arr off' unconsumed', nomore)-              go n off' unconsumed'-                | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)-                | otherwise = (Text arr off' unconsumed', nomore)-          (Text arr off unconsumed, _) >> i = go i off unconsumed-            where-              go 0 off' unconsumed' = (Text arr off' unconsumed', nomore)-              go n off' unconsumed'-                | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)-                | otherwise = (Text arr off' unconsumed', nomore)-          toInt (Text arr off unconsumed, _) = div off 2-          box (# text, cache #) = (text, cache)-          unbox (text, cache) = (# text, cache #)-          newCRef (Text _ i _, _) = newSTRefU i-          readCRef ref = fmap (\i -> (Text empty i 0, nomore)) (readSTRefU ref)-          writeCRef ref (Text _ i _, _) = writeSTRefU ref i-      in PreparedInput next more same (input, nomore) box unbox newCRef readCRef writeCRef s(<<) (>>) toInt-    ||]--instance Input Lazy.ByteString (OffWith Lazy.ByteString) where-  prepare qinput = [||-      let next (OffWith i (Lazy.Chunk (PS ptr@(ForeignPtr addr# final) off@(I# off#) size) cs)) =-            case readWord8OffAddr# addr# off# realWorld# of-              (# s', x #) -> case touch# final s' of-                _ -> (# C# (chr# (word2Int# x)), OffWith (i+1) (if size == 1 then cs-                                                                else Lazy.Chunk (PS ptr (off+1) (size-1)) cs) #)-          more (OffWith _ Lazy.Empty) = False-          more _ = True-          ow@(OffWith _ (Lazy.Empty)) << _ = ow-          OffWith o (Lazy.Chunk (PS ptr off size) cs) << i =-            let d = min off i-            in OffWith (o - d) (Lazy.Chunk (PS ptr (off - d) (size + d)) cs)-          ow@(OffWith _ Lazy.Empty) >> _ = ow-          OffWith o (Lazy.Chunk (PS ptr off size) cs) >> i-            | i < size  = OffWith (o + i) (Lazy.Chunk (PS ptr (off + i) (size - i)) cs)-            | otherwise = OffWith (o + size) cs >> (i - size)-          readCRef ref = fmap (\i -> OffWith i Lazy.Empty) (readSTRefU ref)-      in PreparedInput next more offWithSame (offWith $$qinput) offWithBox offWithUnbox offWithNewORef readCRef offWithWriteORef (<<) (>>) offWithToInt-    ||]-}

@@ -1,155 +0,0 @@-{-# LANGUAGE MagicHash,-             TypeFamilies,-             UnboxedTuples,-             StandaloneKindSignatures #-}-module Parsley.Internal.Backend.Machine.InputRep (-    Rep, RepKind,-    intSame, intLess, min#, max#,-    OffWith, offWith, offWithSame, offWithShiftRight,-    --OffWithStreamAnd(..),-    UnpackedLazyByteString, emptyUnpackedLazyByteString,-    Stream, dropStream,-    offsetText,-    representationTypes,-    -- These must be exposed-    textShiftRight, textShiftLeft,-    byteStringShiftRight, byteStringShiftLeft-  ) where--import Data.Array.Unboxed                (UArray)-import Data.ByteString.Internal          (ByteString(..))-import Data.Kind                         (Type)-import Data.Text.Internal                (Text(..))-import Data.Text.Unsafe                  (iter_, reverseIter_)-import GHC.Exts                          (Int(..), TYPE, RuntimeRep(..), (==#), (<#), (+#), (-#), isTrue#)-import GHC.ForeignPtr                    (ForeignPtr(..), ForeignPtrContents)-import GHC.Prim                          (Int#, Addr#, nullAddr#)-import Parsley.Internal.Common.Utils     (Code)-import Parsley.Internal.Core.InputTypes  (Text16, CharList, Stream(..))--import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))-import qualified Language.Haskell.TH           as TH   (Q, Type)--{- Representation Types -}-type OffWith ts = (# Int#, ts #)---data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts-type UnpackedLazyByteString = (#-    Int#,-    Addr#,-    ForeignPtrContents,-    Int#,-    Int#,-    Lazy.ByteString-  #)--representationTypes :: [TH.Q TH.Type]-representationTypes = [[t|[Char]|], [t|UArray Int Char|], [t|Text16|], [t|ByteString|], [t|CharList|], [t|Stream|], [t|Lazy.ByteString|], [t|Text|]]--offWith :: Code ts -> Code (OffWith ts)-offWith qts = [||(# 0#, $$qts #)||]--emptyUnpackedLazyByteString :: Code Int# -> Code UnpackedLazyByteString-emptyUnpackedLazyByteString qi# = [|| (# $$(qi#), nullAddr#, error "nullForeignPtr", 0#, 0#, Lazy.Empty #) ||]--{- Representation Mappings -}--- When a new input type is added here, it needs an Input instance in Parsley.Backend.Machine-type RepKind :: Type -> RuntimeRep-type family RepKind input where-  RepKind [Char] = IntRep-  RepKind (UArray Int Char) = IntRep-  RepKind Text16 = IntRep-  RepKind ByteString = IntRep-  RepKind Text = LiftedRep-  RepKind Lazy.ByteString = 'TupleRep '[IntRep, AddrRep, LiftedRep, IntRep, IntRep, LiftedRep]-  RepKind CharList = 'TupleRep '[IntRep, LiftedRep]-  RepKind Stream = 'TupleRep '[IntRep, LiftedRep]-  --RepKind (OffWithStreamAnd _) = 'TupleRep '[IntRep, LiftedRep, LiftedRep] --REMOVE-  --RepKind (Text, Stream) = 'TupleRep '[LiftedRep, LiftedRep] --REMOVE--type Rep :: forall (rep :: Type) -> TYPE (RepKind rep)-type family Rep input where-  Rep [Char] = Int#-  Rep (UArray Int Char) = Int#-  Rep Text16 = Int#-  Rep ByteString = Int#-  Rep Text = Text-  Rep Lazy.ByteString = UnpackedLazyByteString-  Rep CharList = (# Int#, String #)-  Rep Stream = (# Int#, Stream #)-  --Rep (OffWithStreamAnd ts) = (# Int#, Stream, ts #)-  --Rep (Text, Stream) = (# Text, Stream #)--{- Generic Representation Operations -}-intSame :: Code Int# -> Code Int# -> Code Bool-intSame qi# qj# = [||isTrue# ($$(qi#) ==# $$(qj#))||]--intLess :: Code Int# -> Code Int# -> Code Bool-intLess qi# qj# = [||isTrue# ($$(qi#) <# $$(qj#))||]--offsetText :: Code Text -> Code Int-offsetText qt = [||case $$qt of Text _ off _ -> off||]--offWithSame :: Code (# Int#, ts #) -> Code (# Int#, ts #) -> Code Bool-offWithSame qi# qj# = [||-    case $$(qi#) of-      (# i#, _ #) -> case $$(qj#) of-        (# j#, _ #) -> $$(intSame [||i#||] [||j#||])-  ||]--offWithShiftRight :: Code (Int -> ts -> ts) -> Code (# Int#, ts #) -> Code Int# -> Code (# Int#, ts #)-offWithShiftRight drop qo# qi# = [||-    case $$(qo#) of (# o#, ts #) -> (# (o# +# $$(qi#)), ($$drop (I# $$(qi#)) ts) #)-  ||]--{-offWithStreamAnd :: ts -> OffWithStreamAnd ts-offWithStreamAnd ts = OffWithStreamAnd 0 nomore ts--offWithStreamAndToInt :: OffWithStreamAnd ts -> Int-offWithStreamAndToInt (OffWithStreamAnd i _ _) = i-}--dropStream :: Int -> Stream -> Stream-dropStream 0 cs = cs-dropStream n (_ :> cs) = dropStream (n-1) cs--textShiftRight :: Text -> Int -> Text-textShiftRight (Text arr off unconsumed) i = go i off unconsumed-  where-    go 0 off' unconsumed' = Text arr off' unconsumed'-    go n off' unconsumed'-      | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0-                          in go (n-1) (off'+d) (unconsumed'-d)-      | otherwise = Text arr off' unconsumed'--textShiftLeft :: Text -> Int -> Text-textShiftLeft (Text arr off unconsumed) i = go i off unconsumed-  where-    go 0 off' unconsumed' = Text arr off' unconsumed'-    go n off' unconsumed'-      | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)-      | otherwise = Text arr off' unconsumed'--{-# INLINE emptyUnpackedLazyByteString' #-}-emptyUnpackedLazyByteString' :: Int# -> UnpackedLazyByteString-emptyUnpackedLazyByteString' i# = (# i#, nullAddr#, error "nullForeignPtr", 0#, 0#, Lazy.Empty #)--byteStringShiftRight :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString-byteStringShiftRight (# i#, addr#, final, off#, size#, cs #) j#-  | isTrue# (j# <# size#)  = (# i# +# j#, addr#, final, off# +# j#, size# -# j#, cs #)-  | otherwise = case cs of-    Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' -> byteStringShiftRight (# i# +# size#, addr'#, final', off'#, size'#, cs' #) (j# -# size#)-    Lazy.Empty -> emptyUnpackedLazyByteString' (i# +# size#)--byteStringShiftLeft :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString-byteStringShiftLeft (# i#, addr#, final, off#, size#, cs #) j# =-  let d# = min# off# j#-  in (# i# -# d#, addr#, final, off# -# d#, size# +# d#, cs #)--min# :: Int# -> Int# -> Int#-min# i# j# = case i# <# j# of-  0# -> j#-  _  -> i#--max# :: Int# -> Int# -> Int#-max# i# j# = case i# <# j# of-  0# -> i#-  _  -> j#

@@ -1,233 +0,0 @@-{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}-{-# LANGUAGE AllowAmbiguousTypes,-             ConstrainedClassMethods,-             ConstraintKinds,-             CPP,-             ImplicitParams,-             MagicHash,-             RecordWildCards,-             TypeApplications #-}-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.Array.Unboxed                            (UArray)-import Data.ByteString.Internal                      (ByteString)-import Data.STRef                                    (writeSTRef, readSTRef, newSTRef)-import Data.Proxy                                    (Proxy(Proxy))-import Data.Text                                     (Text)-import Data.Void                                     (Void)-import Debug.Trace                                   (trace)-import GHC.Exts                                      (Int(..), (-#))-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(FREEVAR, OFFSET), genDefunc)-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{-, representationTypes-})-import Parsley.Internal.Backend.Machine.Instructions (Access(..))-import Parsley.Internal.Backend.Machine.LetBindings  (Regs(..))-import Parsley.Internal.Backend.Machine.State        (Γ(..), Ctx, Handler, Machine(..), MachineMonad, Cont, SubRoutine, OpStack(..), Func,-                                                      run, voidCoins, insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, cachedΣ, concreteΣ, debugLevel)-import Parsley.Internal.Common                       (One, Code, Vec(..), Nat(..))-import Parsley.Internal.Core.InputTypes              (Text16, CharList, Stream)-import System.Console.Pretty                         (color, Color(Green, White, Red, Blue))--import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString)--#define inputInstances(derivation) \-derivation([Char])                 \-derivation((UArray Int Char))      \-derivation(Text16)                 \-derivation(ByteString)             \-derivation(CharList)               \-derivation(Stream)                 \-derivation(Lazy.ByteString)        \-derivation(Text)--type Ops o = (LogHandler o, ContOps o, HandlerOps o, JoinBuilder o, RecBuilder o, ReturnOps o, PositionOps o, LogOps (Rep o))--{- Input Operations -}-sat :: (?ops :: InputOps (Rep o)) => (Code Char -> Code 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' -> [||-    if $$(p c) then $$(k (γ {operands = Op (FREEVAR c) operands, input = input'}))-    else $$bad-  ||]--emitLengthCheck :: forall s o xs n r a. (?ops :: InputOps (Rep 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 γ-emitLengthCheck 1 good bad γ = [|| if $$more $$(input γ) then $$(good γ) else $$bad ||]-emitLengthCheck (I# n) good bad γ = [||-  if $$more $$(shiftRight (Proxy @o) (input γ) [||n -# 1#||]) then $$(good γ)-  else $$bad ||]--{- General Operations -}-dup :: Defunc x -> (Defunc x -> Code r) -> Code r-dup x k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]--{-# INLINE returnST #-}-returnST :: forall s a. a -> ST s a-returnST = return @(ST s)--{- Register Operations -}-newΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))-newΣ σ Soft x k ctx = dup x $ \dupx -> k $! insertNewΣ σ Nothing dupx ctx-newΣ σ Hard x k ctx = dup x $ \dupx -> [||-    do ref <- newSTRef $$(genDefunc dupx)-       $$(k $! insertNewΣ σ (Just [||ref||]) dupx ctx)-  ||]--writeΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))-writeΣ σ Soft x k ctx = dup x $ \dupx -> k $! cacheΣ σ dupx ctx-writeΣ σ Hard x k ctx = let ref = concreteΣ σ ctx in dup x $ \dupx -> [||-    do writeSTRef $$ref $$(genDefunc dupx)-       $$(k $! cacheΣ σ dupx ctx)-  ||]--readΣ :: ΣVar x -> Access -> (Defunc x -> Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))-readΣ σ Soft k ctx = (k $! cachedΣ σ ctx) $! ctx-readΣ σ Hard k ctx = let ref = concreteΣ σ ctx in [||-    do x <- readSTRef $$ref-       $$(let fv = FREEVAR [||x||] in k fv $! cacheΣ σ fv ctx)-  ||]--{- Handler Operations -}-class HandlerOps o where-  buildHandler :: Γ s o xs n r a-               -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))-               -> Code (Rep o) -> Code (Handler s o a)-  fatal :: Code (Handler s o a)--setupHandler :: Γ s o xs n r a-             -> (Code (Rep o) -> Code (Handler s o a))-             -> (Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))-setupHandler γ h k = [||-    let handler = $$(h (input γ))-    in $$(k (γ {handlers = VCons [||handler||] (handlers γ)}))-  ||]--raise :: Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))-raise γ = let VCons h _ = handlers γ in [|| $$h $$(input γ) ||]--#define deriveHandlerOps(_o)                        \-instance HandlerOps _o where                        \-{                                                   \-  buildHandler γ h c = [||\(o# :: Rep _o) ->        \-    $$(h (γ {operands = Op (OFFSET c) (operands γ), \-             input = [||o#||]}))||];                \-  fatal = [||\(!_) -> returnST Nothing ||];         \-};-inputInstances(deriveHandlerOps)--{- Control Flow Operations -}-class 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)--class ReturnOps o where-  halt :: Code (Cont s o a a)-  noreturn :: Code (Cont s o a Void)--callWithContinuation :: forall o s a x n. Code (SubRoutine s o a x) -> Code (Cont s o a x) -> Code (Rep o) -> Vec (Succ n) (Code (Handler s o a)) -> Code (ST s (Maybe a))-callWithContinuation sub ret input (VCons h _) = [||$$sub $$ret $$input $! $$h||]--resume :: Code (Cont s o a x) -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))-resume k γ = let Op x _ = operands γ in [|| $$k $$(genDefunc x) $$(input γ) ||]--#define deriveContOps(_o)                                                              \-instance ContOps _o where                                                              \-{                                                                                      \-  suspend m γ = [|| \x (!o#) -> $$(m (γ {operands = Op (FREEVAR [||x||]) (operands γ), \-                                         input = [||o#||]})) ||];                      \-};-inputInstances(deriveContOps)--#define deriveReturnOps(_o)                                      \-instance ReturnOps _o where                                      \-{                                                                \-  halt = [||\x _ -> returnST $! Just x||];                       \-  noreturn = [||\_ _ -> error "Return is not permitted here"||]; \-};-inputInstances(deriveReturnOps)--{- Builder Operations -}-class JoinBuilder o where-  setupJoinPoint :: ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a--class RecBuilder o where-  buildIter :: ReturnOps o-            => Ctx s o a -> MVar Void -> Machine s o '[] One Void a-            -> (Code (Rep o) -> Code (Handler s o a)) -> Code (Rep o) -> Code (ST s (Maybe a))-  buildRec  :: Regs rs-            -> Ctx s o a-            -> Machine s o '[] One r a-            -> Code (Func rs s o a r)--#define deriveJoinBuilder(_o)                                                       \-instance JoinBuilder _o where                                                       \-{                                                                                   \-  setupJoinPoint φ (Machine k) mx =                                                 \-    liftM2 (\mk ctx γ -> [||                                                        \-      let join x !(o# :: Rep _o) =                                                  \-        $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||o#||]})) \-      in $$(run mx γ (insertΦ φ [||join||] ctx))                                    \-    ||]) (local voidCoins k) ask;                                                   \-};-inputInstances(deriveJoinBuilder)--#define deriveRecBuilder(_o)                                                \-instance RecBuilder _o where                                                \-{                                                                           \-  buildIter ctx μ l h o = [||                                               \-      let handler !o# = $$(h [||o#||]);                                     \-          loop !o# =                                                        \-        $$(run l                                                            \-            (Γ Empty (noreturn @_o) [||o#||] (VCons [||handler o#||] VNil)) \-            (voidCoins (insertSub μ [||\_ (!o#) _ -> loop o#||] ctx)))      \-      in loop $$o                                                           \-    ||];                                                                    \-  buildRec rs ctx k = takeFreeRegisters rs ctx (\ctx ->                     \-    [|| \(!ret) (!o#) h ->                                                  \-      $$(run k (Γ Empty [||ret||] [||o#||] (VCons [||h||] VNil)) ctx) ||]); \-};-inputInstances(deriveRecBuilder)--takeFreeRegisters :: Regs rs -> Ctx s o a -> (Ctx s o a -> Code (SubRoutine s o a x)) -> Code (Func rs s o a x)-takeFreeRegisters NoRegs ctx body = body ctx-takeFreeRegisters (FreeReg σ σs) ctx body = [||\(!reg) -> $$(takeFreeRegisters σs (insertScopedΣ σ [||reg||] ctx) body)||]--{- Debugger Operations -}-class (PositionOps o, LogOps (Rep o)) => LogHandler o where-  logHandler :: (?ops :: InputOps (Rep o)) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Code (Rep o) -> Code (Handler s o a)--preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps o, LogOps (Rep o)) => String -> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String-preludeString name dir γ ctx ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]-  where-    offset     = input γ-    proxy      = Proxy @o-    indent     = replicate (debugLevel ctx * 2) ' '-    start      = shiftLeft offset [||5#||]-    end        = shiftRight proxy offset [||5#||]-    inputTrace = [|| let replace '\n' = color Green "↙"-                         replace ' '  = color White "·"-                         replace c    = return c-                         go i#-                           | $$(same proxy [||i#||] end) || not ($$more i#) = []-                           | otherwise = $$(next [||i#||] (\qc qi' -> [||replace $$qc ++ go $$qi'||]))-                     in go $$start ||]-    eof        = [|| if $$more $$end then $$inputTrace else $$inputTrace ++ color Red "•" ||]-    prelude    = [|| concat [indent, dir : name, dir : " (", show ($$(offToInt offset)), "): "] ||]-    caretSpace = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]--#define deriveLogHandler(_o)                                                                   \-instance LogHandler _o where                                                                   \-{                                                                                              \-  logHandler name ctx γ _ = let VCons h _ = handlers γ in [||\(!o#) ->                         \-      trace $$(preludeString name '<' (γ {input = [||o#||]}) ctx (color Red " Fail")) ($$h o#) \-    ||];                                                                                       \-};-inputInstances(deriveLogHandler)---- RIP Dream :(-{-$(let derive _o = [d|-        instance HandlerOps _o where-          fatal = [||\(!o#) -> return Nothing :: ST s (Maybe a)||]-        |] in traverse derive representationTypes)-}

@@ -1,160 +0,0 @@-{-# LANGUAGE DeriveAnyClass,-             ExistentialQuantification,-             TypeFamilies,-             DerivingStrategies #-}-module Parsley.Internal.Backend.Machine.State (-    HandlerStack, Handler, Cont, SubRoutine, MachineMonad, Func,-    Γ(..), Ctx, OpStack(..),-    QSubRoutine(..), QJoin(..), Machine(..),-    run,-    emptyCtx,-    insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ,-    askSub, askΦ,-    debugUp, debugDown, debugLevel,-    storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins,-    hasCoin, isBankrupt, liquidate-  ) where--import Control.Exception                            (Exception, throw)-import Control.Monad                                (liftM2)-import Control.Monad.Reader                         (asks, MonadReader, Reader, runReader)-import Control.Monad.ST                             (ST)-import Data.STRef                                   (STRef)-import Data.Dependent.Map                           (DMap)-import Data.Kind                                    (Type)-import Data.Maybe                                   (fromMaybe)-import Parsley.Internal.Backend.Machine.Defunc      (Defunc)-import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΣVar(..), ΦVar, IMVar, IΣVar)-import Parsley.Internal.Backend.Machine.InputRep    (Rep)-import Parsley.Internal.Backend.Machine.LetBindings (Regs(..))-import Parsley.Internal.Common                      (Queue, enqueue, dequeue, Code, Vec)--import qualified Data.Dependent.Map as DMap             ((!), insert, empty, lookup)-import qualified Parsley.Internal.Common.Queue as Queue (empty, null, foldr)--type HandlerStack n s o a = Vec n (Code (Handler s o a))-type Handler s o a = Rep o -> ST s (Maybe a)-type Cont s o a x = x -> Rep o -> ST s (Maybe a)-type SubRoutine s o a x = Cont s o a x -> Rep o -> 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-  Func '[] s o a x      = SubRoutine s o a x-  Func (r : rs) s o a x = STRef s r -> Func rs s o a x--data QSubRoutine s o a x = forall rs. QSubRoutine  (Code (Func rs s o a x)) (Regs rs)-newtype QJoin s o a x = QJoin { unwrapJoin :: Code (Cont s o a x) }-newtype Machine s o xs n r a = Machine { getMachine :: MachineMonad s o xs n r a }--run :: Machine s o xs n r a -> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))-run = flip . runReader . getMachine--data OpStack xs where-  Empty :: OpStack '[]-  Op :: Defunc x -> OpStack xs -> OpStack (x ': xs)--data Reg s x = Reg { getReg    :: Maybe (Code (STRef s x))-                   , getCached :: Maybe (Defunc x) }--data Γ s o xs n r a = Γ { operands :: OpStack xs-                        , retCont  :: Code (Cont s o a r)-                        , input    :: Code (Rep o)-                        , handlers :: HandlerStack n s o a }--data Ctx s o a = Ctx { μs         :: DMap MVar (QSubRoutine s o a)-                     , φs         :: DMap ΦVar (QJoin s o a)-                     , σs         :: DMap ΣVar (Reg s)-                     , debugLevel :: Int-                     , coins      :: Int-                     , piggies    :: Queue Int }--emptyCtx :: DMap MVar (QSubRoutine s o a) -> Ctx s o a-emptyCtx μs = Ctx μs DMap.empty DMap.empty 0 0 Queue.empty--insertSub :: MVar x -> Code (SubRoutine s o a x) -> Ctx s o a -> Ctx s o a-insertSub μ q ctx = ctx {μs = DMap.insert μ (QSubRoutine q NoRegs) (μs ctx)}--insertΦ :: ΦVar x -> Code (Cont s o a x) -> Ctx s o a -> Ctx s o a-insertΦ φ qjoin ctx = ctx {φs = DMap.insert φ (QJoin qjoin) (φs ctx)}--insertNewΣ :: ΣVar x -> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a-insertNewΣ σ qref x ctx = ctx {σs = DMap.insert σ (Reg qref (Just x)) (σs ctx)}--insertScopedΣ :: ΣVar x -> Code (STRef s x) -> Ctx s o a -> Ctx s o a-insertScopedΣ σ qref ctx = ctx {σs = DMap.insert σ (Reg (Just qref) Nothing) (σs ctx)}--cacheΣ :: ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a-cacheΣ σ x ctx = case DMap.lookup σ (σs ctx) of-  Just (Reg ref _) -> ctx {σs = DMap.insert σ (Reg ref (Just x)) (σs ctx)}-  Nothing          -> throw (outOfScopeRegister σ)--concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x)-concreteΣ σ = fromMaybe (throw (intangibleRegister σ)) . (>>= getReg) . DMap.lookup σ . σs--cachedΣ :: ΣVar x -> Ctx s o a -> Defunc x-cachedΣ σ = fromMaybe (throw (registerFault σ)) . (>>= getCached) . DMap.lookup σ . σs--askSub :: MonadReader (Ctx s o a) m => MVar x -> m (Code (SubRoutine s o a x))-askSub μ =-  do QSubRoutine sub rs <- askSubUnbound μ-     asks (provideFreeRegisters sub rs)--askSubUnbound :: MonadReader (Ctx s o a) m => MVar x -> m (QSubRoutine s o a x)-askSubUnbound μ = asks (fromMaybe (throw (missingDependency μ)) . DMap.lookup μ . μs)--provideFreeRegisters :: Code (Func rs s o a x) -> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)-provideFreeRegisters sub NoRegs _ = sub-provideFreeRegisters f (FreeReg σ σs) ctx = provideFreeRegisters [||$$f $$(concreteΣ σ ctx)||] σs ctx--askΦ :: MonadReader (Ctx s o a) m => ΦVar x -> m (Code (Cont s o a x))-askΦ φ = asks (unwrapJoin . (DMap.! φ) . φs)--debugUp :: Ctx s o a -> Ctx s o a-debugUp ctx = ctx {debugLevel = debugLevel ctx + 1}--debugDown :: Ctx s o a -> Ctx s o a-debugDown ctx = ctx {debugLevel = debugLevel ctx - 1}---- Piggy bank functions-storePiggy :: Int -> Ctx s o a -> Ctx s o a-storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx)}--breakPiggy :: Ctx s o a -> Ctx s o a-breakPiggy ctx = let (coins, piggies') = dequeue (piggies ctx) in ctx {coins = coins, piggies = piggies'}--hasCoin :: Ctx s o a -> Bool-hasCoin = (> 0) . coins--isBankrupt :: Ctx s o a -> Bool-isBankrupt = liftM2 (&&) (not . hasCoin) (Queue.null . piggies)--spendCoin :: Ctx s o a -> Ctx s o a-spendCoin ctx = ctx {coins = coins ctx - 1}--giveCoins :: Int -> Ctx s o a -> Ctx s o a-giveCoins c ctx = ctx {coins = coins ctx + c}--voidCoins :: Ctx s o a -> Ctx s o a-voidCoins ctx = ctx {coins = 0, piggies = Queue.empty}--liquidate :: Ctx s o a -> Int-liquidate ctx = Queue.foldr (+) (coins ctx) (piggies ctx)--newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception-newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Exception-newtype IntangibleRegister = IntangibleRegister IΣVar deriving anyclass Exception-newtype RegisterFault = RegisterFault IΣVar deriving anyclass Exception--missingDependency :: MVar x -> MissingDependency-missingDependency (MVar v) = MissingDependency v-outOfScopeRegister :: ΣVar x -> OutOfScopeRegister-outOfScopeRegister (ΣVar σ) = OutOfScopeRegister σ-intangibleRegister :: ΣVar x -> IntangibleRegister-intangibleRegister (ΣVar σ) = IntangibleRegister σ-registerFault :: ΣVar x -> RegisterFault-registerFault (ΣVar σ) = RegisterFault σ--instance Show MissingDependency where show (MissingDependency μ) = "Dependency μ" ++ show μ ++ " has not been compiled"-instance Show OutOfScopeRegister where show (OutOfScopeRegister σ) = "Register r" ++ show σ ++ " is out of scope"-instance Show IntangibleRegister where show (IntangibleRegister σ) = "Register r" ++ show σ ++ " is intangible in this scope"-instance Show RegisterFault where show (RegisterFault σ) = "Attempting to access register r" ++ show σ ++ " from cache has failed"

@@ -1,50 +0,0 @@-{-|-Module      : Parsley.Internal.Backend.Machine-Description : The implementation of the low level parsing machinery is found here-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : unstable--@since 0.1.0.0--}-module Parsley.Internal.Backend.Machine (-    Input, eval,-    PositionOps,-    module Parsley.Internal.Backend.Machine.Instructions,-    module Parsley.Internal.Backend.Machine.Defunc,-    module Parsley.Internal.Backend.Machine.Identifiers,-    module Parsley.Internal.Backend.Machine.LetBindings-  ) where--import Data.Array.Unboxed                            (UArray)-import Data.ByteString                               (ByteString)-import Data.Dependent.Map                            (DMap)-import Data.Text                                     (Text)-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(..))-import Parsley.Internal.Backend.Machine.Identifiers-import Parsley.Internal.Backend.Machine.InputOps     (InputPrep(..), PositionOps)-import Parsley.Internal.Backend.Machine.InputRep     (Rep)-import Parsley.Internal.Backend.Machine.Instructions-import Parsley.Internal.Backend.Machine.LetBindings  (LetBinding, makeLetBinding)-import Parsley.Internal.Backend.Machine.Ops          (Ops)-import Parsley.Internal.Common.Utils                 (Code)-import Parsley.Internal.Core.InputTypes-import Parsley.Internal.Trace                        (Trace)--import qualified Data.ByteString.Lazy as Lazy (ByteString)-import qualified Parsley.Internal.Backend.Machine.Eval as Eval (eval)--eval :: forall input a. (Input input, Trace) => Code input -> (LetBinding (Rep input) a a, DMap MVar (LetBinding (Rep input) a)) -> Code (Maybe a)-eval input (toplevel, bindings) = Eval.eval (prepare input) toplevel bindings--class (InputPrep input, Ops (Rep input)) => Input input-instance Input [Char]-instance Input (UArray Int Char)-instance Input Text16-instance Input ByteString-instance Input CharList-instance Input Text---instance Input CacheText-instance Input Lazy.ByteString---instance Input Lazy.ByteString-instance Input Stream

@@ -1,39 +0,0 @@-module Parsley.Internal.Backend.Machine.Defunc (module Parsley.Internal.Backend.Machine.Defunc) where--import Parsley.Internal.Backend.Machine.InputOps (PositionOps(same))-import Parsley.Internal.Common.Utils             (Code, WQ(WQ))--import qualified Parsley.Internal.Core.Defunc as Core (Defunc(BLACK), ap, genDefunc, genDefunc1, genDefunc2)--data Defunc a where-  USER    :: Core.Defunc a -> Defunc a-  BOTTOM  :: Defunc a-  SAME    :: PositionOps o => Defunc (o -> o -> Bool)-  FREEVAR :: Code a -> Defunc a--ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c-ap2 f x y = USER (Core.ap (Core.ap (seal f) (seal x)) (seal y))-  where-    seal :: Defunc a -> Core.Defunc a-    seal (USER x) = x-    seal x        = Core.BLACK (WQ undefined (genDefunc x))--genDefunc :: Defunc a -> Code a-genDefunc (USER x)    = Core.genDefunc x-genDefunc BOTTOM      = [||undefined||]-genDefunc SAME        = same-genDefunc (FREEVAR x) = x--genDefunc1 :: Defunc (a -> b) -> Code a -> Code b-genDefunc1 (USER f) qx = Core.genDefunc1 f qx-genDefunc1 f qx        = [|| $$(genDefunc f) $$qx ||]--genDefunc2 :: Defunc (a -> b -> c) -> Code a -> Code b -> Code c-genDefunc2 (USER f) qx qy = Core.genDefunc2 f qx qy-genDefunc2 f qx qy        = [|| $$(genDefunc f) $$qx $$qy ||]--instance Show (Defunc a) where-  show (USER x) = show x-  show SAME = "same"-  show BOTTOM = "[[irrelevant]]"-  show (FREEVAR _) = "x"

@@ -1,183 +0,0 @@-{-# LANGUAGE ImplicitParams,-             MultiWayIf,-             RecordWildCards,-             TypeApplications #-}-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)-import Control.Monad.Reader                           (ask, asks, local)-import Control.Monad.ST                               (runST)-import Parsley.Internal.Backend.Machine.Defunc        (Defunc(FREEVAR), genDefunc, genDefunc1, ap2)-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.LetBindings   (LetBinding(..))-import Parsley.Internal.Backend.Machine.LetRecBuilder-import Parsley.Internal.Backend.Machine.Ops-import Parsley.Internal.Backend.Machine.State-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)--eval :: forall o a. (Trace, Ops o) => Code (InputDependant o) -> LetBinding o a a -> DMap MVar (LetBinding o a) -> Code (Maybe a)-eval input (LetBinding !p _) fs = trace ("EVALUATING TOP LEVEL") [|| runST $-  do let !(InputDependant next more offset) = $$input-     $$(let ?ops = InputOps [||more||] [||next||]-        in letRec fs-             nameLet-             (\exp rs names -> buildRec rs (emptyCtx names) (readyMachine exp))-             (\names -> run (readyMachine p) (Γ Empty (halt @o) [||offset||] (VCons (fatal @o) VNil)) (emptyCtx names)))-  ||]-  where-    nameLet :: MVar x -> String-    nameLet (MVar i) = "sub" ++ show i--readyMachine :: (?ops :: InputOps o, Ops o, Trace) => Fix4 (Instr o) xs n r a -> Machine s o xs n r a-readyMachine = cata4 (Machine . alg)-  where-    alg :: (?ops :: InputOps o, Ops o) => Instr o (Machine s o) xs n r a -> MachineMonad s o xs n r a-    alg Ret                 = evalRet-    alg (Call μ k)          = evalCall μ k-    alg (Jump μ)            = evalJump μ-    alg (Push x k)          = evalPush x k-    alg (Pop k)             = evalPop k-    alg (Lift2 f k)         = evalLift2 f k-    alg (Sat p k)           = evalSat p k-    alg Empt                = evalEmpt-    alg (Commit k)          = evalCommit k-    alg (Catch k h)         = evalCatch k h-    alg (Tell k)            = evalTell k-    alg (Seek k)            = evalSeek k-    alg (Case p q)          = evalCase p q-    alg (Choices fs ks def) = evalChoices fs ks def-    alg (Iter μ l k)        = evalIter μ l k-    alg (Join φ)            = evalJoin φ-    alg (MkJoin φ p k)      = evalMkJoin φ p k-    alg (Swap k)            = evalSwap k-    alg (Dup k)             = evalDup k-    alg (Make σ c k)        = evalMake σ c k-    alg (Get σ c k)         = evalGet σ c k-    alg (Put σ c k)         = evalPut σ c k-    alg (LogEnter name k)   = evalLogEnter name k-    alg (LogExit name k)    = evalLogExit name k-    alg (MetaInstr m k)     = evalMeta m k--evalRet :: ContOps o => MachineMonad s o (x : xs) n x a-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 μ)--evalJump :: ContOps o => MVar x -> MachineMonad s o '[] (Succ n) x a-evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation 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 γ)})--evalPop :: Machine s o xs n r a -> MachineMonad s o (x : xs) n r a-evalPop (Machine k) = k <&> \m γ -> m (γ {operands = let Op _ xs = operands γ in xs})--evalLift2 :: Defunc (x -> y -> z) -> Machine s o (z : xs) n r a -> MachineMonad s o (y : x : xs) n r a-evalLift2 f (Machine k) = k <&> \m γ -> m (γ {operands = let Op y (Op x xs) = operands γ in Op (ap2 f x y) xs})--evalSat :: (?ops :: InputOps o, PositionOps o, BoxOps o, HandlerOps o, Trace) => Defunc (Char -> Bool) -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a-evalSat p (Machine k) = do-  bankrupt <- asks isBankrupt-  hasChange <- asks hasCoin-  if | bankrupt -> maybeEmitCheck (Just 1) <$> k-     | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k-     | otherwise -> trace "I have a piggy :)" $ local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)-  where-    maybeEmitCheck Nothing mk γ = sat (genDefunc1 p) mk (raise γ) γ-    maybeEmitCheck (Just n) mk γ =-      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (genDefunc1 p) mk [||bad||]) [||bad||] γ)||]--evalEmpt :: (BoxOps o, HandlerOps o) => MachineMonad s o xs (Succ n) r a-evalEmpt = return $! raise--evalCommit :: Machine s o xs n r a -> MachineMonad s o xs (Succ n) r a-evalCommit (Machine k) = k <&> \mk γ -> let VCons _ hs = handlers γ in mk (γ {handlers = hs})--evalCatch :: (BoxOps o, HandlerOps o) => Machine s o xs (Succ n) r a -> Machine s o (o : xs) n r a -> MachineMonad s o xs n r a-evalCatch (Machine k) (Machine h) = liftM2 (\mk mh γ -> setupHandler γ (buildHandler γ mh) mk) k h--evalTell :: Machine s o (o : xs) n r a -> MachineMonad s o xs n r a-evalTell (Machine k) = k <&> \mk γ -> mk (γ {operands = Op (FREEVAR (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 input xs = operands γ in mk (γ {operands = xs, input = genDefunc 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 γ ->-  let Op e xs = operands γ-  in [||case $$(genDefunc e) of-    Left x -> $$(mp (γ {operands = Op (FREEVAR [||x||]) xs}))-    Right y  -> $$(mq (γ {operands = Op (FREEVAR [||y||]) xs}))||]) p q--evalChoices :: [Defunc (x -> Bool)] -> [Machine s o xs n r a] -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a-evalChoices fs ks (Machine def) = liftM2 (\mdef mks γ -> let Op x xs = operands γ in go x fs mks mdef (γ {operands = xs}))-  def-  (forM ks getMachine)-  where-    go x (f:fs) (mk:mks) def γ = [||-        if $$(genDefunc1 f (genDefunc x)) then $$(mk γ)-        else $$(go x fs mks def γ)-      ||]-    go _ _ _ def γ = def γ--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--evalJoin :: ContOps o => ΦVar x -> MachineMonad s o (x : xs) n r a-evalJoin φ = askΦ φ <&> resume--evalMkJoin :: JoinBuilder o => ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a-evalMkJoin = setupJoinPoint--evalSwap :: Machine s o (x : y : xs) n r a -> MachineMonad s o (y : x : xs) n r a-evalSwap (Machine k) = k <&> \mk γ -> mk (γ {operands = let Op y (Op x xs) = operands γ in Op x (Op y xs)})--evalDup :: Machine s o (x : x : xs) n r a -> MachineMonad s o (x : xs) n r a-evalDup (Machine k) = k <&> \mk γ ->-  let Op x xs = operands γ-  in dup x $ \dupx -> mk (γ {operands = Op dupx (Op dupx xs)})--evalMake :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a-evalMake σ a k = asks $! \ctx γ ->-  let Op x xs = operands γ-  in newΣ σ a x (run k (γ {operands = xs})) ctx--evalGet :: ΣVar x -> Access -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a-evalGet σ a k = asks $! \ctx γ -> readΣ σ a (\x -> run k (γ {operands = Op x (operands γ)})) ctx--evalPut :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a-evalPut σ a k = asks $! \ctx γ ->-  let Op x xs = operands γ-  in writeΣ σ a x (run k (γ {operands = xs})) ctx--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) =-  liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '>' γ ctx "") $$(setupHandler γ (logHandler name ctx γ) k)||])-    (local debugUp mk)-    ask--evalLogExit :: (?ops :: InputOps o, PositionOps o, LogOps o) => String -> Machine s o xs n r a -> MachineMonad s o xs n r a-evalLogExit name (Machine mk) =-  liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '<' γ (debugDown ctx) (color Green " Good")) $$(k γ) ||])-    (local debugDown mk)-    ask--evalMeta :: (?ops :: InputOps o, PositionOps o, BoxOps o, HandlerOps o) => MetaInstr n -> Machine s o xs n r a -> MachineMonad s o xs n r a-evalMeta (AddCoins coins) (Machine k) =-  do requiresPiggy <- asks hasCoin-     if requiresPiggy then local (storePiggy coins) k-     else local (giveCoins coins) k <&> \mk γ -> emitLengthCheck coins mk (raise γ) γ-evalMeta (RefundCoins coins) (Machine k) = local (giveCoins coins) k-evalMeta (DrainCoins coins) (Machine k) = liftM2 (\n mk γ -> emitLengthCheck n mk (raise γ) γ) (asks ((coins -) . liquidate)) k

@@ -1,229 +0,0 @@-{-# LANGUAGE ImplicitParams,-             MagicHash,-             TypeApplications,-             UnboxedTuples #-}-module Parsley.Internal.Backend.Machine.InputOps (-    InputPrep(..), PositionOps(..), BoxOps(..), LogOps(..),-    InputOps(..), more, next,-    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(..))-import GHC.ForeignPtr                            (ForeignPtr(..))-import GHC.Prim                                  (indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#))-import Parsley.Internal.Backend.Machine.InputRep-import Parsley.Internal.Common.Utils             (Code)-import Parsley.Internal.Core.InputTypes--import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))---import qualified Data.Text                     as Text (length, index)--data InputDependant rep = InputDependant {-next-} (rep -> (# Char, rep #))-                                         {-more-} (rep -> Bool)-                                         {-init-} rep--{- Typeclasses -}-class InputPrep input where-  prepare :: Code input -> Code (InputDependant (Rep input))--class PositionOps rep where-  same :: Code (rep -> rep -> Bool)-  shiftRight :: Code (rep -> Int -> rep)--class BoxOps rep where-  box   :: Code (Unboxed rep -> rep)-  unbox :: Code (rep -> Unboxed rep)--class LogOps rep where-  shiftLeft :: Code (rep -> Int -> rep)-  offToInt  :: Code (rep -> Int)--data InputOps rep = InputOps { _more       :: Code (rep -> Bool)-                             , _next       :: Code (rep -> (# Char, rep #))-                             }-more :: (?ops :: InputOps rep) => Code (rep -> Bool)-more = _more ?ops-next :: (?ops :: InputOps rep) => Code rep -> (Code Char -> Code rep -> Code r) -> Code r-next ts k = [|| let !(# t, ts' #) = $$(_next ?ops) $$ts in $$(k [||t||] [||ts'||]) ||]--{- INSTANCES -}--- InputPrep Instances-instance InputPrep [Char] where-  prepare input = prepare @(UArray Int Char) [||listArray (0, length $$input-1) $$input||]--instance InputPrep (UArray Int Char) where-  prepare qinput = [||-      let UArray _ _ size input# = $$qinput-          next (I# i#) = (# C# (indexWideCharArray# input# i#), I# (i# +# 1#) #)-      in InputDependant next (< size) 0-    ||]--instance InputPrep Text16 where-  prepare qinput = [||-      let Text16 (Text arr off size) = $$qinput-          arr# = aBA arr-          next (I# i#) = (# C# (chr# (word2Int# (indexWord16Array# arr# i#))), I# (i# +# 1#) #)-      in InputDependant next (< size) off-    ||]--instance InputPrep ByteString where-  prepare qinput = [||-      let PS (ForeignPtr addr# final) off size = $$qinput-          next i@(I# i#) =-            case readWord8OffAddr# (addr# `plusAddr#` i#) 0# realWorld# of-              (# s', x #) -> case touch# final s' of-                _ -> (# C# (chr# (word2Int# x)), i + 1 #)-      in InputDependant next (< size) off-    ||]--instance InputPrep CharList where-  prepare qinput = [||-      let CharList input = $$qinput-          next (OffWith i (c:cs)) = (# c, OffWith (i+1) cs #)-          size = length input-          more (OffWith i _) = i < size-          --more (OffWith _ []) = False-          --more _              = True-      in InputDependant next more ($$offWith input)-    ||]--instance InputPrep Text where-  prepare qinput = [||-      let next t@(Text arr off unconsumed) = let !(Iter c d) = iter t 0 in (# c, Text arr (off+d) (unconsumed-d) #)-          more (Text _ _ unconsumed) = unconsumed > 0-      in InputDependant next more $$qinput-    ||]--instance InputPrep Lazy.ByteString where-  prepare qinput = [||-      let next (UnpackedLazyByteString i addr# final off@(I# off#) size cs) =-            case readWord8OffAddr# addr# off# realWorld# of-              (# s', x #) -> case touch# final s' of-                _ -> (# C# (chr# (word2Int# x)),-                    if size /= 1 then UnpackedLazyByteString (i+1) addr# final (off+1) (size-1) cs-                    else case cs of-                      Lazy.Chunk (PS (ForeignPtr addr'# final') off' size') cs' -> UnpackedLazyByteString (i+1) addr'# final' off' size' cs'-                      Lazy.Empty -> emptyUnpackedLazyByteString (i+1)-                  #)-          more (UnpackedLazyByteString _ _ _ _ 0 _) = False-          more _ = True-          initial = case $$qinput of-            Lazy.Chunk (PS (ForeignPtr addr# final) off size) cs -> UnpackedLazyByteString 0 addr# final off size cs-            Lazy.Empty -> emptyUnpackedLazyByteString 0-      in InputDependant next more initial-    ||]--instance InputPrep Stream where-  prepare qinput = [||-      let next (OffWith o (c :> cs)) = (# c, OffWith (o + 1) cs #)-      in InputDependant next (const True) ($$offWith $$qinput)-    ||]---- PositionOps Instances-instance PositionOps Int where-  same = [||(==) @Int||]-  shiftRight = [||(+) @Int||]--instance PositionOps (OffWith String) where-  same = offWithSame-  shiftRight = offWithShiftRight [||drop||]--instance PositionOps (OffWith Stream) where-  same = offWithSame-  shiftRight = offWithShiftRight [||dropStream||]--instance PositionOps Text where-  same = [||\(Text _ i _) (Text _ j _) -> i == j||]-  shiftRight = [||textShiftRight||]--instance PositionOps UnpackedLazyByteString where-  same = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i == j||]-  shiftRight = [||byteStringShiftRight||]---- BoxOps Instances-instance BoxOps Int where-  box = [||\i# -> I# i#||]-  unbox = [||\(I# i#) -> i#||]--instance BoxOps (OffWith ts) where-  box = [||\(# i#, ts #) -> OffWith (I# i#) ts||]-  unbox = [||\(OffWith (I# i#) ts) -> (# i#, ts #)||]--instance BoxOps Text where-  box = [||id||]-  unbox = [||id||]--instance BoxOps UnpackedLazyByteString where-  box = [||\(!(# i#, addr#, final, off#, size#, cs #)) -> UnpackedLazyByteString (I# i#) addr# final (I# off#) (I# size#) cs||]-  unbox = [||\(UnpackedLazyByteString (I# i#) addr# final (I# off#) (I# size#) cs) -> (# i#, addr#, final, off#, size#, cs #)||]---- LogOps Instances-instance LogOps Int where-  shiftLeft = [||\o i -> max (o - i) 0||]-  offToInt = [||id||]--instance LogOps (OffWith ts) where-  shiftLeft = [||const||]-  offToInt = [||\(OffWith i _) -> i||]--instance LogOps Text where-  shiftLeft = [||textShiftLeft||]-  offToInt = [||\(Text _ off _) -> div off 2||]--instance LogOps UnpackedLazyByteString where-  shiftLeft = [||byteStringShiftLeft||]-  offToInt = [||\(UnpackedLazyByteString i _ _ _ _ _) -> i||]--{- Old Instances -}-{-instance Input CacheText (Text, Stream) where-  prepare qinput = [||-      let (CacheText input) = $$qinput-          next (t@(Text arr off unconsumed), _) = let !(Iter c d) = iter t 0 in (# c, (Text arr (off+d) (unconsumed-d), nomore) #)-          more (Text _ _ unconsumed, _) = unconsumed > 0-          same (Text _ i _, _) (Text _ j _, _) = i == j-          (Text arr off unconsumed, _) << i = go i off unconsumed-            where-              go 0 off' unconsumed' = (Text arr off' unconsumed', nomore)-              go n off' unconsumed'-                | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)-                | otherwise = (Text arr off' unconsumed', nomore)-          (Text arr off unconsumed, _) >> i = go i off unconsumed-            where-              go 0 off' unconsumed' = (Text arr off' unconsumed', nomore)-              go n off' unconsumed'-                | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)-                | otherwise = (Text arr off' unconsumed', nomore)-          toInt (Text arr off unconsumed, _) = div off 2-          box (# text, cache #) = (text, cache)-          unbox (text, cache) = (# text, cache #)-          newCRef (Text _ i _, _) = newSTRefU i-          readCRef ref = fmap (\i -> (Text empty i 0, nomore)) (readSTRefU ref)-          writeCRef ref (Text _ i _, _) = writeSTRefU ref i-      in PreparedInput next more same (input, nomore) box unbox newCRef readCRef writeCRef s(<<) (>>) toInt-    ||]--instance Input Lazy.ByteString (OffWith Lazy.ByteString) where-  prepare qinput = [||-      let next (OffWith i (Lazy.Chunk (PS ptr@(ForeignPtr addr# final) off@(I# off#) size) cs)) =-            case readWord8OffAddr# addr# off# realWorld# of-              (# s', x #) -> case touch# final s' of-                _ -> (# C# (chr# (word2Int# x)), OffWith (i+1) (if size == 1 then cs-                                                                else Lazy.Chunk (PS ptr (off+1) (size-1)) cs) #)-          more (OffWith _ Lazy.Empty) = False-          more _ = True-          ow@(OffWith _ (Lazy.Empty)) << _ = ow-          OffWith o (Lazy.Chunk (PS ptr off size) cs) << i =-            let d = min off i-            in OffWith (o - d) (Lazy.Chunk (PS ptr (off - d) (size + d)) cs)-          ow@(OffWith _ Lazy.Empty) >> _ = ow-          OffWith o (Lazy.Chunk (PS ptr off size) cs) >> i-            | i < size  = OffWith (o + i) (Lazy.Chunk (PS ptr (off + i) (size - i)) cs)-            | otherwise = OffWith (o + size) cs >> (i - size)-          readCRef ref = fmap (\i -> OffWith i Lazy.Empty) (readSTRefU ref)-      in PreparedInput next more offWithSame (offWith $$qinput) offWithBox offWithUnbox offWithNewORef readCRef offWithWriteORef (<<) (>>) offWithToInt-    ||]-}

@@ -1,131 +0,0 @@-{-# LANGUAGE MagicHash,-             TypeFamilies,-             TypeFamilyDependencies,-             UnboxedTuples #-}-module Parsley.Internal.Backend.Machine.InputRep (-    Unboxed, Rep,-    OffWith(..), offWith, offWithSame, offWithShiftRight,-    OffWithStreamAnd(..),-    UnpackedLazyByteString(..), emptyUnpackedLazyByteString,-    Stream, dropStream,-    representationTypes,-    -- These must be exposed-    textShiftRight, textShiftLeft,-    byteStringShiftRight, byteStringShiftLeft-  ) where--import Data.Array.Unboxed                (UArray)-import Data.ByteString.Internal          (ByteString(..))-import Data.Text.Internal                (Text(..))-import Data.Text.Unsafe                  (iter_, reverseIter_)-import GHC.Exts                          (TYPE, RuntimeRep(..))-import GHC.ForeignPtr                    (ForeignPtr(..), ForeignPtrContents)-import GHC.Prim                          (Int#, Addr#, nullAddr#)-import Parsley.Internal.Common.Utils     (Code)-import Parsley.Internal.Core.InputTypes  (Text16, CharList, Stream(..))--import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))-import qualified Language.Haskell.TH           as TH   (Q, Type)--{- Representation Types -}-data OffWith ts = OffWith {-# UNPACK #-} !Int ts-data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts-data UnpackedLazyByteString = UnpackedLazyByteString-  {-# UNPACK #-} !Int-  !Addr#-  ForeignPtrContents-  {-# UNPACK #-} !Int-  {-# UNPACK #-} !Int-  Lazy.ByteString--representationTypes :: [TH.Q TH.Type]-representationTypes = [[t|Int|], [t|OffWith [Char]|], [t|OffWith Stream|], [t|UnpackedLazyByteString|], [t|Text|]]--offWith :: Code (ts -> OffWith ts)-offWith = [||OffWith 0||]--{-# INLINE emptyUnpackedLazyByteString #-}-emptyUnpackedLazyByteString :: Int -> UnpackedLazyByteString-emptyUnpackedLazyByteString i = UnpackedLazyByteString i nullAddr# (error "nullForeignPtr") 0 0 Lazy.Empty--{- Representation Mappings -}--- When a new input type is added here, it needs an Input instance in Parsley.Backend.Machine-type family Rep input where-  Rep [Char] = Int-  Rep (UArray Int Char) = Int-  Rep Text16 = Int-  Rep ByteString = Int-  Rep CharList = OffWith String-  Rep Text = Text-  --Rep CacheText = (Text, Stream)-  Rep Lazy.ByteString = UnpackedLazyByteString-  --Rep Lazy.ByteString = OffWith Lazy.ByteString-  Rep Stream = OffWith Stream--type family RepKind rep where-  RepKind Int = IntRep-  RepKind Text = LiftedRep-  RepKind UnpackedLazyByteString = 'TupleRep '[IntRep, AddrRep, LiftedRep, IntRep, IntRep, LiftedRep]-  RepKind (OffWith _) = 'TupleRep '[IntRep, LiftedRep]-  RepKind (OffWithStreamAnd _) = 'TupleRep '[IntRep, LiftedRep, LiftedRep]-  RepKind (Text, Stream) = 'TupleRep '[LiftedRep, LiftedRep]--type family Unboxed rep = (urep :: TYPE (RepKind rep)) | urep -> rep where-  Unboxed Int = Int#-  Unboxed Text = Text-  Unboxed UnpackedLazyByteString = (# Int#, Addr#, ForeignPtrContents, Int#, Int#, Lazy.ByteString #)-  Unboxed (OffWith ts) = (# Int#, ts #)-  Unboxed (OffWithStreamAnd ts) = (# Int#, Stream, ts #)-  Unboxed (Text, Stream) = (# Text, Stream #)--{- Generic Representation Operations -}-offWithSame :: Code (OffWith ts -> OffWith ts -> Bool)-offWithSame = [||\(OffWith i _) (OffWith j _) -> i == j||]--offWithShiftRight :: Code (Int -> ts -> ts) -> Code (OffWith ts -> Int -> OffWith ts)-offWithShiftRight drop = [||\(OffWith o ts) i -> OffWith (o + i) ($$drop i ts)||]--{-offWithStreamAnd :: ts -> OffWithStreamAnd ts-offWithStreamAnd ts = OffWithStreamAnd 0 nomore ts--offWithStreamAndBox :: (# Int#, Stream, ts #) -> OffWithStreamAnd ts-offWithStreamAndBox (# i#, ss, ts #) = OffWithStreamAnd (I# i#) ss ts--offWithStreamAndUnbox :: OffWithStreamAnd ts -> (# Int#, Stream, ts #)-offWithStreamAndUnbox (OffWithStreamAnd (I# i#) ss ts) = (# i#, ss, ts #)--offWithStreamAndToInt :: OffWithStreamAnd ts -> Int-offWithStreamAndToInt (OffWithStreamAnd i _ _) = i-}--dropStream :: Int -> Stream -> Stream-dropStream 0 cs = cs-dropStream n (_ :> cs) = dropStream (n-1) cs--textShiftRight :: Text -> Int -> Text-textShiftRight (Text arr off unconsumed) i = go i off unconsumed-  where-    go 0 off' unconsumed' = Text arr off' unconsumed'-    go n off' unconsumed'-      | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0-                          in go (n-1) (off'+d) (unconsumed'-d)-      | otherwise = Text arr off' unconsumed'--textShiftLeft :: Text -> Int -> Text-textShiftLeft (Text arr off unconsumed) i = go i off unconsumed-  where-    go 0 off' unconsumed' = Text arr off' unconsumed'-    go n off' unconsumed'-      | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)-      | otherwise = Text arr off' unconsumed'--byteStringShiftRight :: UnpackedLazyByteString -> Int -> UnpackedLazyByteString-byteStringShiftRight !(UnpackedLazyByteString i addr# final off size cs) j-  | j < size  = UnpackedLazyByteString (i + j) addr# final (off + j) (size - j) cs-  | otherwise = case cs of-    Lazy.Chunk (PS (ForeignPtr addr'# final') off' size') cs' -> byteStringShiftRight (UnpackedLazyByteString (i + size) addr'# final' off' size' cs') (j - size)-    Lazy.Empty -> emptyUnpackedLazyByteString (i + size)--byteStringShiftLeft :: UnpackedLazyByteString -> Int -> UnpackedLazyByteString-byteStringShiftLeft (UnpackedLazyByteString i addr# final off size cs) j =-  let d = min off j-  in UnpackedLazyByteString (i - d) addr# final (off - d) (size + d) cs

@@ -1,221 +0,0 @@-{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}-{-# LANGUAGE AllowAmbiguousTypes,-             ConstrainedClassMethods,-             ConstraintKinds,-             CPP,-             ImplicitParams,-             MagicHash,-             RecordWildCards,-             TypeApplications #-}-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.STRef                                    (writeSTRef, readSTRef, newSTRef)-import Data.Text                                     (Text)-import Data.Void                                     (Void)-import Debug.Trace                                   (trace)-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(FREEVAR), genDefunc)-import Parsley.Internal.Backend.Machine.Identifiers  (MVar, ΦVar, ΣVar)-import Parsley.Internal.Backend.Machine.InputOps     (PositionOps(..), BoxOps(..), LogOps(..), InputOps, next, more)-import Parsley.Internal.Backend.Machine.InputRep     (Unboxed, OffWith, UnpackedLazyByteString, Stream{-, representationTypes-})-import Parsley.Internal.Backend.Machine.Instructions (Access(..))-import Parsley.Internal.Backend.Machine.LetBindings  (Regs(..))-import Parsley.Internal.Backend.Machine.State        (Γ(..), Ctx, Handler, Machine(..), MachineMonad, Cont, SubRoutine, OpStack(..), Func,-                                                      run, voidCoins, insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, cachedΣ, concreteΣ, debugLevel)-import Parsley.Internal.Common                       (One, Code, Vec(..), Nat(..))-import System.Console.Pretty                         (color, Color(Green, White, Red, Blue))--#define inputInstances(derivation) \-derivation(Int)                    \-derivation((OffWith [Char]))       \-derivation((OffWith Stream))       \-derivation(UnpackedLazyByteString) \-derivation(Text)--type Ops o = (LogHandler o, ContOps o, HandlerOps o, JoinBuilder o, RecBuilder o, ReturnOps o, PositionOps o, BoxOps o, LogOps o)--{- Input Operations -}-sat :: (?ops :: InputOps o) => (Code Char -> Code 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' -> [||-    if $$(p c) then $$(k (γ {operands = Op (FREEVAR c) operands, input = input'}))-    else $$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 γ-emitLengthCheck 1 good bad γ = [|| if $$more $$(input γ) then $$(good γ) else $$bad ||]-emitLengthCheck n good bad γ = [||-  if $$more ($$shiftRight $$(input γ) (n - 1)) then $$(good γ)-  else $$bad ||]--{- General Operations -}-dup :: Defunc x -> (Defunc x -> Code r) -> Code r-dup x k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]--{-# INLINE returnST #-}-returnST :: forall s a. a -> ST s a-returnST = return @(ST s)--{- Register Operations -}-newΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))-newΣ σ Soft x k ctx = dup x $ \dupx -> k $! insertNewΣ σ Nothing dupx ctx-newΣ σ Hard x k ctx = dup x $ \dupx -> [||-    do ref <- newSTRef $$(genDefunc dupx)-       $$(k $! insertNewΣ σ (Just [||ref||]) dupx ctx)-  ||]--writeΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))-writeΣ σ Soft x k ctx = dup x $ \dupx -> k $! cacheΣ σ dupx ctx-writeΣ σ Hard x k ctx = let ref = concreteΣ σ ctx in dup x $ \dupx -> [||-    do writeSTRef $$ref $$(genDefunc dupx)-       $$(k $! cacheΣ σ dupx ctx)-  ||]--readΣ :: ΣVar x -> Access -> (Defunc x -> Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))-readΣ σ Soft k ctx = (k $! cachedΣ σ ctx) $! ctx-readΣ σ Hard k ctx = let ref = concreteΣ σ ctx in [||-    do x <- readSTRef $$ref-       $$(let fv = FREEVAR [||x||] in k fv $! cacheΣ σ fv ctx)-  ||]--{- Handler Operations -}-class HandlerOps o where-  buildHandler :: BoxOps o-               => Γ s o xs n r a-               -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))-               -> Code o -> Code (Handler s o a)-  fatal :: Code (Handler s o a)-  raise :: BoxOps o => Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))--setupHandler :: Γ s o xs n r a-             -> (Code o -> Code (Handler s o a))-             -> (Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))-setupHandler γ h k = [||-    let handler = $$(h (input γ))-    in $$(k (γ {handlers = VCons [||handler||] (handlers γ)}))-  ||]--#define deriveHandlerOps(_o)                         \-instance HandlerOps _o where                         \-{                                                    \-  buildHandler γ h c = [||\(o# :: Unboxed _o) ->     \-    $$(h (γ {operands = Op (FREEVAR c) (operands γ), \-             input = [||$$box o#||]}))||];           \-  fatal = [||\(!_) -> returnST Nothing ||];          \-  raise γ = let VCons h _ = handlers γ               \-            in [|| $$h ($$unbox $$(input γ)) ||];    \-};-inputInstances(deriveHandlerOps)--{- Control Flow Operations -}-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))--class ReturnOps o where-  halt :: Code (Cont s o a a)-  noreturn :: Code (Cont s o a Void)--#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||]; \-};-inputInstances(deriveContOps)--#define deriveReturnOps(_o)                                      \-instance ReturnOps _o where                                      \-{                                                                \-  halt = [||\x _ -> returnST $! Just x||];                       \-  noreturn = [||\_ _ -> error "Return is not permitted here"||]; \-};-inputInstances(deriveReturnOps)--{- Builder Operations -}-class BoxOps o => JoinBuilder o where-  setupJoinPoint :: ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a--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))-  buildRec  :: Regs rs-            -> Ctx s o a-            -> Machine s o '[] One r a-            -> Code (Func rs s o a r)--#define deriveJoinBuilder(_o)                                                             \-instance JoinBuilder _o where                                                             \-{                                                                                         \-  setupJoinPoint φ (Machine k) mx =                                                       \-    liftM2 (\mk ctx γ -> [||                                                              \-      let join x !(o# :: Unboxed _o) =                                                    \-        $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||$$box o#||]})) \-      in $$(run mx γ (insertΦ φ [||join||] ctx))                                          \-    ||]) (local voidCoins k) ask;                                                         \-};-inputInstances(deriveJoinBuilder)--#define deriveRecBuilder(_o)                                                     \-instance RecBuilder _o where                                                     \-{                                                                                \-  buildIter ctx μ l h o = let bx = box in [||                                    \-      let handler !o# = $$(h [||$$bx o#||]);                                     \-          loop !o# =                                                             \-        $$(run l                                                                 \-            (Γ Empty (noreturn @_o) [||$$bx o#||] (VCons [||handler o#||] VNil)) \-            (voidCoins (insertSub μ [||\_ (!o#) _ -> loop o#||] ctx)))           \-      in loop ($$unbox $$o)                                                      \-    ||];                                                                         \-  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) ||]); \-};-inputInstances(deriveRecBuilder)--takeFreeRegisters :: Regs rs -> Ctx s o a -> (Ctx s o a -> Code (SubRoutine s o a x)) -> Code (Func rs s o a x)-takeFreeRegisters NoRegs ctx body = body ctx-takeFreeRegisters (FreeReg σ σs) ctx body = [||\(!reg) -> $$(takeFreeRegisters σs (insertScopedΣ σ [||reg||] ctx) body)||]--{- Debugger Operations -}-class (BoxOps o, PositionOps o, LogOps o) => LogHandler o where-  logHandler :: (?ops :: InputOps o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Code o -> Code (Handler s o a)--preludeString :: (?ops :: InputOps o, PositionOps o, LogOps o) => String -> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String-preludeString name dir γ ctx ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]-  where-    offset     = input γ-    indent     = replicate (debugLevel ctx * 2) ' '-    start      = [|| $$shiftLeft $$offset 5 ||]-    end        = [|| $$shiftRight $$offset 5 ||]-    inputTrace = [|| let replace '\n' = color Green "↙"-                         replace ' '  = color White "·"-                         replace c    = return c-                         go i-                           | $$same i $$end || not ($$more i) = []-                           | otherwise = $$(next [||i||] (\qc qi' -> [||replace $$qc ++ go $$qi'||]))-                     in go $$start ||]-    eof        = [|| if $$more $$end then $$inputTrace else $$inputTrace ++ color Red "•" ||]-    prelude    = [|| concat [indent, dir : name, dir : " (", show ($$offToInt $$offset), "): "] ||]-    caretSpace = [|| replicate (length $$prelude + $$offToInt $$offset - $$offToInt $$start) ' ' ||]--#define deriveLogHandler(_o)                                                                         \-instance LogHandler _o where                                                                         \-{                                                                                                    \-  logHandler name ctx γ _ = let VCons h _ = handlers γ in [||\(!o#) ->                               \-      trace $$(preludeString name '<' (γ {input = [||$$box o#||]}) ctx (color Red " Fail")) ($$h o#) \-    ||];                                                                                             \-};-inputInstances(deriveLogHandler)---- RIP Dream :(-{-$(let derive _o = [d|-        instance HandlerOps _o where-          fatal = [||\(!o#) -> return Nothing :: ST s (Maybe a)||]-        |] in traverse derive representationTypes)-}

@@ -1,160 +0,0 @@-{-# LANGUAGE DeriveAnyClass,-             ExistentialQuantification,-             TypeFamilies,-             DerivingStrategies #-}-module Parsley.Internal.Backend.Machine.State (-    HandlerStack, Handler, Cont, SubRoutine, MachineMonad, Func,-    Γ(..), Ctx, OpStack(..),-    QSubRoutine(..), QJoin(..), Machine(..),-    run,-    emptyCtx,-    insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ,-    askSub, askΦ,-    debugUp, debugDown, debugLevel,-    storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins,-    hasCoin, isBankrupt, liquidate-  ) where--import Control.Exception                            (Exception, throw)-import Control.Monad                                (liftM2)-import Control.Monad.Reader                         (asks, MonadReader, Reader, runReader)-import Control.Monad.ST                             (ST)-import Data.STRef                                   (STRef)-import Data.Dependent.Map                           (DMap)-import Data.Kind                                    (Type)-import Data.Maybe                                   (fromMaybe)-import Parsley.Internal.Backend.Machine.Defunc      (Defunc)-import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΣVar(..), ΦVar, IMVar, IΣVar)-import Parsley.Internal.Backend.Machine.InputRep    (Unboxed)-import Parsley.Internal.Backend.Machine.LetBindings (Regs(..))-import Parsley.Internal.Common                      (Queue, enqueue, dequeue, Code, Vec)--import qualified Data.Dependent.Map as DMap             ((!), insert, empty, lookup)-import qualified Parsley.Internal.Common.Queue as Queue (empty, null, foldr)--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 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-  Func '[] s o a x      = SubRoutine s o a x-  Func (r : rs) s o a x = STRef s r -> Func rs s o a x--data QSubRoutine s o a x = forall rs. QSubRoutine  (Code (Func rs s o a x)) (Regs rs)-newtype QJoin s o a x = QJoin { unwrapJoin :: Code (Cont s o a x) }-newtype Machine s o xs n r a = Machine { getMachine :: MachineMonad s o xs n r a }--run :: Machine s o xs n r a -> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))-run = flip . runReader . getMachine--data OpStack xs where-  Empty :: OpStack '[]-  Op :: Defunc x -> OpStack xs -> OpStack (x ': xs)--data Reg s x = Reg { getReg    :: Maybe (Code (STRef s x))-                   , getCached :: Maybe (Defunc x) }--data Γ s o xs n r a = Γ { operands :: OpStack xs-                        , retCont  :: Code (Cont s o a r)-                        , input    :: Code o-                        , handlers :: HandlerStack n s o a }--data Ctx s o a = Ctx { μs         :: DMap MVar (QSubRoutine s o a)-                     , φs         :: DMap ΦVar (QJoin s o a)-                     , σs         :: DMap ΣVar (Reg s)-                     , debugLevel :: Int-                     , coins      :: Int-                     , piggies    :: Queue Int }--emptyCtx :: DMap MVar (QSubRoutine s o a) -> Ctx s o a-emptyCtx μs = Ctx μs DMap.empty DMap.empty 0 0 Queue.empty--insertSub :: MVar x -> Code (SubRoutine s o a x) -> Ctx s o a -> Ctx s o a-insertSub μ q ctx = ctx {μs = DMap.insert μ (QSubRoutine q NoRegs) (μs ctx)}--insertΦ :: ΦVar x -> Code (Cont s o a x) -> Ctx s o a -> Ctx s o a-insertΦ φ qjoin ctx = ctx {φs = DMap.insert φ (QJoin qjoin) (φs ctx)}--insertNewΣ :: ΣVar x -> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a-insertNewΣ σ qref x ctx = ctx {σs = DMap.insert σ (Reg qref (Just x)) (σs ctx)}--insertScopedΣ :: ΣVar x -> Code (STRef s x) -> Ctx s o a -> Ctx s o a-insertScopedΣ σ qref ctx = ctx {σs = DMap.insert σ (Reg (Just qref) Nothing) (σs ctx)}--cacheΣ :: ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a-cacheΣ σ x ctx = case DMap.lookup σ (σs ctx) of-  Just (Reg ref _) -> ctx {σs = DMap.insert σ (Reg ref (Just x)) (σs ctx)}-  Nothing          -> throw (outOfScopeRegister σ)--concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x)-concreteΣ σ = fromMaybe (throw (intangibleRegister σ)) . (>>= getReg) . DMap.lookup σ . σs--cachedΣ :: ΣVar x -> Ctx s o a -> Defunc x-cachedΣ σ = fromMaybe (throw (registerFault σ)) . (>>= getCached) . DMap.lookup σ . σs--askSub :: MonadReader (Ctx s o a) m => MVar x -> m (Code (SubRoutine s o a x))-askSub μ =-  do QSubRoutine sub rs <- askSubUnbound μ-     asks (provideFreeRegisters sub rs)--askSubUnbound :: MonadReader (Ctx s o a) m => MVar x -> m (QSubRoutine s o a x)-askSubUnbound μ = asks (fromMaybe (throw (missingDependency μ)) . DMap.lookup μ . μs)--provideFreeRegisters :: Code (Func rs s o a x) -> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)-provideFreeRegisters sub NoRegs _ = sub-provideFreeRegisters f (FreeReg σ σs) ctx = provideFreeRegisters [||$$f $$(concreteΣ σ ctx)||] σs ctx--askΦ :: MonadReader (Ctx s o a) m => ΦVar x -> m (Code (Cont s o a x))-askΦ φ = asks (unwrapJoin . (DMap.! φ) . φs)--debugUp :: Ctx s o a -> Ctx s o a-debugUp ctx = ctx {debugLevel = debugLevel ctx + 1}--debugDown :: Ctx s o a -> Ctx s o a-debugDown ctx = ctx {debugLevel = debugLevel ctx - 1}---- Piggy bank functions-storePiggy :: Int -> Ctx s o a -> Ctx s o a-storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx)}--breakPiggy :: Ctx s o a -> Ctx s o a-breakPiggy ctx = let (coins, piggies') = dequeue (piggies ctx) in ctx {coins = coins, piggies = piggies'}--hasCoin :: Ctx s o a -> Bool-hasCoin = (> 0) . coins--isBankrupt :: Ctx s o a -> Bool-isBankrupt = liftM2 (&&) (not . hasCoin) (Queue.null . piggies)--spendCoin :: Ctx s o a -> Ctx s o a-spendCoin ctx = ctx {coins = coins ctx - 1}--giveCoins :: Int -> Ctx s o a -> Ctx s o a-giveCoins c ctx = ctx {coins = coins ctx + c}--voidCoins :: Ctx s o a -> Ctx s o a-voidCoins ctx = ctx {coins = 0, piggies = Queue.empty}--liquidate :: Ctx s o a -> Int-liquidate ctx = Queue.foldr (+) (coins ctx) (piggies ctx)--newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception-newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Exception-newtype IntangibleRegister = IntangibleRegister IΣVar deriving anyclass Exception-newtype RegisterFault = RegisterFault IΣVar deriving anyclass Exception--missingDependency :: MVar x -> MissingDependency-missingDependency (MVar v) = MissingDependency v-outOfScopeRegister :: ΣVar x -> OutOfScopeRegister-outOfScopeRegister (ΣVar σ) = OutOfScopeRegister σ-intangibleRegister :: ΣVar x -> IntangibleRegister-intangibleRegister (ΣVar σ) = IntangibleRegister σ-registerFault :: ΣVar x -> RegisterFault-registerFault (ΣVar σ) = RegisterFault σ--instance Show MissingDependency where show (MissingDependency μ) = "Dependency μ" ++ show μ ++ " has not been compiled"-instance Show OutOfScopeRegister where show (OutOfScopeRegister σ) = "Register r" ++ show σ ++ " is out of scope"-instance Show IntangibleRegister where show (IntangibleRegister σ) = "Register r" ++ show σ ++ " is intangible in this scope"-instance Show RegisterFault where show (RegisterFault σ) = "Attempting to access register r" ++ show σ ++ " from cache has failed"

@@ -29,17 +29,15 @@ import Prelude hiding            (readFile) import Data.Text.IO              (readFile) import Parsley.InputExtras       (Text16(..))-import Parsley.Internal.Backend  (codeGen, Input, eval)-import Parsley.Internal.Frontend (compile)-import Parsley.Internal.Trace    (Trace(trace))+import Parsley.Internal          (codeGen, Input, eval, compile, Trace(trace))  import Parsley.Alternative              as Alternative import Parsley.Applicative              as Applicative import Parsley.Combinator               as Combinator  (item, char, string, satisfy, notFollowedBy, lookAhead, try) import Parsley.Fold                     as Fold        (many, some)-import Parsley.Internal.Core            as Core        (Parser, ParserOps)-import Parsley.Internal.Common.Utils    as THUtils     (Quapplicative(..), WQ, Code)-import Parsley.Internal.Core.Primitives as Primitives  (debug)+import Parsley.Internal                 as Core        (Parser, ParserOps)+import Parsley.Internal                 as THUtils     (Quapplicative(..), WQ, Code)+import Parsley.Internal                 as Primitives  (debug) import Parsley.Selective                as Selective  {-|

@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} {-| Module      : Parsley.Defunctionalized Description : Defunctionalised operators usable in place of plain Haskell equivalents@@ -13,7 +14,11 @@ @since 0.1.0.0 -} module Parsley.Defunctionalized (-    module Parsley.Internal.Core.Defunc+    Defunc(..),+    pattern UNIT,+    pattern FLIP_CONST,+    pattern FLIP_H,+    pattern COMPOSE_H   ) where -import Parsley.Internal.Core.Defunc hiding (genDefunc, genDefunc1, genDefunc2, ap)+import Parsley.Internal (Defunc(..), pattern UNIT, pattern FLIP_CONST, pattern FLIP_H, pattern COMPOSE_H)

@@ -1,36 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-|-Module      : Parsley.Internal-Description : The gateway into the internals: here be monsters!-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : unstable--This module exposes all of the /required/ functionality found in the internals of the library out-to the user API.--@since 0.1.0.0--}-module Parsley.Internal (-    module Core,-    module Primitives,-    module THUtils,-    module Trace,-    module Frontend,-    module Backend-  ) where--import Parsley.Internal.Backend         as Backend    (codeGen, Input, eval)-import Parsley.Internal.Core            as Core-import Parsley.Internal.Core.Primitives as Primitives (-    pure, (<*>), (*>), (<*),-    (<|>), empty,-    satisfy, lookAhead, try, notFollowedBy,-    chainPre, chainPost,-    Reg, newRegister, get, put,-    conditional, branch,-    debug-  )-import Parsley.Internal.Common.Utils    as THUtils    (Quapplicative(..), WQ, Code, makeQ)-import Parsley.Internal.Frontend        as Frontend   (compile)-import Parsley.Internal.Trace           as Trace      (Trace(trace))

@@ -1,16 +0,0 @@-{-|-Module      : Parsley.Internal.Backend-Description : The backend is concerned with code generation and control flow analysis-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : stable--@since 0.1.0.0--}-module Parsley.Internal.Backend (-    module Parsley.Internal.Backend.CodeGenerator,-    module Parsley.Internal.Backend.Machine-  ) where--import Parsley.Internal.Backend.CodeGenerator (codeGen)-import Parsley.Internal.Backend.Machine       (Input, eval)

@@ -1,192 +0,0 @@-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# LANGUAGE PatternSynonyms #-}-module Parsley.Internal.Backend.CodeGenerator (codeGen) where--import Data.Maybe                                    (isJust)-import Data.Set                                      (Set, elems)-import Control.Monad.Trans                           (lift)-import Parsley.Internal.Backend.Machine              (Defunc(USER, SAME), LetBinding, makeLetBinding, Instr(..),-                                                      pattern Fmap, pattern App, _Modify, _Get, _Put, _Make, pattern If,-                                                      addCoins, refundCoins, drainCoins, PositionOps,-                                                      IMVar, IΦVar, IΣVar, MVar(..), ΦVar(..), ΣVar(..))-import Parsley.Internal.Backend.InstructionAnalyser  (coinsNeeded)-import Parsley.Internal.Common.Fresh                 (VFreshT, HFresh, evalFreshT, evalFresh, construct, MonadFresh(..), mapVFreshT)-import Parsley.Internal.Common.Indexed               (Fix, Fix4(In4), Cofree(..), Nat(..), imap, histo, extract, (|>))-import Parsley.Internal.Core.CombinatorAST           (Combinator(..), MetaCombinator(..))-import Parsley.Internal.Core.Defunc                  (Defunc(COMPOSE, ID), pattern FLIP_H, pattern UNIT)-import Parsley.Internal.Trace                        (Trace(trace))--import Parsley.Internal.Core.Defunc as Core          (Defunc)--type CodeGenStack a = VFreshT IΦVar (VFreshT IMVar (HFresh IΣVar)) a-runCodeGenStack :: CodeGenStack a -> IMVar -> IΦVar -> IΣVar -> a-runCodeGenStack m μ0 φ0 σ0 =-  (flip evalFresh σ0 .-   flip evalFreshT μ0 .-   flip evalFreshT φ0) m--newtype CodeGen o a x =-  CodeGen {runCodeGen :: forall xs n r. Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)}--{-# INLINEABLE codeGen #-}-codeGen :: (Trace, PositionOps o) => Maybe (MVar x) -> Fix Combinator x -> Set IΣVar -> IMVar -> IΣVar -> LetBinding o a x-codeGen letBound p rs μ0 σ0 = trace ("GENERATING " ++ name ++ ": " ++ show p ++ "\nMACHINE: " ++ show (map ΣVar (elems rs)) ++ " => " ++ show m) $ makeLetBinding m rs-  where-    name = maybe "TOP LEVEL" show letBound-    m = finalise (histo alg p)-    alg :: PositionOps o => Combinator (Cofree Combinator (CodeGen o a)) x -> CodeGen o a x-    alg = peephole |> (\x -> CodeGen (direct (imap extract x)))-    finalise cg =-      let m = runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0 σ0-      in if isJust letBound then m else addCoins (coinsNeeded m) m--pattern (:<$>:) :: Core.Defunc (a -> b) -> k a -> Combinator (Cofree Combinator k) b-pattern f :<$>: p <- (_ :< Pure f) :<*>: (p :< _)-pattern (:$>:) :: Combinator (Cofree Combinator k) a -> Core.Defunc b -> Combinator (Cofree Combinator k) b-pattern p :$>: x <- (_ :< p) :*>: (_ :< Pure x)-pattern LiftA2 :: Core.Defunc (a -> b -> c) -> k a -> k b -> Combinator (Cofree Combinator k) c-pattern LiftA2 f p q <- (_ :< ((_ :< Pure f) :<*>: (p :< _))) :<*>: (q :< _)-pattern TryOrElse ::  k a -> k a -> Combinator (Cofree Combinator k) a-pattern TryOrElse p q <- (_ :< Try (p :< _)) :<|>: (q :< _)--rollbackHandler :: Fix4 (Instr o) (o : xs) (Succ n) r a-rollbackHandler = In4 (Seek (In4 Empt))--parsecHandler :: PositionOps o => Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) (o : xs) (Succ n) r a-parsecHandler k = In4 (Tell (In4 (Lift2 SAME (In4 (If k (In4 Empt))))))--peephole :: PositionOps o => Combinator (Cofree Combinator (CodeGen o a)) x -> Maybe (CodeGen o a x)-peephole (f :<$>: p) = Just $ CodeGen $ \m -> runCodeGen p (In4 (Fmap (USER f) m))-peephole (LiftA2 f p q) = Just $ CodeGen $ \m ->-  do qc <- runCodeGen q (In4 (Lift2 (USER f) m))-     runCodeGen p qc-peephole (TryOrElse p q) = Just $ CodeGen $ \m -> -- FIXME!-  do (binder, φ) <- makeΦ m-     pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))-     fmap (binder . In4 . Catch pc . In4 . Seek) (freshΦ (runCodeGen q φ))-peephole ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ \m ->-  do (binder, φ) <- makeΦ m-     pc <- freshΦ (runCodeGen p (deadCommitOptimisation (In4 (Pop (In4 (Push (USER x) φ))))))-     fmap (binder . In4 . Catch pc . In4 . Seek) (freshΦ (runCodeGen q φ))-peephole (MetaCombinator RequiresCut (_ :< ((p :< _) :<|>: (q :< _)))) = Just $ CodeGen $ \m ->-  do (binder, φ) <- makeΦ m-     pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))-     qc <- freshΦ (runCodeGen q φ)-     return $! binder (In4 (Catch pc (parsecHandler qc)))-peephole (MetaCombinator RequiresCut (_ :< ChainPre (op :< _) (p :< _))) = Just $ CodeGen $ \m ->-  do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (Fmap (USER (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))-     pc <- freshM (runCodeGen p (In4 (App m)))-     return $! In4 (Push (USER ID) (In4 (_Make σ (In4 (Iter μ opc (parsecHandler (In4 (_Get σ (addCoins (coinsNeeded pc) pc)))))))))-peephole (MetaCombinator RequiresCut (_ :< ChainPost (p :< _) (op :< _))) = Just $ CodeGen $ \m ->-  do μ <- askM-     σ <- freshΣ-     let nm = coinsNeeded m-     opc <- freshM (runCodeGen op (In4 (_Modify σ (In4 (Jump μ)))))-     freshM (runCodeGen p (In4 (_Make σ (In4 (Iter μ opc (parsecHandler (In4 (_Get σ (addCoins nm m)))))))))-peephole (MetaCombinator Cut (_ :< ChainPre (op :< _) (p :< _))) = Just $ CodeGen $ \m ->-  do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (Fmap (USER (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))-     let nop = coinsNeeded opc-     pc <- freshM (runCodeGen p (In4 (App m)))-     return $! In4 (Push (USER ID) (In4 (_Make σ (In4 (Iter μ (addCoins nop opc) (parsecHandler (In4 (_Get σ (addCoins (coinsNeeded pc) pc)))))))))--- TODO: One more for fmap try-peephole _ = Nothing--direct :: PositionOps o => Combinator (CodeGen o a) x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)-direct (Pure x)      m = do return $! In4 (Push (USER x) m)-direct (Satisfy p)   m = do return $! In4 (Sat (USER p) m)-direct (pf :<*>: px) m = do pxc <- runCodeGen px (In4 (App m)); runCodeGen pf pxc-direct (p :*>: q)    m = do qc <- runCodeGen q m; runCodeGen p (In4 (Pop qc))-direct (p :<*: q)    m = do qc <- runCodeGen q (In4 (Pop m)); runCodeGen p qc-direct Empty         _ = do return $! In4 Empt-direct (p :<|>: q) m =-  do (binder, φ) <- makeΦ m-     pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))-     qc <- freshΦ (runCodeGen q φ)-     let np = coinsNeeded pc-     let nq = coinsNeeded qc-     let dp = np - min np nq-     let dq = nq - min np nq-     return $! binder (In4 (Catch (addCoins dp pc) (parsecHandler (addCoins dq qc))))-direct (Try p)       m = do fmap (In4 . flip Catch rollbackHandler) (runCodeGen p (deadCommitOptimisation m))-direct (LookAhead p) m =-  do n <- fmap coinsNeeded (runCodeGen p (In4 Empt)) -- Dodgy hack, but oh well-     fmap (In4 . Tell) (runCodeGen p (In4 (Swap (In4 (Seek (refundCoins n m))))))-direct (NotFollowedBy p) m =-  do pc <- runCodeGen p (In4 (Pop (In4 (Seek (In4 (Commit (In4 Empt)))))))-     let np = coinsNeeded pc-     let nm = coinsNeeded m-     return $! In4 (Catch (addCoins (max (np - nm) 0) (In4 (Tell pc))) (In4 (Seek (In4 (Push (USER UNIT) m)))))-direct (Branch b p q) m =-  do (binder, φ) <- makeΦ m-     pc <- freshΦ (runCodeGen p (In4 (Swap (In4 (App φ)))))-     qc <- freshΦ (runCodeGen q (In4 (Swap (In4 (App φ)))))-     let minc = coinsNeeded (In4 (Case pc qc))-     let dp = max 0 (coinsNeeded pc - minc)-     let dq = max 0 (coinsNeeded qc - minc)-     fmap binder (runCodeGen b (In4 (Case (addCoins dp pc) (addCoins dq qc))))-direct (Match p fs qs def) m =-  do (binder, φ) <- makeΦ m-     qcs <- traverse (\q -> freshΦ (runCodeGen q φ)) qs-     defc <- freshΦ (runCodeGen def φ)-     let minc = coinsNeeded (In4 (Choices (map USER fs) qcs defc))-     let defc':qcs' = map (max 0 . subtract minc . coinsNeeded >>= addCoins) (defc:qcs)-     fmap binder (runCodeGen p (In4 (Choices (map USER fs) qcs' defc')))-direct (Let _ μ _) m = return $! tailCallOptimise μ m-direct (ChainPre op p) m =-  do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (Fmap (USER (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))-     let nop = coinsNeeded opc-     pc <- freshM (runCodeGen p (In4 (App m)))-     return $! In4 (Push (USER ID) (In4 (_Make σ (In4 (Iter μ (addCoins nop opc) (parsecHandler (In4 (_Get σ pc))))))))-direct (ChainPost p op) m =-  do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (_Modify σ (In4 (Jump μ)))))-     let nop = coinsNeeded opc-     freshM (runCodeGen p (In4 (_Make σ (In4 (Iter μ (addCoins nop opc) (parsecHandler (In4 (_Get σ m))))))))-direct (MakeRegister σ p q)   m = do qc <- runCodeGen q m; runCodeGen p (In4 (_Make σ qc))-direct (GetRegister σ)        m = do return $! In4 (_Get σ m)-direct (PutRegister σ p)      m = do runCodeGen p (In4 (_Put σ (In4 (Push (USER UNIT) m))))-direct (Debug name p)         m = do fmap (In4 . LogEnter name) (runCodeGen p (In4 (Commit (In4 (LogExit name m)))))-direct (MetaCombinator Cut p) m = do runCodeGen p (addCoins (coinsNeeded m) m)--tailCallOptimise :: MVar x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-tailCallOptimise μ (In4 Ret) = In4 (Jump μ)-tailCallOptimise μ k         = In4 (Call μ k)---- Thanks to the optimisation applied to the K stack, commit is deadcode before Ret--- However, I'm not yet sure about the interactions with try yet...-deadCommitOptimisation :: Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs (Succ n) r a-deadCommitOptimisation (In4 Ret) = In4 Ret-deadCommitOptimisation m         = In4 (Commit m)---- Refactor with asks-askM :: CodeGenStack (MVar a)-askM = lift (construct MVar)--askΦ :: CodeGenStack (ΦVar a)-askΦ = construct ΦVar--freshM :: CodeGenStack a -> CodeGenStack a-freshM = mapVFreshT newScope--freshΦ :: CodeGenStack a -> CodeGenStack a-freshΦ = newScope--makeΦ :: Fix4 (Instr o) (x ': xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a, Fix4 (Instr o) (x : xs) (Succ n) r a)-makeΦ m | elidable m = return $! (id, m)-  where-    -- This is double-φ optimisation:   If a φ-node points directly to another φ-node, then it can be elided-    elidable (In4 (Join _)) = True-    -- This is terminal-φ optimisation: If a φ-node points directly to a terminal operation, then it can be elided-    elidable (In4 Ret)      = True-    elidable _              = False-makeΦ m = let n = coinsNeeded m in fmap (\φ -> (In4 . MkJoin φ (addCoins n m), drainCoins n (In4 (Join φ)))) askΦ--freshΣ :: CodeGenStack (ΣVar a)-freshΣ = lift (lift (construct ΣVar))

@@ -1,123 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses,-             TypeFamilies,-             UndecidableInstances #-}-module Parsley.Internal.Backend.InstructionAnalyser (coinsNeeded, relevancy, Length) where--import Data.Kind                        (Type)-import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..))-import Parsley.Internal.Common.Indexed  (cata4, Fix4, Const4(..))-import Parsley.Internal.Common.Vec      (Vec(..), Nat(..), SNat(..), SingNat(..), zipWithVec, replicateVec)--coinsNeeded :: Fix4 (Instr o) xs n r a -> Int-coinsNeeded = fst . getConst4 . cata4 (Const4 . alg)-  where-    algCatch :: (Int, Bool) -> (Int, Bool) -> (Int, Bool)-    algCatch k (_, True) = k-    algCatch (_, True) k = k-    algCatch (k1, _) (k2, _) = (min k1 k2, False)--    alg :: Instr o (Const4 (Int, Bool)) xs n r a -> (Int, Bool)-    alg Ret                                    = (0, False)-    alg (Push _ (Const4 k))                    = (fst k, False)-    alg (Pop k)                                = getConst4 k-    alg (Lift2 _ k)                            = getConst4 k-    alg (Sat _ (Const4 k))                     = (fst k + 1, snd k)-    alg (Call _ (Const4 k))                    = (0, snd k)-    alg (Jump _)                               = (0, False)-    alg Empt                                   = (0, True)-    alg (Commit k)                             = getConst4 k-    alg (Catch k h)                            = algCatch (getConst4 k) (getConst4 h)-    alg (Tell k)                               = getConst4 k-    alg (Seek k)                               = getConst4 k-    alg (Case p q)                             = algCatch (getConst4 p) (getConst4 q)-    alg (Choices _ ks def)                     = foldr (algCatch . getConst4) (getConst4 def) ks-    alg (Iter _ _ (Const4 k))                  = (0, snd k)-    alg (Join _)                               = (0, False)-    alg (MkJoin _ (Const4 b) (Const4 k))       = (fst k + fst b, snd k || snd b)-    alg (Swap k)                               = getConst4 k-    alg (Dup k)                                = getConst4 k-    alg (Make _ _ k)                           = getConst4 k-    alg (Get _ _ k)                            = getConst4 k-    alg (Put _ _ k)                            = getConst4 k-    alg (LogEnter _ k)                         = getConst4 k-    alg (LogExit _ k)                          = getConst4 k-    alg (MetaInstr (AddCoins _) (Const4 k))    = k-    alg (MetaInstr (RefundCoins n) (Const4 k)) = (max (fst k - n) 0, snd k) -- These were refunded, so deduct-    alg (MetaInstr (DrainCoins _) (Const4 k))  = (fst k, False)--{- TODO-  Live Value Analysis-  ---------------------  This analysis is designed to clean up dead registers:-    * Instead of the state laws on the Combinator AST, this should catch these cases-    * By performing it here we have ready access to the control flow information-    * We'll perform global register analysis--  State Laws:-    * get *> get = get = get <* get-    * put (pure x) *> get = put (pure x) *> pure x-    * put get = pure ()-    * put x *> put (pure y) = x *> put (pure y) = put x <* put (pure y)-    -->-    * Get . Pop . Get = Get = Get . Get . Pop -- Captured by relevancy analysis-    * Get . Get = Get . Dup Subsumes the above (Dup . Pop = id, Dup . Swap = Dup)-    * px . Put . Push () . Pop . Get = px . Dup . Put . Push () . Pop -- ??? (this law is better than above)-    * Get . Put . Push () = Push () -- ??? Improved relevancy analysis?-    * px . Put . Push () . Pop . py . Put . Push () = px . Pop . Push () . Pop . py . Put . Push () = px . Put . Push () . py . Put . Push () . Pop -- Captured by dead register analysis--  Best case scenario is that we can capture all of the above optimisations-  without a need to explicitly implement them.--  Idea 1) recurse through the machine and mark branches with their liveIn set-          if a register is not liveIn after a Put instruction it can be removed-          Get r gens r-          Put r kills r-  Idea 2) recurse through the machine and collect relevancy data:-          a value on the stack is relevant if it is consumed by `Lift2` or `Case`, etc-          it is irrelevant if consumed by Pop-          if Get produces an irrelevant operand, it can be replaced by Push BOTTOM-          Dup disjoins the relevancy of the top two elements of the stack-          Swap switches the relevancy of the top two elements of the stack-  Idea 3) recurse through the machine and collect everUsed information-          if a register is never used, then the Make instruction can be removed--}--type family Length (xs :: [Type]) :: Nat where-  Length '[] = Zero-  Length (_ : xs) = Succ (Length xs)--newtype RelevancyStack xs (n :: Nat) r a = RelevancyStack { getStack :: SNat (Length xs) -> Vec (Length xs) Bool }--relevancy :: SingNat (Length xs) => Fix4 (Instr o) xs n r a -> Vec (Length xs) Bool-relevancy = ($ sing) . getStack . cata4 (RelevancyStack . alg)-  where-    zipRelevancy = zipWithVec (||)--    -- This algorithm is over-approximating: join and ret aren't _always_ relevant-    alg :: Instr o RelevancyStack xs n r a -> SNat (Length xs) -> Vec (Length xs) Bool-    alg Ret                _         = VCons True VNil-    alg (Push _ k)         n         = let VCons _ xs = getStack k (SSucc n) in xs-    alg (Pop k)            (SSucc n) = VCons False (getStack k n)-    alg (Lift2 _ k)        (SSucc n) = let VCons rel xs = getStack k n in VCons rel (VCons rel xs)-    alg (Sat _ k)          n         = let VCons _ xs = getStack k (SSucc n) in xs-    alg (Call _ k)         n         = let VCons _ xs = getStack k (SSucc n) in xs-    alg (Jump _)           _         = VNil-    alg Empt               n         = replicateVec n False-    alg (Commit k)         n         = getStack k n-    alg (Catch k _)        n         = getStack k n-    alg (Tell k)           n         = let VCons _ xs = getStack k (SSucc n) in xs-    alg (Seek k)           (SSucc n) = VCons True (getStack k n)-    alg (Case p q)         n         = VCons True (let VCons _ xs = zipRelevancy (getStack p n) (getStack q n) in xs)-    alg (Choices _ ks def) (SSucc n) = VCons True (foldr (zipRelevancy . (`getStack` n)) (getStack def n) ks)-    alg (Iter _ _ k)       n         = let VCons _ xs = getStack k (SSucc n) in xs-    alg (Join _)           (SSucc n) = VCons True (replicateVec n False)-    alg (MkJoin _ b _)     n         = let VCons _ xs = getStack b (SSucc n) in xs-    alg (Swap k)           n         = let VCons rel1 (VCons rel2 xs) = getStack k n in VCons rel2 (VCons rel1 xs)-    alg (Dup k)            n         = let VCons rel1 (VCons rel2 xs) = getStack k (SSucc n) in VCons (rel1 || rel2) xs-    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 (LogEnter _ k)     n         = getStack k n-    alg (LogExit _ k)      n         = getStack k n-    alg (MetaInstr _ k)    n         = getStack k n

@@ -1,30 +0,0 @@-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# LANGUAGE DerivingStrategies,-             GeneralizedNewtypeDeriving #-}-module Parsley.Internal.Backend.Machine.Identifiers (-    ΦVar(..), IΦVar,-    module Parsley.Internal.Core.Identifiers,-  ) where--import Data.GADT.Compare                 (GEq, GCompare, gcompare, geq, GOrdering(..))-import Data.Kind                         (Type)-import Data.Typeable                     ((:~:)(Refl))-import Data.Word                         (Word64)-import Parsley.Internal.Core.Identifiers -- for re-export-import Unsafe.Coerce                     (unsafeCoerce)--newtype ΦVar (a :: Type) = ΦVar IΦVar-newtype IΦVar = IΦVar Word64 deriving newtype (Ord, Eq, Num, Enum, Show)--instance Show (ΦVar a) where show (ΦVar φ) = "φ" ++ show φ--instance GEq ΦVar where-  geq (ΦVar u) (ΦVar v)-    | u == v    = Just (unsafeCoerce Refl)-    | otherwise = Nothing--instance GCompare ΦVar where-  gcompare φ1@(ΦVar u) φ2@(ΦVar v) = case compare u v of-    LT -> GLT-    EQ -> case geq φ1 φ2 of Just Refl -> GEQ-    GT -> GGT

@@ -1,141 +0,0 @@-{-# LANGUAGE OverloadedStrings,-             PatternSynonyms,-             DerivingStrategies #-}-module Parsley.Internal.Backend.Machine.Instructions (module Parsley.Internal.Backend.Machine.Instructions) where--import Data.Kind                                    (Type)-import Data.Void                                    (Void)-import Parsley.Internal.Backend.Machine.Identifiers (MVar, ΦVar, ΣVar)-import Parsley.Internal.Common                      (IFunctor4, Fix4(In4), Const4(..), imap4, cata4, Nat(..), One, intercalateDiff)--import Parsley.Internal.Backend.Machine.Defunc as Machine (Defunc(USER))-import Parsley.Internal.Core.Defunc            as Core    (Defunc(ID), pattern FLIP_H)--data Instr (o :: rep) (k :: [Type] -> Nat -> Type -> Type -> Type) (xs :: [Type]) (n :: Nat) (r :: Type) (a :: Type) where-  Ret       :: Instr o k '[x] n x a-  Push      :: Machine.Defunc x -> k (x : xs) n r a -> Instr o k xs n r a-  Pop       :: k xs n r a -> Instr o k (x : xs) n r a-  Lift2     :: Machine.Defunc (x -> y -> z) -> k (z : xs) n r a -> Instr o k (y : x : xs) n r a-  Sat       :: Machine.Defunc (Char -> Bool) -> k (Char : xs) (Succ n) r a -> Instr o k xs (Succ n) r a-  Call      :: MVar x -> k (x : xs) (Succ n) r a -> Instr o k xs (Succ n) r a-  Jump      :: MVar x -> Instr o k '[] (Succ n) x a-  Empt      :: Instr o k xs (Succ n) r a-  Commit    :: k xs n r a -> Instr o k xs (Succ n) r a-  Catch     :: k xs (Succ n) r a -> k (o : xs) n r a -> Instr o k xs n r a-  Tell      :: k (o : xs) n r a -> Instr o k xs n r a-  Seek      :: k xs n r a -> Instr o k (o : xs) n r a-  Case      :: k (x : xs) n r a -> k (y : xs) n r a -> Instr o k (Either x y : xs) n r a-  Choices   :: [Machine.Defunc (x -> Bool)] -> [k xs n r a] -> k xs n r a -> Instr o k (x : xs) n r a-  Iter      :: MVar Void -> k '[] One Void a -> k (o : xs) n r a -> Instr o k xs n r a-  Join      :: ΦVar x -> Instr o k (x : xs) n r a-  MkJoin    :: ΦVar x -> k (x : xs) n r a -> k xs n r a -> Instr o k xs n r a-  Swap      :: k (x : y : xs) n r a -> Instr o k (y : x : xs) n r a-  Dup       :: k (x : x : xs) n r a -> Instr o k (x : xs) n r a-  Make      :: ΣVar x -> Access -> k xs n r a -> Instr o k (x : xs) n r a-  Get       :: ΣVar x -> Access -> k (x : xs) n r a -> Instr o k xs n r a-  Put       :: ΣVar x -> Access -> k xs n r a -> Instr o k (x : xs) n r a-  LogEnter  :: String -> k xs (Succ (Succ n)) r a -> Instr o k xs (Succ n) r a-  LogExit   :: String -> k xs n r a -> Instr o k xs n r a-  MetaInstr :: MetaInstr n -> k xs n r a -> Instr o k xs n r a--data Access = Hard | Soft deriving stock Show--data MetaInstr (n :: Nat) where-  AddCoins    :: Int -> MetaInstr (Succ n)-  RefundCoins :: Int -> MetaInstr n-  DrainCoins  :: Int -> MetaInstr (Succ n)--mkCoin :: (Int -> MetaInstr n) -> Int -> Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a-mkCoin _    0 = id-mkCoin meta n = In4 . MetaInstr (meta n)--addCoins :: Int -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-addCoins = mkCoin AddCoins-refundCoins :: Int -> Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a-refundCoins = mkCoin RefundCoins-drainCoins :: Int -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-drainCoins = mkCoin DrainCoins--pattern App :: Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : (x -> y) : xs) n r a-pattern App k = Lift2 (USER ID) k--pattern Fmap :: Machine.Defunc (x -> y) -> Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : xs) n r a-pattern Fmap f k = Push f (In4 (Lift2 (USER (FLIP_H ID)) k))--_Modify :: ΣVar x -> Fix4 (Instr o) xs n r a -> Instr o (Fix4 (Instr o)) ((x -> x) : xs) n r a-_Modify σ  = _Get σ . In4 . App . In4 . _Put σ--_Make :: ΣVar x -> k xs n r a -> Instr o k (x : xs) n r a-_Make σ = Make σ Hard--_Put :: ΣVar x -> k xs n r a -> Instr o k (x : xs) n r a-_Put σ = Put σ Hard--_Get :: ΣVar x -> k (x : xs) n r a -> Instr o k xs n r a-_Get σ = Get σ Hard---- This this is a nice little trick to get this instruction to generate optimised code-pattern If :: Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a -> Instr o (Fix4 (Instr o)) (Bool : xs) n r a-pattern If t e = Choices [USER ID] [t] e--instance IFunctor4 (Instr o) where-  imap4 _ Ret                 = Ret-  imap4 f (Push x k)          = Push x (f k)-  imap4 f (Pop k)             = Pop (f k)-  imap4 f (Lift2 g k)         = Lift2 g (f k)-  imap4 f (Sat g k)           = Sat g (f k)-  imap4 f (Call μ k)          = Call μ (f k)-  imap4 _ (Jump μ)            = Jump μ-  imap4 _ Empt                = Empt-  imap4 f (Commit k)          = Commit (f k)-  imap4 f (Catch p h)         = Catch (f p) (f h)-  imap4 f (Tell k)            = Tell (f k)-  imap4 f (Seek k)            = Seek (f k)-  imap4 f (Case p q)          = Case (f p) (f q)-  imap4 f (Choices fs ks def) = Choices fs (map f ks) (f def)-  imap4 f (Iter μ l h)        = Iter μ (f l) (f h)-  imap4 _ (Join φ)            = Join φ-  imap4 f (MkJoin φ p k)      = MkJoin φ (f p) (f k)-  imap4 f (Swap k)            = Swap (f k)-  imap4 f (Dup k)             = Dup (f k)-  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 (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)--instance Show (Fix4 (Instr o) xs n r a) where-  show = ($ "") . getConst4 . cata4 (Const4 . alg)-    where-      alg :: forall xs n r a. Instr o (Const4 (String -> String)) xs n r a -> String -> String-      alg Ret                 = "Ret"-      alg (Call μ k)          = "(Call " . shows μ . " " . getConst4 k . ")"-      alg (Jump μ)            = "(Jump " . shows μ . ")"-      alg (Push x k)          = "(Push " . shows x . " " . getConst4 k . ")"-      alg (Pop k)             = "(Pop " . getConst4 k . ")"-      alg (Lift2 f k)         = "(Lift2 " . shows f . " " . getConst4 k . ")"-      alg (Sat f k)           = "(Sat " . shows f . " " . getConst4 k . ")"-      alg Empt                = "Empt"-      alg (Commit k)          = "(Commit " . getConst4 k . ")"-      alg (Catch p h)         = "(Catch " . getConst4 p . " " . getConst4 h . ")"-      alg (Tell k)            = "(Tell " . getConst4 k . ")"-      alg (Seek k)            = "(Seek " . getConst4 k . ")"-      alg (Case p q)          = "(Case " . getConst4 p . " " . getConst4 q . ")"-      alg (Choices fs ks def) = "(Choices " . shows fs . " [" . intercalateDiff ", " (map getConst4 ks) . "] " . getConst4 def . ")"-      alg (Iter μ l h)        = "{Iter " . shows μ . " " . getConst4 l . " " . getConst4 h . "}"-      alg (Join φ)            = shows φ-      alg (MkJoin φ p k)      = "(let " . shows φ . " = " . getConst4 p . " in " . getConst4 k . ")"-      alg (Swap k)            = "(Swap " . getConst4 k . ")"-      alg (Dup k)             = "(Dup " . getConst4 k . ")"-      alg (Make σ a k)        = "(Make " . shows σ . " " . shows a . " " . getConst4 k . ")"-      alg (Get σ a k)         = "(Get " . shows σ . " " . shows a . " " . getConst4 k . ")"-      alg (Put σ a k)         = "(Put " . shows σ . " " . shows a . " " . getConst4 k . ")"-      alg (LogEnter _ k)      = getConst4 k-      alg (LogExit _ k)       = getConst4 k-      alg (MetaInstr m k)     = "[" . shows m . "] " . getConst4 k--instance Show (MetaInstr n) where-  show (AddCoins n)    = "Add " ++ show n ++ " coins"-  show (RefundCoins n) = "Refund " ++ show n ++ " coins"-  show (DrainCoins n)  = "Using " ++ show n ++ " coins"

@@ -1,32 +0,0 @@-{-# LANGUAGE ExistentialQuantification,-             StandaloneDeriving,-             DerivingStrategies #-}-module Parsley.Internal.Backend.Machine.LetBindings (-    LetBinding(..),-    Regs(..),-    makeLetBinding,-    Binding-  ) where--import Prelude hiding                                (foldr)-import Data.Kind                                     (Type)-import Data.Set                                      (Set, foldr)-import Parsley.Internal.Backend.Machine.Identifiers  (IΣVar, ΣVar(..))-import Parsley.Internal.Backend.Machine.Instructions (Instr)-import Parsley.Internal.Common                       (Fix4, One)-import Unsafe.Coerce                                 (unsafeCoerce)--type Binding o a x = Fix4 (Instr o) '[] One x a-data LetBinding o a x = forall rs. LetBinding (Binding o a x) (Regs rs)-deriving stock instance Show (LetBinding o a x)--makeLetBinding :: Binding o a x -> Set IΣVar -> LetBinding o a x-makeLetBinding m rs = LetBinding m (unsafeMakeRegs rs)--data Regs (rs :: [Type]) where-  NoRegs :: Regs '[]-  FreeReg :: ΣVar r -> Regs rs -> Regs (r : rs)-deriving stock instance Show (Regs rs)--unsafeMakeRegs :: Set IΣVar -> Regs rs-unsafeMakeRegs =  foldr (\σ rs -> unsafeCoerce (FreeReg (ΣVar σ) rs)) (unsafeCoerce NoRegs)

@@ -1,50 +0,0 @@-{-# LANGUAGE TupleSections,-             CPP #-}-module Parsley.Internal.Backend.Machine.LetRecBuilder (letRec) where--import Data.Dependent.Sum                           (DSum((:=>)))-import Data.Functor.Const                           (Const(..))-import Data.GADT.Compare                            (GCompare)-import Data.Some                                    (Some(Some))-import Language.Haskell.TH                          (newName, Name)-#if __GLASGOW_HASKELL__ < 900-import Language.Haskell.TH.Syntax                   (Q, unTypeQ, unsafeTExpCoerce, Exp(VarE, LetE), Dec(FunD), Clause(Clause), Body(NormalB))-#else-import Language.Haskell.TH.Syntax                   (unTypeCode, unsafeCodeCoerce, Exp(VarE, LetE), Dec(FunD), Clause(Clause), Body(NormalB))-#endif-import Parsley.Internal.Backend.Machine.LetBindings (LetBinding(..), Binding, Regs)-import Parsley.Internal.Backend.Machine.State       (QSubRoutine(..), Func)-import Parsley.Internal.Common.Utils                (Code)--import Data.Dependent.Map as DMap (DMap, (!), map, toList, traverseWithKey)--#if __GLASGOW_HASKELL__ < 900-unsafeCodeCoerce :: Q Exp -> Code a-unsafeCodeCoerce = unsafeTExpCoerce-unTypeCode :: Code a -> Q Exp-unTypeCode = unTypeQ-#endif--letRec :: GCompare key => {-bindings-}   DMap key (LetBinding o a)-                       -> {-nameof-}     (forall x. key x -> String)-                       -> {-genBinding-} (forall x rs. Binding o a x -> Regs rs -> DMap key (QSubRoutine s o a) -> Code (Func rs s o a x))-                       -> {-expr-}       (DMap key (QSubRoutine s o a) -> Code b)-                       -> Code b-letRec bindings nameOf genBinding expr = unsafeCodeCoerce $-  do -- Make a bunch of names-     names <- traverseWithKey (\k (LetBinding _ rs) -> Const . (, Some rs) <$> newName (nameOf k)) bindings-     -- Wrap them up so that they are valid typed template haskell names-     let typedNames = DMap.map makeTypedName names-     -- Generate each binding providing them with the names-     let makeDecl (k :=> LetBinding body frees) =-          do let Const (name, _) = names ! k-             func <- unTypeCode (genBinding body frees typedNames)-             return (FunD name [Clause [] (NormalB func) []])-     decls <- traverse makeDecl (toList bindings)-     -- Generate the main expression using the same names-     exp <- unTypeCode (expr typedNames)-     -- Construct the let expression-     return (LetE decls exp)-  where-     makeTypedName :: Const (Name, Some Regs) x -> QSubRoutine s o a x-     makeTypedName (Const (name, Some frees)) = QSubRoutine (unsafeCodeCoerce (return (VarE name))) frees

@@ -1,17 +0,0 @@-module Parsley.Internal.Backend.Optimiser (optimise) where--import Data.GADT.Compare                (geq)-import Data.Typeable                    ((:~:)(Refl))-import Parsley.Internal.Backend.Machine-import Parsley.Internal.Common.Indexed---- We'll come back here later ;)-optimise :: Instr o (Fix4 (Instr o)) xs n r a -> Fix4 (Instr o) xs n r a-optimise (Push _ (In4 (Pop m))) = m-optimise (Get _ _ (In4 (Pop m))) = m-optimise (Dup (In4 (Pop m))) = m-optimise (Dup (In4 (Swap m))) = In4 (Dup m)-optimise (Get r1 a (In4 (Get r2 _ m))) | Just Refl <- r1 `geq` r2 = In4 (Get r1 a (In4 (Dup m)))-optimise (Put r1 a (In4 (Get r2 _ m))) | Just Refl <- r1 `geq` r2 = In4 (Dup (In4 (Put r1 a m)))-optimise (Get r1 _ (In4 (Put r2 _ m))) | Just Refl <- r1 `geq` r2 = m-optimise m = In4 m

@@ -1,22 +0,0 @@-{-|-Module      : Parsley.Internal.Core-Description : Functionality that is not parser specific but used in various places.-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : unstable--@since 0.1.0.0--}-module Parsley.Internal.Common (-    module Parsley.Internal.Common.Fresh,-    module Parsley.Internal.Common.Indexed,-    module Parsley.Internal.Common.Queue,-    module Parsley.Internal.Common.Utils,-    module Parsley.Internal.Common.Vec-  ) where--import Parsley.Internal.Common.Fresh-import Parsley.Internal.Common.Indexed-import Parsley.Internal.Common.Queue-import Parsley.Internal.Common.Utils-import Parsley.Internal.Common.Vec

@@ -1,124 +0,0 @@-{-# LANGUAGE FunctionalDependencies,-             GeneralisedNewtypeDeriving,-             DerivingStrategies,-             UndecidableInstances #-}-module Parsley.Internal.Common.Fresh (-    VFreshT, HFreshT, VFresh, HFresh,-    runFreshT, runFresh,-    evalFreshT, evalFresh,-    execFreshT, execFresh,-    MonadFresh(..), construct, mapVFreshT,-    RunFreshT-  ) where--import Control.Applicative        (liftA2)-import Control.Monad.Fix          (MonadFix(..))-import Control.Monad.Identity     (Identity, runIdentity)-import Control.Monad.Reader.Class (MonadReader(..))-import Control.Monad.State.Class  (MonadState(..))-import Control.Monad.Trans        (MonadTrans(..), MonadIO(..))---- Fresh operations-class Monad m => MonadFresh x m | m -> x where-  newVar :: m x-  newScope :: m a -> m a--construct :: MonadFresh x m => (x -> a) -> m a-construct f = fmap f newVar--mapVFreshT :: (m (a, x, x) -> n (b, x, x)) -> VFreshT x m a -> VFreshT x n b-mapVFreshT f m = vFreshT (\cur max -> f (unVFreshT m cur max))--class (Monad n, Monad m) => RunFreshT x n m | m -> x, m -> n where-  runFreshT :: m a -> x -> n (a, x)--evalFreshT :: RunFreshT x n m => m a -> x -> n a-evalFreshT m init = fst <$> runFreshT m init--execFreshT :: RunFreshT x n m => m a -> x -> n x-execFreshT m init = snd <$> runFreshT m init---- Fresh type-type HFresh x = HFreshT x Identity-type VFresh x = VFreshT x Identity--- TODO Nominals-newtype VFreshT x m a = VFreshT (FreshT x m a) deriving newtype (Functor, Applicative, Monad, MonadFix, MonadTrans, MonadIO, MonadReader r, MonadState s, RunFreshT x m)-newtype HFreshT x m a = HFreshT (FreshT x m a) deriving newtype (Functor, Applicative, Monad, MonadFix, MonadTrans, MonadIO, MonadReader r, MonadState s, RunFreshT x m)-newtype FreshT x m a = FreshT {unFreshT :: x -> x -> m (a, x, x)}--instance Monad n => RunFreshT x n (FreshT x n) where-  runFreshT k init =-    do (x, _, max) <- unFreshT k init init-       return $! (x, max)--runFresh :: RunFreshT x Identity m => m a -> x -> (a, x)-runFresh mx = runIdentity . runFreshT mx--evalFresh :: RunFreshT x Identity m => m a -> x -> a-evalFresh mx = runIdentity . evalFreshT mx--execFresh :: RunFreshT x Identity m => m a -> x -> x-execFresh mx = runIdentity . execFreshT mx--vFreshT :: (x -> x -> m (a, x, x)) -> VFreshT x m a-vFreshT = VFreshT . FreshT--unVFreshT :: VFreshT x m a -> x -> x -> m (a, x, x)-unVFreshT (VFreshT f) = unFreshT f--hFreshT :: (x -> x -> m (a, x, x)) -> HFreshT x m a-hFreshT = HFreshT . FreshT--unHFreshT :: HFreshT x m a -> x -> x -> m (a, x, x)-unHFreshT (HFreshT f) = unFreshT f--instance Functor f => Functor (FreshT x f) where-  {-# INLINE fmap #-}-  fmap f (FreshT k) = FreshT (\cur max -> fmap (\(x, cur', max') -> (f x, cur', max')) (k cur max))--instance Monad m => Applicative (FreshT x m) where-  {-# INLINE pure #-}-  pure x = FreshT (\cur max -> pure (x, cur, max))-  {-# INLINE liftA2 #-}-  liftA2 f (FreshT mx) (FreshT my) = FreshT (\cur max ->-    do (x, cur', max') <- mx cur max-       (y, cur'', max'') <- my cur' max'-       return $! (f x y, cur'', max''))--instance Monad m => Monad (FreshT x m) where-  {-# INLINE return #-}-  return = pure-  {-# INLINE (>>=) #-}-  (FreshT mx) >>= f = FreshT (\cur max ->-    do (x, cur', max') <- mx cur max-       unFreshT (f x) cur' max')--instance MonadFix m => MonadFix (FreshT x m) where-  {-# INLINE mfix #-}-  mfix f = FreshT (\cur max -> mfix (\ ~(x, _, _) -> unFreshT (f x) cur max))--instance MonadTrans (FreshT x) where-  {-# INLINE lift #-}-  lift m = FreshT (\cur max ->-    do x <- m-       return (x, cur, max))--instance (Monad m, Ord x, Enum x) => MonadFresh x (VFreshT x m) where-  newVar = vFreshT (\cur m -> return (cur, cur, max m cur))-  newScope scoped = vFreshT (\cur max ->-    do (x, _, max') <- unVFreshT scoped (succ cur) max-       return $! (x, cur, max'))--instance (Monad m, Ord x, Enum x) => MonadFresh x (HFreshT x m) where-  newVar = hFreshT (\cur m -> return (cur, succ cur, max m cur))-  newScope scoped = hFreshT (\cur max ->-    do (x, _, max') <- unHFreshT scoped cur max-       return $! (x, cur, max'))--instance MonadIO m => MonadIO (FreshT x m) where liftIO = lift . liftIO-instance MonadReader r m => MonadReader r (FreshT x m) where-  ask = lift ask-  local f m = FreshT (\cur next -> local f (unFreshT m cur next))-instance MonadState s m => MonadState s (FreshT x m) where-  get = lift get-  put = lift . put

@@ -1,98 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-module Parsley.Internal.Common.Indexed (module Parsley.Internal.Common.Indexed) where--import Control.Applicative ((<|>), liftA2)-import Data.Kind           (Type)-import Data.Maybe          (fromMaybe)--data Nat = Zero | Succ Nat-type One = Succ Zero--class IFunctor (f :: (Type -> Type) -> Type -> Type) where-  imap :: (forall j. a j -> b j) -> f a i -> f b i--class IFunctor4 (f :: ([Type] -> Nat -> Type -> Type -> Type) -> [Type] -> Nat -> Type -> Type -> Type) where-  imap4 :: (forall i' j' k'. a i' j' k' x -> b i' j' k' x) -> f a i j k x -> f b i j k x--newtype Fix f a = In (f (Fix f) a)-newtype Fix4 f i j k l = In4 (f (Fix4 f) i j k l)--inop :: Fix f a -> f (Fix f) a-inop (In x) = x--inop4 :: Fix4 f i j k l -> f (Fix4 f) i j k l-inop4 (In4 x) = x--cata :: forall f a i. IFunctor f => (forall j. f a j -> a j) -> Fix f i -> a i-cata alg = go where-  go :: Fix f j -> a j-  go (In x) = alg (imap go x)--cata' :: forall f a i. IFunctor f =>-         (forall j. Fix f j -> f a j -> a j) ->-         Fix f i -> a i-cata' alg = go where-  go :: Fix f j -> a j-  go i@(In x) = alg i (imap go x)--cata4 :: forall f a i j k x. IFunctor4 f =>-         (forall i' j' k'. f a i' j' k' x -> a i' j' k' x) ->-         Fix4 f i j k x -> a i j k x-cata4 alg = go where-  go :: Fix4 f i' j' k' x -> a i' j' k' x-  go (In4 x) = alg (imap4 go x)--data (f :+: g) k a where-  L :: f k a -> (f :+: g) k a-  R :: g k a -> (f :+: g) k a--instance (IFunctor f, IFunctor g) => IFunctor (f :+: g) where-  imap f (L x) = L (imap f x)-  imap f (R y) = R (imap f y)--(\/) :: (f a i -> b) -> (g a i -> b) -> (f :+: g) a i -> b-(f \/ _) (L x) = f x-(_ \/ g) (R y) = g y--data Cofree f a i = a i :< f (Cofree f a) i-{-# INLINE extract #-}-extract :: Cofree f a i -> a i-extract (x :< _) = x--instance IFunctor f => IFunctor (Cofree f) where-  imap f (x :< xs) = f x :< imap (imap f) xs--histo :: IFunctor f => (forall j. f (Cofree f a) j -> a j) -> Fix f i -> a i-histo alg = extract . cata (alg >>= (:<))--data (f :*: g) i = f i :*: g i--{-# INLINE (/\) #-}-(/\) :: (a -> f i) -> (a -> g i) -> (a -> (f :*: g) i)-(f /\ g) x = f x :*: g x--{-# INLINE ifst #-}-ifst :: (f :*: g) i -> f i-ifst (x :*: _) = x-{-# INLINE isnd #-}-isnd :: (f :*: g) i -> g i-isnd (_ :*: y) = y--mutu :: IFunctor f => (forall j. f (a :*: b) j -> a j) -> (forall j. f (a :*: b) j -> b j) -> Fix f i -> (a :*: b) i-mutu algl algr = cata (algl /\ algr)--zygo :: IFunctor f => (forall j. f (a :*: b) j -> a j) -> (forall j. f b j -> b j) -> Fix f i -> a i-zygo alg aux = ifst . mutu alg (aux . imap isnd)--zipper :: IFunctor f => (forall j. f a j -> a j) -> (forall j. f b j -> b j) -> Fix f i -> (a :*: b) i-zipper algl algr = mutu (algl . imap ifst) (algr . imap isnd)--class                         Chain r k         where (|>) :: (a -> Maybe r) -> (a -> k) -> a -> k-instance {-# OVERLAPPABLE #-} Chain a a         where (|>) = liftA2 (flip fromMaybe)-instance {-# OVERLAPS #-}     Chain a (Maybe a) where (|>) = liftA2 (<|>)--data Unit1 k = Unit-newtype Const1 a k = Const1 {getConst1 :: a}--data Unit4 i j k l = Unit4-newtype Const4 a i j k l = Const4 {getConst4 :: a}

@@ -1,41 +0,0 @@-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# LANGUAGE ViewPatterns,-             DerivingStrategies #-}-module Parsley.Internal.Common.Queue (Queue, empty, enqueue, dequeue, null, size, foldr) where--import Prelude hiding (null, foldr)--import qualified Prelude (foldr)--data Queue a = Queue {-  outsz :: Int,-  outs  :: [a],-  insz  :: Int,-  ins   :: [a]-} deriving stock Eq--empty :: Queue a-empty = Queue 0 [] 0 []--enqueue :: a -> Queue a -> Queue a-enqueue x q = q {insz = insz q + 1, ins = x : ins q}--dequeue :: Queue a -> (a, Queue a)-dequeue q@(outs -> (x:outs')) = (x, q {outsz = outsz q - 1, outs = outs'})-dequeue q@(outs -> [])        = dequeue (Queue (insz q) (reverse (ins q)) 0 [])--null :: Queue a -> Bool-null (Queue 0 [] 0 []) = True-null _ = False--size :: Queue a -> Int-size q = insz q + outsz q--toList :: Queue a -> [a]-toList q = outs q ++ reverse (ins q)--foldr :: (a -> b -> b) -> b -> Queue a -> b-foldr f k = Prelude.foldr f k . toList--instance Show a => Show (Queue a) where-  show = show . toList

@@ -1,87 +0,0 @@-{-# LANGUAGE DeriveFunctor,-             MultiParamTypeClasses,-             DerivingStrategies,-             CPP #-}-module Parsley.Internal.Common.State (-    State, StateT,-    runState, evalState, execState,-    runStateT, evalStateT, execStateT,-    module Control.Monad.State.Class-  ) where--import Control.Applicative       (liftA2, Alternative(..))-#if __GLASGOW_HASKELL__ < 808-import Control.Monad.Fail        (MonadFail(..))-#endif-import Control.Monad.Fix         (MonadFix(..))-import Control.Monad.Identity    (Identity, runIdentity)-import Control.Monad.State.Class-import Control.Monad.Trans       (MonadTrans(..), MonadIO(..))--#if __GLASGOW_HASKELL__ < 808-import qualified Control.Monad.Fail as Fail (MonadFail(fail))-#endif--type State s = StateT s Identity-{-# INLINE runState #-}-runState :: State s a -> s -> (a, s)-runState mx = runIdentity . runStateT mx--{-# INLINE evalState #-}-evalState :: State s a -> s -> a-evalState mx = runIdentity . evalStateT mx--{-# INLINE execState #-}-execState :: State s a -> s -> s-execState mx = runIdentity . execStateT mx--newtype StateT s m a = StateT {unStateT :: forall r. s -> (a -> s -> m r) -> m r} deriving stock Functor--{-# INLINE runStateT #-}-runStateT :: Monad m => StateT s m a -> s -> m (a, s)-runStateT (StateT f) s = f s (curry return)--{-# INLINE evalStateT #-}-evalStateT :: Monad m => StateT s m a -> s -> m a-evalStateT (StateT f) s = f s (const . return)--{-# INLINE execStateT #-}-execStateT :: Monad m => StateT s m a -> s -> m s-execStateT (StateT f) s = f s (const return)--instance Applicative (StateT s m) where-  {-# INLINE pure #-}-  pure x = StateT (flip ($ x))-  {-# INLINE liftA2 #-}-  liftA2 f (StateT mx) (StateT my) = StateT (\s k -> mx s (\x s' -> my s' (\y s'' -> k (f x y) s'')))--instance Monad (StateT s m) where-  {-# INLINE return #-}-  return = pure-  {-# INLINE (>>=) #-}-  StateT mx >>= f = StateT (\s k -> mx s (\x s' -> unStateT (f x) s' k))--instance MonadFix m => MonadFix (StateT s m) where-  {-# INLINE mfix #-}-  mfix f = StateT (\s k -> mfix (\ ~(x, _) -> runStateT (f x) s) >>= uncurry k)--instance MonadTrans (StateT s) where-  {-# INLINE lift #-}-  lift m = StateT (\s k -> m >>= (`k` s))--instance MonadIO m => MonadIO (StateT s m) where liftIO = lift . liftIO--instance MonadFail m => MonadFail (StateT s m) where-#if __GLASGOW_HASKELL__ < 808-  fail msg = StateT (\_ _ -> Fail.fail msg)-#else-  fail msg = StateT (\_ _ -> fail msg)-#endif--instance Alternative m => Alternative (StateT s m) where-  empty = StateT (\_ _ -> empty)-  StateT mx <|> StateT my = StateT (\s k -> mx s k <|> my s k)--instance MonadState s (StateT s m) where-  get = StateT (\s k -> k s s)-  put s = StateT (\_ k -> k () s)

@@ -1,116 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}-{-# LANGUAGE UndecidableInstances,-             CPP #-}-#if __GLASGOW_HASKELL__ >= 810-{-# LANGUAGE StandaloneKindSignatures #-}-#endif-module Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..), intercalate, intercalateDiff) where--import Data.List (intersperse)-import Data.String (IsString(..))--#if __GLASGOW_HASKELL__ >= 810-import Data.Kind    (Type)-import GHC.Exts    (TYPE, RuntimeRep)-#endif--#if __GLASGOW_HASKELL__ < 900-import Language.Haskell.TH (TExp, Q)-#else-import qualified Language.Haskell.TH as TH (Code, Q)-#endif--{-|-A type alias for typed template haskell code, which represents the Haskell AST for a given value.--@since 0.1.0.0--}-#if __GLASGOW_HASKELL__ >= 810-type Code :: forall (r :: RuntimeRep). TYPE r -> Type-#endif-#if __GLASGOW_HASKELL__ < 900-type Code a = Q (TExp a)-#else-type Code a = TH.Code TH.Q a-#endif--{-|-Pronounced \"with code\", this datatype is the representation for user-land values. It pairs-a value up with its representation as Haskell @Code@. It should be manipulated using-`Quapplicative`.--@since 0.1.0.0--}-data WQ a = WQ { __val :: a, __code :: Code a }--{-|-This class is used to manipulate the representations of both user-land values and defunctionalised-representations. It can be used to construct these values as well as extract their underlying value-and code representation on demand.--It is named after the @Applicative@ class, with the @Q@ standing for \"code\". The @(`>*<`)@ operator-is analogous to @(\<*>)@ and `makeQ` analogous to @pure@.--@since 0.1.0.0--}-class Quapplicative q where-  {-|-  Combines a value with its representation to build one of the representation types.--  @since 0.1.0.0-  -}-  makeQ :: a -> Code a -> q a--  {-|-  Extracts the regular value out of the representation.--  @since 0.1.0.0-  -}-  _val :: q a -> a--  {-|-  Extracts the representation of the value as code.--  @since 0.1.0.0-  -}-  _code :: q a -> Code a--  {-|-  Pronounced \"quapp\", this can be used to combine the code of a function with the code of a value.--  > const5 = makeQ const [||const||] >*< makeQ 5 [||5||]--  is the same as saying--  > const5 = makeQ (const 5) [||const 5||]--  It is more idiomatically found as the output to the @IdiomsPlugin@.--  @since 0.1.0.0-  -}-  (>*<) :: q (a -> b) -> q a -> q b-  f >*< x = makeQ ((_val f) (_val x)) [||$$(_code f) $$(_code x)||]-infixl 9 >*<--{-|-This instance is used to manipulate values of `WQ`.--@since 0.1.0.0--}-instance Quapplicative WQ where-  makeQ = WQ-  _code = __code-  _val = __val--intercalate :: Monoid w => w -> [w] -> w-intercalate xs xss = mconcat (intersperse xs xss)--instance IsString (String -> String) where-  fromString = showString--newtype Id a = Id {unId :: a -> a}-instance Semigroup (Id a) where f <> g = Id $ unId f . unId g-instance Monoid (Id a) where mempty = Id $ id--intercalateDiff :: (a -> a) -> [(a -> a)] -> a -> a-intercalateDiff sep xs = unId $ intercalate (Id sep) (map Id xs)

@@ -1,23 +0,0 @@-module Parsley.Internal.Common.Vec (module Parsley.Internal.Common.Vec, Nat(..)) where--import Parsley.Internal.Common.Indexed (Nat(..))--data Vec n a where-  VNil :: Vec Zero a-  VCons :: a -> Vec n a -> Vec (Succ n) a--replicateVec :: SNat n -> a -> Vec n a-replicateVec SZero _     = VNil-replicateVec (SSucc n) x = VCons x (replicateVec n x)--zipWithVec :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c-zipWithVec _ VNil         VNil         = VNil-zipWithVec f (VCons x xs) (VCons y ys) = VCons (f x y) (zipWithVec f xs ys)--data SNat (n :: Nat) where-  SZero :: SNat Zero-  SSucc :: SNat n -> SNat (Succ n)--class SingNat (n :: Nat) where sing :: SNat n-instance SingNat Zero where sing = SZero-instance SingNat n => SingNat (Succ n) where sing = SSucc sing

@@ -1,19 +0,0 @@-{-|-Module      : Parsley.Internal.Core-Description : The main AST and datatypes are found here-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : unstable--@since 0.1.0.0--}-module Parsley.Internal.Core (-    Parser,-    ParserOps,-    module Parsley.Internal.Core.Defunc,-    module Parsley.Internal.Core.InputTypes-  ) where--import Parsley.Internal.Core.Defunc hiding (genDefunc, genDefunc1, genDefunc2, ap)-import Parsley.Internal.Core.InputTypes-import Parsley.Internal.Core.Primitives (Parser, ParserOps)

@@ -1,132 +0,0 @@-{-# LANGUAGE ApplicativeDo,-             OverloadedStrings #-}-module Parsley.Internal.Core.CombinatorAST (module Parsley.Internal.Core.CombinatorAST) where--import Data.Kind                         (Type)-import Parsley.Internal.Common           (IFunctor(..), Fix, Const1(..), cata, intercalateDiff, (:+:))-import Parsley.Internal.Core.Identifiers (MVar, ΣVar)-import Parsley.Internal.Core.Defunc      (Defunc)--{-|-The opaque datatype that represents parsers.--@since 0.1.0.0--}-newtype Parser a = Parser {unParser :: Fix (Combinator :+: ScopeRegister) a}---- Core datatype-data Combinator (k :: Type -> Type) (a :: Type) where-  Pure           :: Defunc a -> Combinator k a-  Satisfy        :: Defunc (Char -> Bool) -> Combinator k Char-  (:<*>:)        :: k (a -> b) -> k a -> Combinator k b-  (:*>:)         :: k a -> k b -> Combinator k b-  (:<*:)         :: k a -> k b -> Combinator k a-  (:<|>:)        :: k a -> k a -> Combinator k a-  Empty          :: Combinator k a-  Try            :: k a -> Combinator k a-  LookAhead      :: k a -> Combinator k a-  Let            :: Bool -> MVar a -> k a -> Combinator k a-  NotFollowedBy  :: k a -> Combinator k ()-  Branch         :: k (Either a b) -> k (a -> c) -> k (b -> c) -> Combinator k c-  Match          :: k a -> [Defunc (a -> Bool)] -> [k b] -> k b -> Combinator k b-  ChainPre       :: k (a -> a) -> k a -> Combinator k a-  ChainPost      :: k a -> k (a -> a) -> Combinator k a-  MakeRegister   :: ΣVar a -> k a -> k b -> Combinator k b-  GetRegister    :: ΣVar a -> Combinator k a-  PutRegister    :: ΣVar a -> k a -> Combinator k ()-  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--{-|-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.-It is the abstracted representation of a runtime storage location.--@since 0.1.0.0--}-newtype Reg (r :: Type) a = Reg (ΣVar a)--data MetaCombinator where-  Cut         :: MetaCombinator-  RequiresCut :: MetaCombinator---- Instances-instance IFunctor Combinator where-  imap _ (Pure x)             = Pure x-  imap _ (Satisfy p)          = Satisfy p-  imap f (p :<*>: q)          = f p :<*>: f q-  imap f (p :*>: q)           = f p :*>: f q-  imap f (p :<*: q)           = f p :<*: f q-  imap f (p :<|>: q)          = f p :<|>: f q-  imap _ Empty                = Empty-  imap f (Try p)              = Try (f p)-  imap f (LookAhead p)        = LookAhead (f p)-  imap f (Let r v p)          = Let r v (f p)-  imap f (NotFollowedBy p)    = NotFollowedBy (f p)-  imap f (Branch b p q)       = Branch (f b) (f p) (f q)-  imap f (Match p fs qs d)    = Match (f p) fs (map f qs) (f d)-  imap f (ChainPre op p)      = ChainPre (f op) (f p)-  imap f (ChainPost p op)     = ChainPost (f p) (f op)-  imap f (MakeRegister σ p q) = MakeRegister σ (f p) (f q)-  imap _ (GetRegister σ)      = GetRegister σ-  imap f (PutRegister σ p)    = PutRegister σ (f p)-  imap f (Debug name p)       = Debug name (f p)-  imap f (MetaCombinator m p) = MetaCombinator m (f p)--instance Show (Fix Combinator a) where-  show = ($ "") . getConst1 . cata (Const1 . alg)-    where-      alg (Pure x)                                  = "(pure " . shows x . ")"-      alg (Satisfy f)                               = "(satisfy " . shows f . ")"-      alg (Const1 pf :<*>: Const1 px)               = "(" . pf . " <*> " .  px . ")"-      alg (Const1 p :*>: Const1 q)                  = "(" . p . " *> " . q . ")"-      alg (Const1 p :<*: Const1 q)                  = "(" . p . " <* " . q . ")"-      alg (Const1 p :<|>: Const1 q)                 = "(" . p . " <|> " . q . ")"-      alg Empty                                     = "empty"-      alg (Try (Const1 p))                          = "(try " . p . ")"-      alg (LookAhead (Const1 p))                    = "(lookAhead " . p . ")"-      alg (Let False v _)                           = "(let-bound " . shows v . ")"-      alg (Let True v _)                            = "(rec " . shows v . ")"-      alg (NotFollowedBy (Const1 p))                = "(notFollowedBy " . p . ")"-      alg (Branch (Const1 b) (Const1 p) (Const1 q)) = "(branch " . b . " " . p . " " . q . ")"-      alg (Match (Const1 p) fs qs (Const1 def))     = "(match " . p . " " . shows fs . " [" . intercalateDiff ", " (map getConst1 qs) . "] "  . def . ")"-      alg (ChainPre (Const1 op) (Const1 p))         = "(chainPre " . op . " " . p . ")"-      alg (ChainPost (Const1 p) (Const1 op))        = "(chainPost " . p . " " . op . ")"-      alg (MakeRegister σ (Const1 p) (Const1 q))    = "(make " . shows σ . " " . p . " " . q . ")"-      alg (GetRegister σ)                           = "(get " . shows σ . ")"-      alg (PutRegister σ (Const1 p))                = "(put " . shows σ . " " . p . ")"-      alg (Debug _ (Const1 p))                      = p-      alg (MetaCombinator m (Const1 p))             = p . " [" . shows m . "]"--instance IFunctor ScopeRegister where-  imap f (ScopeRegister p g) = ScopeRegister (f p) (f . g)--instance Show MetaCombinator where-  show Cut = "coins after"-  show RequiresCut = "requires cut"--{-# INLINE traverseCombinator #-}-traverseCombinator :: Applicative m => (forall a. f a -> m (k a)) -> Combinator f a -> m (Combinator k a)-traverseCombinator expose (pf :<*>: px)        = do pf' <- expose pf; px' <- expose px; pure (pf' :<*>: px')-traverseCombinator expose (p :*>: q)           = do p' <- expose p; q' <- expose q; pure (p' :*>: q')-traverseCombinator expose (p :<*: q)           = do p' <- expose p; q' <- expose q; pure (p' :<*: q')-traverseCombinator expose (p :<|>: q)          = do p' <- expose p; q' <- expose q; pure (p' :<|>: q')-traverseCombinator _      Empty                = do pure Empty-traverseCombinator expose (Try p)              = do p' <- expose p; pure (Try p')-traverseCombinator expose (LookAhead p)        = do p' <- expose p; pure (LookAhead p')-traverseCombinator expose (NotFollowedBy p)    = do p' <- expose p; pure (NotFollowedBy p')-traverseCombinator expose (Branch b p q)       = do b' <- expose b; p' <- expose p; q' <- expose q; pure (Branch b' p' q')-traverseCombinator expose (Match p fs qs d)    = do p' <- expose p; qs' <- traverse expose qs; d' <- expose d; pure (Match p' fs qs' d')-traverseCombinator expose (ChainPre op p)      = do op' <- expose op; p' <- expose p; pure (ChainPre op' p')-traverseCombinator expose (ChainPost p op)     = do p' <- expose p; op' <- expose op; pure (ChainPost p' op')-traverseCombinator expose (MakeRegister σ p q) = do p' <- expose p; q' <- expose q; pure (MakeRegister σ p' q')-traverseCombinator _      (GetRegister σ)      = do pure (GetRegister σ)-traverseCombinator expose (PutRegister σ p)    = do p' <- expose p; pure (PutRegister σ p')-traverseCombinator expose (Debug name p)       = do p' <- expose p; pure (Debug name p')-traverseCombinator _      (Pure x)             = do pure (Pure x)-traverseCombinator _      (Satisfy f)          = do pure (Satisfy f)-traverseCombinator expose (Let r v p)          = do p' <- expose p; pure (Let r v p')-traverseCombinator expose (MetaCombinator m p) = do p' <- expose p; pure (MetaCombinator m p')

@@ -1,175 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-module Parsley.Internal.Core.Defunc (module Parsley.Internal.Core.Defunc) where--import Language.Haskell.TH.Syntax (Lift(..))-import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))--{-|-This datatype is useful for providing an /inspectable/ representation of common Haskell functions.-These can be provided in place of `WQ` to any combinator that requires it. The only difference is-that the Parsley compiler is able to manipulate and match on the constructors, which might lead to-optimisations. They can also be more convenient than constructing the `WQ` object itself:--> ID ~= WQ id [||id||]-> APP_H f x ~= WQ (f x) [||f x||]--@since 0.1.0.0--}-data Defunc a where-  -- | Corresponds to the standard @id@ function-  ID      :: Defunc (a -> a)-  -- | Corresponds to the standard @(.)@ function applied to no arguments-  COMPOSE :: Defunc ((b -> c) -> (a -> b) -> (a -> c))-  -- | Corresponds to the standard @flip@ function applied to no arguments-  FLIP    :: Defunc ((a -> b -> c) -> b -> a -> c)-  -- | Corresponds to function application of two other `Defunc` values-  APP_H   :: Defunc (a -> b) -> Defunc a -> Defunc b-  -- | Corresponds to the partially applied @(== x)@ for some `Defunc` value @x@-  EQ_H    :: Eq a => Defunc a -> Defunc (a -> Bool)-  -- | Represents a liftable, showable value-  LIFTED  :: (Show a, Lift a) => a -> Defunc a-  -- | Represents the standard @(:)@ function applied to no arguments-  CONS    :: Defunc (a -> [a] -> [a])-  -- | Represents the standard @const@ function applied to no arguments-  CONST   :: Defunc (a -> b -> a)-  -- | Represents the empty list @[]@-  EMPTY   :: Defunc [a]-  -- | Wraps up any value of type `WQ`-  BLACK   :: WQ a -> Defunc a--  -- Syntax constructors-  {-|-  Represents the regular Haskell @if@ syntax--  @since 0.1.1.0-  -}-  IF_S    :: Defunc Bool -> Defunc a -> Defunc a -> Defunc a-  {-|-  Represents a Haskell lambda abstraction--  @since 0.1.1.0-  -}-  LAM_S   :: (Defunc a -> Defunc b) -> Defunc (a -> b)-  {-|-  Represents a Haskell let binding--  @since 0.1.1.0-  -}-  LET_S   :: Defunc a -> (Defunc a -> Defunc b) -> Defunc b--{-|-This instance is used to manipulate values of `Defunc`.--@since 0.1.0.0--}-instance Quapplicative Defunc where-  makeQ x qx        = BLACK (makeQ x qx)-  _val ID           = id-  _val COMPOSE      = (.)-  _val FLIP         = flip-  _val (APP_H f x)  = (_val f) (_val x)-  _val (LIFTED x)   = x-  _val (EQ_H x)     = ((_val x) ==)-  _val CONS         = (:)-  _val CONST        = const-  _val EMPTY        = []-  _val (BLACK f)    = _val f-  -- Syntax-  _val (IF_S c t e) = if _val c then _val t else _val e-  _val (LAM_S f)    = \x -> _val (f (makeQ x undefined))-  _val (LET_S x f)  = let y = _val x in _val (f (makeQ y undefined))-  _code = genDefunc-  (>*<) = APP_H--{-|-This pattern represents fully applied composition of two `Defunc` values--@since 0.1.0.0--}-pattern COMPOSE_H     :: () => ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) => Defunc x -> Defunc y -> Defunc z-pattern COMPOSE_H f g = APP_H (APP_H COMPOSE f) g-{-|-This pattern corresponds to the standard @flip@ function applied to a single argument--@since 0.1.0.0--}-pattern FLIP_H        :: () => ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) => Defunc x -> Defunc y-pattern FLIP_H f      = APP_H FLIP f-{-|-Represents the flipped standard @const@ function applied to no arguments--@since 0.1.0.0--}-pattern FLIP_CONST    :: () => (x ~ (a -> b -> b)) => Defunc x-pattern FLIP_CONST    = FLIP_H CONST-{-|-This pattern represents the unit value @()@--@since 0.1.0.0--}-pattern UNIT          :: Defunc ()-pattern UNIT          = LIFTED ()--ap :: Defunc (a -> b) -> Defunc a -> Defunc b-ap f x = APP_H f x--genDefunc :: Defunc a -> Code a-genDefunc ID                        = [|| \x -> x ||]-genDefunc COMPOSE                   = [|| \f g x -> f (g x) ||]-genDefunc FLIP                      = [|| \f x y -> f y x ||]-genDefunc (COMPOSE_H f g)           = [|| \x -> $$(genDefunc1 (COMPOSE_H f g) [||x||]) ||]-genDefunc CONST                     = [|| \x _ -> x ||]-genDefunc FLIP_CONST                = [|| \_ y -> y ||]-genDefunc (FLIP_H f)                = [|| \x -> $$(genDefunc1 (FLIP_H f) [||x||]) ||]-genDefunc (APP_H f x)               = genDefunc1 f (genDefunc x)-genDefunc (LIFTED x)                = [|| x ||]-genDefunc (EQ_H x)                  = [|| \y -> $$(genDefunc1 (EQ_H x) [||y||]) ||]-genDefunc CONS                      = [|| \x xs -> x : xs ||]-genDefunc EMPTY                     = [|| [] ||]-genDefunc (IF_S (LIFTED True) t _)  = genDefunc t-genDefunc (IF_S (LIFTED False) _ e) = genDefunc e-genDefunc (IF_S c t e)              = [|| if $$(genDefunc c) then $$(genDefunc t) else $$(genDefunc e) ||]-genDefunc (LAM_S f)                 = [|| \x -> $$(genDefunc1 (LAM_S f) [||x||]) ||]-genDefunc (LET_S x f)               = [|| let y = $$(genDefunc x) in $$(genDefunc (f (makeQ undefined [||y||]))) ||]-genDefunc (BLACK f)                 = _code f--genDefunc1 :: Defunc (a -> b) -> Code a -> Code b-genDefunc1 ID              qx = qx-genDefunc1 COMPOSE         qf = [|| \g x -> $$qf (g x) ||]-genDefunc1 FLIP            qf = [|| \x y -> $$qf y x ||]-genDefunc1 (COMPOSE_H f g) qx = genDefunc1 f (genDefunc1 g qx)-genDefunc1 (APP_H ID f)    qx = genDefunc1 f qx-genDefunc1 (APP_H f x)     qy = genDefunc2 f (genDefunc x) qy-genDefunc1 CONST           qx = [|| \_ -> $$qx ||]-genDefunc1 FLIP_CONST      _  = genDefunc ID-genDefunc1 (FLIP_H f)      qx = [|| \y -> $$(genDefunc2 (FLIP_H f) qx [||y||]) ||]-genDefunc1 (EQ_H x)        qy = [|| $$(genDefunc x)  == $$qy ||]-genDefunc1 (LAM_S f)       qx = genDefunc (f (makeQ undefined qx))-genDefunc1 f               qx = [|| $$(genDefunc f) $$qx ||]--genDefunc2 :: Defunc (a -> b -> c) -> Code a -> Code b -> Code c-genDefunc2 ID              qf qx  = [|| $$qf $$qx ||]-genDefunc2 COMPOSE         qf qg  = [|| \x -> $$qf ($$qg x) ||]-genDefunc2 FLIP            qf qx  = [|| \y -> $$qf y $$qx ||]-genDefunc2 (COMPOSE_H f g) qx qy  = genDefunc2 f (genDefunc1 g qx) qy-genDefunc2 CONST           qx _   = qx-genDefunc2 FLIP_CONST      _  qy  = qy-genDefunc2 (FLIP_H f)      qx qy  = genDefunc2 f qy qx-genDefunc2 CONS            qx qxs = [|| $$qx : $$qxs ||]-genDefunc2 f               qx qy  = [|| $$(genDefunc1 f qx) $$qy ||]--instance Show (Defunc a) where-  show COMPOSE = "(.)"-  show FLIP = "flip"-  show (FLIP_H f) = concat ["(flip ", show f, ")"]-  show (COMPOSE_H f g) = concat ["(", show f, " . ", show g, ")"]-  show (APP_H f x) = concat ["(", show f, " ", show x, ")"]-  show (LIFTED x) = show x-  show (EQ_H x) = concat ["(== ", show x, ")"]-  show ID  = "id"-  show EMPTY = "[]"-  show CONS = "(:)"-  show CONST = "const"-  show (IF_S c b e) = concat ["(if ", show c, " then ", show b, " else ", show e, ")"]-  show (LAM_S _) = "f"-  show _ = "x"

@@ -1,44 +0,0 @@-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# LANGUAGE DerivingStrategies,-             GeneralizedNewtypeDeriving #-}-module Parsley.Internal.Core.Identifiers (-    MVar(..), IMVar,-    ΣVar(..), IΣVar,-  ) where--import Data.Array        (Ix)-import Data.GADT.Compare (GEq, GCompare, gcompare, geq, GOrdering(..))-import Data.Kind         (Type)-import Data.Typeable     ((:~:)(Refl))-import Data.Word         (Word64)-import Unsafe.Coerce     (unsafeCoerce)--newtype ΣVar (a :: Type) = ΣVar IΣVar-newtype MVar (a :: Type) = MVar IMVar-newtype IMVar = IMVar Word64 deriving newtype (Ord, Eq, Num, Enum, Show, Ix)-newtype IΣVar = IΣVar Word64 deriving newtype (Ord, Eq, Num, Enum, Show, Ix)--instance Show (MVar a) where show (MVar μ) = "μ" ++ show μ-instance Show (ΣVar a) where show (ΣVar σ) = "σ" ++ show σ--instance GEq ΣVar where-  geq (ΣVar u) (ΣVar v)-    | u == v    = Just (unsafeCoerce Refl)-    | otherwise = Nothing--instance GCompare ΣVar where-  gcompare σ1@(ΣVar u) σ2@(ΣVar v) = case compare u v of-    LT -> GLT-    EQ -> case geq σ1 σ2 of Just Refl -> GEQ-    GT -> GGT--instance GEq MVar where-  geq (MVar u) (MVar v)-    | u == v    = Just (unsafeCoerce Refl)-    | otherwise = Nothing--instance GCompare MVar where-  gcompare μ1@(MVar u) μ2@(MVar v) = case compare u v of-    LT -> GLT-    EQ -> case geq μ1 μ2 of Just Refl -> GEQ-    GT -> GGT

@@ -1,38 +0,0 @@-module Parsley.Internal.Core.InputTypes (module Parsley.Internal.Core.InputTypes) where--import Data.Text (Text)--{-|-By wrapping a regular @Text@ input with this newtype, Parsley will assume that all-of the characters fit into exactly one 16-bit chunk. This allows the consumption of-characters in the datatype to be consumed much faster, but does not support multi-word-characters. --@since 0.1.0.0--}-newtype Text16 = Text16 Text----newtype CacheText = CacheText Text--{-|-By wrapping a regular @String@ with this newtype, Parsley will not preprocess it into-an array of characters, instead using regular pattern matching for the implementation.--@since 0.1.0.0--}-newtype CharList = CharList String--{-|-An input type that represents an infinite stream of input characters.--@since 0.1.0.0--}-data Stream = {-# UNPACK #-} !Char :> Stream--{-|-The \"end\" of a stream, an infinite stream of \'\\0\' (null) characters--@since 0.1.0.0--}-nomore :: Stream-nomore = '\0' :> nomore

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

@@ -1,14 +0,0 @@-{-|-Module      : Parsley.Internal.Frontend-Description : The frontend is concerned with AST manipulation and processing-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : stable--@since 0.1.0.0--}-module Parsley.Internal.Frontend (-    module Parsley.Internal.Frontend.Compiler,-  ) where--import Parsley.Internal.Frontend.Compiler (compile)

@@ -1,241 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-module Parsley.Internal.Frontend.CombinatorAnalyser (analyse, compliance, Compliance(..), emptyFlags, AnalysisFlags(..)) where----import Control.Applicative                 (liftA2)---import Control.Monad.Reader                (ReaderT, ask, runReaderT, local)---import Control.Monad.State.Strict          (State, get, put, evalState)-import Data.Coerce                         (coerce)-import Data.Kind                           (Type)---import Data.Map.Strict                     (Map)---import Data.Set                            (Set)-import Parsley.Internal.Common.Indexed     (Fix(..){-, imap, cata-}, zygo, (:*:)(..), ifst)-import Parsley.Internal.Core.CombinatorAST (Combinator(..), MetaCombinator(..))---import Parsley.Internal.Core.Identifiers   (IMVar, MVar(..))----import qualified Data.Map.Strict as Map---import qualified Data.Set        as Set--newtype AnalysisFlags = AnalysisFlags {-  letBound :: Bool-}-emptyFlags :: AnalysisFlags-emptyFlags = AnalysisFlags False--analyse :: AnalysisFlags -> Fix Combinator a -> Fix Combinator a-analyse flags = cutAnalysis (letBound flags) {-. terminationAnalysis-}--data Compliance (k :: Type) = DomComp | NonComp | Comp | FullPure deriving stock (Show, Eq)--seqCompliance :: Compliance a -> Compliance b -> Compliance c-seqCompliance c FullPure = coerce c-seqCompliance FullPure c = coerce c-seqCompliance Comp _     = Comp-seqCompliance _ _        = NonComp--caseCompliance :: Compliance a -> Compliance b -> Compliance c-caseCompliance c FullPure              = coerce c-caseCompliance FullPure c              = coerce c-caseCompliance c1 c2 | c1 == coerce c2 = coerce c1-caseCompliance _ _                     = NonComp--{-# INLINE compliance #-}-compliance :: Combinator Compliance a -> Compliance a-compliance (Pure _)                 = FullPure-compliance (Satisfy _)              = NonComp-compliance Empty                    = FullPure-compliance Let{}                    = DomComp-compliance (Try _)                  = DomComp-compliance (NonComp :<|>: FullPure) = Comp-compliance (_ :<|>: _)              = NonComp-compliance (l :<*>: r)              = seqCompliance l r-compliance (l :<*: r)               = seqCompliance l r-compliance (l :*>: r)               = seqCompliance l r-compliance (LookAhead c)            = c -- Lookahead will consume input on failure, so its compliance matches that which is beneath it-compliance (NotFollowedBy _)        = FullPure-compliance (Debug _ c)              = c-compliance (ChainPre NonComp p)     = seqCompliance Comp p-compliance (ChainPre _ p)           = seqCompliance NonComp p-compliance (ChainPost p NonComp)    = seqCompliance p Comp-compliance (ChainPost p _)          = seqCompliance p NonComp-compliance (Branch b p q)           = seqCompliance b (caseCompliance p q)-compliance (Match p _ qs def)       = seqCompliance p (foldr1 caseCompliance (def:qs))-compliance (MakeRegister _ l r)     = seqCompliance l r-compliance (GetRegister _)          = FullPure-compliance (PutRegister _ c)        = coerce c-compliance (MetaCombinator _ c)     = c--newtype CutAnalysis a = CutAnalysis {doCut :: Bool -> (Fix Combinator a, Bool)}--biliftA2 :: (a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)-biliftA2 f g (x1, y1) (x2, y2) = (f x1 x2, g y1 y2)--cutAnalysis :: Bool -> Fix Combinator a -> Fix Combinator a-cutAnalysis letBound = fst . ($ letBound) . doCut . zygo (CutAnalysis . alg) compliance-  where-    mkCut True = In . MetaCombinator Cut-    mkCut False = id--    requiresCut = In . MetaCombinator RequiresCut--    seqAlg :: (Fix Combinator a -> Fix Combinator b -> Combinator (Fix Combinator) c) -> Bool -> CutAnalysis a -> CutAnalysis b -> (Fix Combinator c, Bool)-    seqAlg con cut l r =-      let (l', handled) = doCut l cut-          (r', handled') = doCut r (cut && not handled)-      in (In (con l' r'), handled || handled')--    rewrap :: (Fix Combinator a -> Combinator (Fix Combinator) b) -> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)-    rewrap con cut p = let (p', handled) = doCut p cut in (In (con p'), handled)--    alg :: Combinator (CutAnalysis :*: Compliance) a -> Bool -> (Fix Combinator a, Bool)-    alg (Pure x) _ = (In (Pure x), False)-    alg (Satisfy f) cut = (mkCut cut (In (Satisfy f)), True)-    alg Empty _ = (In Empty, False)-    alg (Let r μ p) cut = (mkCut (not cut) (In (Let r μ (fst (doCut (ifst p) True)))), False) -- If there is no cut, we generate a piggy for the continuation-    alg (Try p) _ = False <$ rewrap Try False (ifst p)-    alg ((p :*: NonComp) :<|>: (q :*: FullPure)) _ = (requiresCut (In (fst (doCut p True) :<|>: fst (doCut q False))), True)-    alg (p :<|>: q) cut =-      let (q', handled) = doCut (ifst q) cut-      in (In (fst (doCut (ifst p) False) :<|>: q'), handled)-    alg (l :<*>: r) cut = seqAlg (:<*>:) cut (ifst l) (ifst r)-    alg (l :<*: r) cut = seqAlg (:<*:) cut (ifst l) (ifst r)-    alg (l :*>: r) cut = seqAlg (:*>:) cut (ifst l) (ifst r)-    alg (LookAhead p) cut = rewrap LookAhead cut (ifst p)-    alg (NotFollowedBy p) _ = False <$ rewrap NotFollowedBy False (ifst p)-    alg (Debug msg p) cut = rewrap (Debug msg) cut (ifst p)-    alg (ChainPre (op :*: NonComp) p) _ =-      let (op', _) = doCut op True-          (p', _) = doCut (ifst p) False-      in (requiresCut (In (ChainPre op' p')), True)-    alg (ChainPre op p) cut =-      let (op', _) = doCut (ifst op) False-          (p', handled) = doCut (ifst p) cut-      in (mkCut (not cut) (In (ChainPre op' p')), handled)-    alg (ChainPost p (op :*: NonComp)) cut =-      let (p', _) = doCut (ifst p) cut-          (op', _) = doCut op True-      in (requiresCut (In (ChainPost p' op')), True)-    alg (ChainPost p op) cut =-      let (p', handled) = doCut (ifst p) cut-          (op', _) = doCut (ifst op) False-      in (mkCut (cut && handled) (In (ChainPost p' op')), handled)-    alg (Branch b p q) cut =-      let (b', handled) = doCut (ifst b) cut-          (p', handled') = doCut (ifst p) (cut && not handled)-          (q', handled'') = doCut (ifst q) (cut && not handled)-      in (In (Branch b' p' q'), handled || (handled' && handled''))-    alg (Match p f qs def) cut =-      let (p', handled) = doCut (ifst p) cut-          (def', handled') = doCut (ifst def) (cut && not handled)-          (qs', handled'') = foldr (\q -> biliftA2 (:) (&&) (doCut (ifst q) (cut && not handled))) ([], handled') qs-      in (In (Match p' f qs' def'), handled || handled'')-    alg (MakeRegister σ l r) cut = seqAlg (MakeRegister σ) cut (ifst l) (ifst r)-    alg (GetRegister σ) _ = (In (GetRegister σ), False)-    alg (PutRegister σ p) cut = rewrap (PutRegister σ) cut (ifst p)-    alg (MetaCombinator m p) cut = rewrap (MetaCombinator m) cut (ifst p)---- Termination Analysis (Generalised left-recursion checker)-{-data Consumption = Some | None | Never-data Prop = Prop {success :: Consumption, fails :: Consumption, indisputable :: Bool} | Unknown--looping (Prop Never Never _)          = True-looping _                             = False-strongLooping (Prop Never Never True) = True-strongLooping _                       = False-neverSucceeds (Prop Never _ _)        = True-neverSucceeds _                       = False-neverFails (Prop _ Never _)           = True-neverFails _                          = False--Never ||| _     = Never-_     ||| Never = Never-Some  ||| _     = Some-None  ||| p     = p--Some  &&& _    = Some-_     &&& Some = Some-None  &&& _    = None-Never &&& p    = p--Never ^^^ _     = Never-_     ^^^ Never = Never-None  ^^^ _     = None-Some  ^^^ p     = p--(==>) :: Prop -> Prop -> Prop-p ==> _ | neverSucceeds p            = p-_ ==> Prop Never Never True          = Prop Never Never True-Prop None _ _ ==> Prop Never Never _ = Prop Never Never False-Prop s1 f1 b1 ==> Prop s2 f2 b2      = Prop (s1 ||| s2) (f1 &&& (s1 ||| f2)) (b1 && b2)--branching :: Prop -> [Prop] -> Prop-branching b ps-  | neverSucceeds b = b-  | any strongLooping ps = Prop Never Never True-branching (Prop None f _) ps-  | any looping ps = Prop Never Never False-  | otherwise      = Prop (foldr1 (|||) (map success ps)) (f &&& (foldr1 (^^^) (map fails ps))) False-branching (Prop Some f _) ps = Prop (foldr (|||) Some (map success ps)) f False----data InferredTerm = Loops | Safe | Undecidable-newtype Termination a = Termination {runTerm :: ReaderT (Set IMVar) (State (Map IMVar Prop)) Prop}-terminationAnalysis :: Fix Combinator a -> Fix Combinator a-terminationAnalysis p = if not (looping (evalState (runReaderT (runTerm (cata (Termination . alg) p)) Set.empty) Map.empty)) then p-                        else error "Parser will loop indefinitely: either it is left-recursive or iterates over pure computations"-  where-    alg :: Combinator Termination a -> ReaderT (Set IMVar) (State (Map IMVar Prop)) Prop-    alg (Satisfy _)                          = return $! Prop Some None True-    alg (Pure _)                             = return $! Prop None Never True-    alg Empty                                = return $! Prop Never None True-    alg (Try p)                              =-      do x <- runTerm p-         return $! if looping x then x-                   else Prop (success x) None (indisputable x)-    alg (LookAhead p)                        =-      do x <- runTerm p-         return $! if looping x then x-                   else Prop None (fails x) (indisputable x)-    alg (NotFollowedBy p)                    =-      do x <- runTerm p-         return $! if looping x then x-                   else Prop None None True-    alg (p :<*>: q)                          = liftA2 (==>) (runTerm p) (runTerm q)-    alg (p :*>: q)                           = liftA2 (==>) (runTerm p) (runTerm q)-    alg (p :<*: q)                           = liftA2 (==>) (runTerm p) (runTerm q)-    alg (p :<|>: q)                          =-      do x <- runTerm p; case x of-           -- If we fail without consuming input then q governs behaviour-           Prop _ None _       -> runTerm q-           -- If p never fails then q is irrelevant-           x | neverFails x    -> return $! x-           -- If p never succeeds then q governs-           x | neverSucceeds x -> runTerm q-           Prop s1 Some i1     -> do ~(Prop s2 f i2) <- runTerm q; return $! Prop (s1 &&& s2) (Some ||| f) (i1 && i2)-    alg (Branch b p q)                       = liftA2 branching (runTerm b) (sequence [runTerm p, runTerm q])-    alg (Match p _ qs def)                   = liftA2 branching (runTerm p) (traverse runTerm (def:qs))-    alg (ChainPre op p)                      =-      do x <- runTerm op; case x of-           -- Never failing implies you must either loop or not consume input-           Prop _ Never _ -> return $! Prop Never Never True-           -- Reaching p can take a route that consumes no input, if op failed-           _ -> do y <- runTerm p-                   return $! if looping y then y-                             else y -- TODO Verify!-    alg (ChainPost p op)                     =-      do y <- runTerm op; case y of-           Prop None _ _ -> return $! Prop Never Never True-           y -> do x <- runTerm p; case (x, y) of-                     (Prop Some f _, Prop _ Never _) -> return $! Prop Some f False-                     (x, y)                          -> return $! Prop (success x) (fails x &&& fails y) False -- TODO Verify-    alg (Let True (MVar v) p)                =-      do props <- get-         seen <- ask-         case Map.lookup v props of-           Just prop -> return $! prop-           Nothing | Set.member v seen -> return $! Prop Never Never False-           Nothing -> do prop <- local (Set.insert v) (runTerm p)-                         let prop' = if looping prop then Prop Never Never True else prop-                         put (Map.insert v prop' props)-                         return $! prop'-    alg (Debug _ p)                          = runTerm p-    --alg _                                    = return $! Unknown--}

@@ -1,179 +0,0 @@-{-# OPTIONS_GHC -fno-hpc #-}-{-# LANGUAGE AllowAmbiguousTypes,-             MagicHash,-             MultiParamTypeClasses,-             MultiWayIf,-             RecursiveDo,-             UndecidableInstances #-}-module Parsley.Internal.Frontend.Compiler (compile) where--import Prelude hiding (pred)-import Data.Dependent.Map                           (DMap)-import Data.Hashable                                (Hashable, hashWithSalt, hash)-import Data.HashMap.Strict                          (HashMap)-import Data.HashSet                                 (HashSet)-import Data.IORef                                   (IORef, newIORef, readIORef, writeIORef)-import Data.Kind                                    (Type)-import Data.Maybe                                   (isJust)-import Data.Set                                     (Set)-import Control.Arrow                                (first, second)-import Control.Monad                                (void, when)-import Control.Monad.Reader                         (ReaderT, runReaderT, local, ask, MonadReader)-import GHC.Exts                                     (Int(..), unsafeCoerce#)-import GHC.Prim                                     (StableName#)-import GHC.StableName                               (StableName(..), makeStableName, hashStableName, eqStableName)-import Numeric                                      (showHex)-import Parsley.Internal.Core.CombinatorAST          (Combinator(..), ScopeRegister(..), Reg(..), Parser(..), traverseCombinator)-import Parsley.Internal.Core.Identifiers            (IMVar, MVar(..), IΣVar, ΣVar(..))-import Parsley.Internal.Common.Fresh                (HFreshT, newVar, runFreshT)-import Parsley.Internal.Common.Indexed              (Fix(In), cata, cata', IFunctor(imap), (:+:)(..), (\/), Const1(..))-import Parsley.Internal.Common.State                (State, get, gets, runState, execState, modify', MonadState)-import Parsley.Internal.Frontend.Optimiser          (optimise)-import Parsley.Internal.Frontend.CombinatorAnalyser (analyse, emptyFlags, AnalysisFlags(..))-import Parsley.Internal.Frontend.Dependencies       (dependencyAnalysis)-import Parsley.Internal.Trace                       (Trace(trace))-import System.IO.Unsafe                             (unsafePerformIO)--import qualified Data.Dependent.Map  as DMap    ((!), empty, insert, mapWithKey, size)-import qualified Data.HashMap.Strict as HashMap (lookup, insert, empty, insertWith, foldrWithKey, (!))-import qualified Data.HashSet        as HashSet (member, insert, empty)-import qualified Data.Map            as Map     ((!))-import qualified Data.Set            as Set     (empty)--{-# INLINEABLE compile #-}-compile :: forall compiled a. Trace => Parser a -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set IΣVar -> IMVar -> IΣVar -> compiled x) -> (compiled a, DMap MVar compiled)-compile (Parser p) codeGen = trace ("COMPILING NEW PARSER WITH " ++ show (DMap.size μs') ++ " LET BINDINGS") (codeGen' Nothing p', DMap.mapWithKey (codeGen' . Just) μs')-  where-    (p', μs, maxV) = preprocess p-    (μs', frs, maxΣ) = dependencyAnalysis p' μs--    freeRegs :: Maybe (MVar x) -> Set IΣVar-    freeRegs = maybe Set.empty (\(MVar v) -> frs Map.! v)--    codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x-    codeGen' letBound p = codeGen letBound (analyse (emptyFlags {letBound = isJust letBound}) p) (freeRegs letBound) (maxV + 1) (maxΣ + 1)--preprocess :: Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)-preprocess p =-  let q = tagParser p-      (lets, recs) = findLets q-      (p', μs, maxV) = letInsertion lets recs q-  in (p', μs, maxV)--data ParserName = forall a. ParserName (StableName# (Fix (Combinator :+: ScopeRegister) a))-data Tag t f (k :: Type -> Type) a = Tag {tag :: t, tagged :: f k a}--tagParser :: Fix (Combinator :+: ScopeRegister) a -> Fix (Tag ParserName Combinator) a-tagParser p = cata' tagAlg p-  where-    tagAlg p = In . Tag (makeParserName p) . (id \/ descope)-    descope (ScopeRegister p f) = freshReg regMaker (\reg@(Reg σ) -> MakeRegister σ p (f reg))-    regMaker :: IORef IΣVar-    regMaker = newRegMaker p--data LetFinderState = LetFinderState { preds  :: HashMap ParserName Int-                                     , recs   :: HashSet ParserName }-type LetFinderCtx   = HashSet ParserName-newtype LetFinder a = LetFinder { doLetFinder :: ReaderT LetFinderCtx (State LetFinderState) () }--findLets :: Fix (Tag ParserName Combinator) a -> (HashSet ParserName, HashSet ParserName)-findLets p = (lets, recs)-  where-    state = LetFinderState HashMap.empty HashSet.empty-    ctx = HashSet.empty-    LetFinderState preds recs = execState (runReaderT (doLetFinder (cata findLetsAlg p)) ctx) state-    lets = HashMap.foldrWithKey (\k n ls -> if n > 1 then HashSet.insert k ls else ls) HashSet.empty preds--findLetsAlg :: Tag ParserName Combinator LetFinder a -> LetFinder a-findLetsAlg p = LetFinder $ do-  let name = tag p-  addPred name-  ifSeen name-    (do addRec name)-    (ifNotProcessedBefore name-      (void (addName name (traverseCombinator (fmap Const1 . doLetFinder) (tagged p)))))--newtype LetInserter a =-  LetInserter {-      doLetInserter :: HFreshT IMVar-                       (State ( HashMap ParserName IMVar-                              , DMap MVar (Fix Combinator)))-                       (Fix Combinator a)-    }-letInsertion :: HashSet ParserName -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)-letInsertion lets recs p = (p', μs, μMax)-  where-    m = cata alg p-    ((p', μMax), (_, μs)) = runState (runFreshT (doLetInserter m) 0) (HashMap.empty, DMap.empty)-    alg :: Tag ParserName Combinator LetInserter a -> LetInserter a-    alg p = LetInserter $ do-      let name = tag p-      let q = tagged p-      (vs, μs) <- get-      let bound = HashSet.member name lets-      let recu = HashSet.member name recs-      if bound || recu then case HashMap.lookup name vs of-        Just v  -> let μ = MVar v in return $! optimise (Let recu μ (μs DMap.! μ))-        Nothing -> do-          v <- newVar-          let μ = MVar v-          modify' (first (HashMap.insert name v))-          rec-            modify' (second (DMap.insert μ q'))-            q' <- doLetInserter (postprocess q) -- This line should be moved above when there is an inliner pass-          return $! optimise (Let recu μ q')-      else do doLetInserter (postprocess q)--postprocess :: Combinator LetInserter a -> LetInserter a-postprocess = LetInserter . fmap optimise . traverseCombinator doLetInserter--modifyPreds :: MonadState LetFinderState m => (HashMap ParserName Int -> HashMap ParserName Int) -> m ()-modifyPreds f = modify' (\st -> st {preds = f (preds st)})--modifyRecs :: MonadState LetFinderState m => (HashSet ParserName -> HashSet ParserName) -> m ()-modifyRecs f = modify' (\st -> st {recs = f (recs st)})--addPred :: MonadState LetFinderState m => ParserName -> m ()-addPred k = modifyPreds (HashMap.insertWith (+) k 1)--addRec :: MonadState LetFinderState m => ParserName -> m ()-addRec = modifyRecs . HashSet.insert--ifSeen :: MonadReader LetFinderCtx m => ParserName -> m a -> m a -> m a-ifSeen x yes no = do seen <- ask; if HashSet.member x seen then yes else no--ifNotProcessedBefore :: MonadState LetFinderState m => ParserName -> m () -> m ()-ifNotProcessedBefore x m =-  do oneReference <- gets ((== 1) . (HashMap.! x) . preds)-     when oneReference m--addName :: MonadReader LetFinderCtx m => ParserName -> m b -> m b-addName x = local (HashSet.insert x)--makeParserName :: Fix (Combinator :+: ScopeRegister) a -> ParserName--- Force evaluation of p to ensure that the stableName is correct first time-makeParserName !p = unsafePerformIO (fmap (\(StableName name) -> ParserName name) (makeStableName p))---- The argument here stops GHC from floating it out, it should be provided something from the scope-{-# NOINLINE newRegMaker #-}-newRegMaker :: a -> IORef IΣVar-newRegMaker x = x `seq` unsafePerformIO (newIORef 0)--{-# NOINLINE freshReg #-}-freshReg :: IORef IΣVar -> (forall r. Reg r a -> x) -> x-freshReg maker scope = scope $ unsafePerformIO $ do-  x <- readIORef maker-  writeIORef maker (x + 1)-  return $! Reg (ΣVar x)--instance IFunctor f => IFunctor (Tag t f) where-  imap f (Tag t k) = Tag t (imap f k)--instance Eq ParserName where-  (ParserName n) == (ParserName m) = eqStableName (StableName n) (StableName m)-instance Hashable ParserName where-  hash (ParserName n) = hashStableName (StableName n)-  hashWithSalt salt (ParserName n) = hashWithSalt salt (StableName n)---- There is great evil in this world, and I'm probably responsible for half of it-instance Show ParserName where showsPrec _ (ParserName n) = showHex (I# (unsafeCoerce# n))

@@ -1,164 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Parsley.Internal.Frontend.Dependencies (dependencyAnalysis) where--import Control.Arrow                        (first, second)-import Control.Monad                        (unless, forM_)-import Data.Array                           (Array, (!), listArray)-import Data.Array.MArray                    (readArray, writeArray, newArray)-import Data.Array.ST                        (runSTUArray)-import Data.Array.Unboxed                   (assocs)-import Data.Dependent.Map                   (DMap)-import Data.List                            (foldl', partition, sortOn)-import Data.Map.Strict                      (Map)-import Data.Maybe                           (fromMaybe)-import Data.Set                             (Set, insert, (\\), union, notMember, empty)-import Data.STRef                           (newSTRef, readSTRef, writeSTRef)-import Parsley.Internal.Common.Indexed      (Fix, cata, Const1(..), (:*:)(..), zipper)-import Parsley.Internal.Common.State        (State, MonadState, execState, modify')-import Parsley.Internal.Core.CombinatorAST  (Combinator(..), traverseCombinator)-import Parsley.Internal.Core.Identifiers    (IMVar, MVar(..), IΣVar, ΣVar(..))--import qualified Data.Dependent.Map as DMap (foldrWithKey, filterWithKey)-import qualified Data.Map.Strict    as Map  ((!), empty, insert, mapMaybeWithKey, findMax, elems, lookup, foldMapWithKey)-import qualified Data.Set           as Set  (elems, empty, insert, lookupMax)--type Graph = Array IMVar [IMVar]---- TODO This actually should be in the backend... dead bindings and the topological ordering can be computed here---      but the register stuff should come after register optimisation and instruction peephole--dependencyAnalysis :: Fix Combinator a -> DMap MVar (Fix Combinator) -> (DMap MVar (Fix Combinator), Map IMVar (Set IΣVar), IΣVar)-dependencyAnalysis toplevel μs =-  let -- Step 1: find roots of the toplevel-      roots = directDependencies toplevel-      -- Step 2: build immediate dependencies-      DependencyMaps{..} = buildDependencyMaps μs-      -- Step 3: find the largest name-      n = fst (Map.findMax immediateDependencies)-      -- Step 4: Build a dependency graph-      graph = buildGraph n immediateDependencies-      -- Step 5: construct the seen set (dfnum)-      -- Step 6: dfs from toplevel (via roots) all with same seen set-      -- Step 7: elems of seen set with dfnum 0 are dead, otherwise they are collected into a list in descending order-      (topo, dead) = topoOrdering roots n graph-      -- Step 8: perform a dfs on each of the topo, with a new seen set for each,-      --         building the flattened dependency map. If the current focus has-      --         already been computed, add all its deps to the seen set and skip.-      --         The end seen set becomes out flattened deps.-      trueDeps = flattenDependencies topo (minMax topo) graph-      -- Step 8: Compute the new registers, and remove dead ones-      addNewRegs v uses-        | notMember v dead = let deps = trueDeps Map.! v-                                 defs = definedRegisters Map.! v-                                 subUses = foldMap (usedRegisters Map.!) deps-                                 subDefs = foldMap (definedRegisters Map.!) deps-                             in Just $ (uses \\ defs) `union` (subUses \\ subDefs)-        | otherwise        = Nothing-      trueRegs = Map.mapMaybeWithKey addNewRegs usedRegisters-      largestRegister = fromMaybe (-1) (Set.lookupMax (Map.foldMapWithKey (const id) definedRegisters))-  in (DMap.filterWithKey (\(MVar v) _ -> notMember v dead) μs, trueRegs, largestRegister)--minMax :: Ord a => [a] -> (a, a)-minMax []     = error "cannot find minimum or maximum of empty list"-minMax (x:xs) = foldl' (\(small, big) x -> (min small x, max big x)) (x, x) xs--buildGraph :: IMVar -> Map IMVar (Set IMVar) -> Graph-buildGraph n = listArray (0, n) . map Set.elems . Map.elems--topoOrdering :: Set IMVar -> IMVar -> Graph -> ([IMVar], Set IMVar)-topoOrdering roots n graph =-  let dfnums = runSTUArray $ do-        dfnums <- newArray (0, n) (0 :: Int)-        nextDfnum <- newSTRef 1-        let hasSeen v = (/= 0) <$> readArray dfnums v-        let setSeen v = do dfnum <- readSTRef nextDfnum-                           writeArray dfnums v dfnum-                           writeSTRef nextDfnum (dfnum + 1)-        forM_ roots (dfs hasSeen setSeen graph)-        return dfnums-      (lives, deads) = partition ((/= 0) . snd) (assocs dfnums)-  in (reverseMap fst (sortOn snd lives), foldl' (\ds v0 -> Set.insert (fst v0) ds) Set.empty deads)--reverseMap :: (a -> b) -> [a] -> [b]-reverseMap f = foldl' (\xs x -> f x : xs) []--flattenDependencies :: [IMVar] -> (IMVar, IMVar) -> Graph -> Map IMVar (Set IMVar)-flattenDependencies topo range graph = foldl' reachable Map.empty topo-  where-    reachable :: Map IMVar (Set IMVar) -> IMVar -> Map IMVar (Set IMVar)-    reachable deps root =-      let seen = runSTUArray $ do-            seen <- newArray range False-            let setSeen v = writeArray seen v True-            let seenOrSkip v = case Map.lookup v deps of-                  Nothing -> readArray seen v-                  Just ds -> setSeen v >> forM_ ds setSeen >> return True-            dfs seenOrSkip setSeen graph root-            return seen-          ds = foldl' (\ds (v, b) -> if b then Set.insert v ds else ds) Set.empty (assocs seen)-      in Map.insert root ds deps--dfs :: Monad m => (IMVar -> m Bool) -> (IMVar -> m ()) -> Graph -> IMVar -> m ()-dfs hasSeen setSeen graph = go-  where-    go v = do seen <- hasSeen v-              unless seen $-                do setSeen v-                   forM_ (graph ! v) go---- IMMEDIATE DEPENDENCY MAPS-data DependencyMaps = DependencyMaps {-  usedRegisters         :: Map IMVar (Set IΣVar), -- Leave Lazy-  immediateDependencies :: Map IMVar (Set IMVar), -- Could be Strict-  definedRegisters      :: Map IMVar (Set IΣVar)-}--buildDependencyMaps :: DMap MVar (Fix Combinator) -> DependencyMaps-buildDependencyMaps = DMap.foldrWithKey (\(MVar v) p deps@DependencyMaps{..} ->-  let (frs, defs, ds) = freeRegistersAndDependencies v p-  in deps { usedRegisters = Map.insert v frs usedRegisters-          , immediateDependencies = Map.insert v ds immediateDependencies-          , definedRegisters = Map.insert v defs definedRegisters}) (DependencyMaps Map.empty Map.empty Map.empty)--freeRegistersAndDependencies :: IMVar -> Fix Combinator a -> (Set IΣVar,  Set IΣVar, Set IMVar)-freeRegistersAndDependencies v p =-  let frsm :*: depsm = zipper freeRegistersAlg (dependenciesAlg (Just v)) p-      (frs, defs) = runFreeRegisters frsm-      ds = runDependencies depsm-  in (frs, defs, ds)---- DEPENDENCY ANALYSIS-newtype Dependencies a = Dependencies { doDependencies :: State (Set IMVar) () }-runDependencies :: Dependencies a -> Set IMVar-runDependencies = flip execState empty. doDependencies--directDependencies :: Fix Combinator a -> Set IMVar-directDependencies = runDependencies . cata (dependenciesAlg Nothing)--{-# INLINE dependenciesAlg #-}-dependenciesAlg :: Maybe IMVar -> Combinator Dependencies a -> Dependencies a-dependenciesAlg (Just v) (Let _ μ@(MVar u) _) = Dependencies $ do unless (u == v) (dependsOn μ)-dependenciesAlg Nothing  (Let _ μ _)          = Dependencies $ do dependsOn μ-dependenciesAlg _ p                           = Dependencies $ do traverseCombinator (fmap Const1 . doDependencies) p; return ()--dependsOn :: MonadState (Set IMVar) m => MVar a -> m ()-dependsOn (MVar v) = modify' (insert v)---- FREE REGISTER ANALYSIS-newtype FreeRegisters a = FreeRegisters { doFreeRegisters :: State (Set IΣVar, Set IΣVar) () }-runFreeRegisters :: FreeRegisters a -> (Set IΣVar, Set IΣVar)-runFreeRegisters = flip execState (empty, empty) . doFreeRegisters--{-# INLINE freeRegistersAlg #-}-freeRegistersAlg :: Combinator FreeRegisters a -> FreeRegisters a-freeRegistersAlg (GetRegister σ)      = FreeRegisters $ do uses σ-freeRegistersAlg (PutRegister σ p)    = FreeRegisters $ do uses σ; doFreeRegisters p-freeRegistersAlg (MakeRegister σ p q) = FreeRegisters $ do defs σ; doFreeRegisters p; doFreeRegisters q-freeRegistersAlg Let{}                = FreeRegisters $ do return () -- TODO This can be removed when Let doesn't have the body in it...-freeRegistersAlg p                    = FreeRegisters $ do traverseCombinator (fmap Const1 . doFreeRegisters) p; return ()--uses :: MonadState (Set IΣVar, vs) m => ΣVar a -> m ()-uses (ΣVar σ) = modify' (first (insert σ)) --tell (singleton σ, mempty)--defs :: MonadState (vs, Set IΣVar) m => ΣVar a -> m ()-defs (ΣVar σ) = modify' (second (insert σ)) --tell (mempty, singleton σ)

@@ -1,177 +0,0 @@-{-# LANGUAGE LambdaCase,-             PatternSynonyms,-             ViewPatterns #-}-module Parsley.Internal.Frontend.Optimiser (optimise) where--import Prelude hiding                      ((<$>))-import Parsley.Internal.Common             (Fix(In), Quapplicative(..))-import Parsley.Internal.Core.CombinatorAST (Combinator(..))-import Parsley.Internal.Core.Defunc        (Defunc(..), pattern FLIP_H, pattern COMPOSE_H, pattern FLIP_CONST, pattern UNIT)--pattern (:<$>:) :: Defunc (a -> b) -> Fix Combinator a -> Combinator (Fix Combinator) b-pattern f :<$>: p = In (Pure f) :<*>: p-pattern (:$>:) :: Fix Combinator a -> Defunc b -> Combinator (Fix Combinator) b-pattern p :$>: x = p :*>: In (Pure x)-pattern (:<$:) :: Defunc a -> Fix Combinator b -> Combinator (Fix Combinator) a-pattern x :<$: p = In (Pure x) :<*: p--optimise :: Combinator (Fix Combinator) a -> Fix Combinator a--- DESTRUCTIVE OPTIMISATION--- Right Absorption Law: empty <*> u                    = empty-optimise (In Empty :<*>: _)                             = In Empty--- Failure Weakening Law: u <*> empty                   = u *> empty-optimise (u :<*>: In Empty)                             = optimise (u :*>: In Empty)--- Right Absorption Law: empty *> u                     = empty-optimise (In Empty :*>: _)                              = In Empty--- Right Absorption Law: empty <* u                     = empty-optimise (In Empty :<*: _)                              = In Empty--- Failure Weakening Law: u <* empty                    = u *> empty-optimise (u :<*: In Empty)                              = optimise (u :*>: In Empty)--- Branch Absorption Law: branch empty p q              = empty-optimise (Branch (In Empty) _ _)                        = In Empty--- Branch Weakening Law: branch b empty empty           = b *> empty-optimise (Branch b (In Empty) (In Empty))               = optimise (b :*>: In Empty)--- Match Absorption Law: match _ empty _ def            = def-optimise (Match (In Empty) _ _ def)                     = def--- Match Weakening Law: match _ p (const empty) empty   = p *> empty-optimise (Match p _ qs (In Empty))-  | all (\case {In Empty -> True; _ -> False}) qs = optimise (p :*>: In Empty)--- APPLICATIVE OPTIMISATION--- Identity Law: id <$> u                               = u-optimise (ID :<$>: u)                                   = u--- Flip const optimisation: flip const <$> u            = u *> pure id-optimise (FLIP_CONST :<$>: u)                           = optimise (u :*>: In (Pure ID))--- Homomorphism Law: pure f <*> pure x                  = pure (f x)-optimise (f :<$>: In (Pure x))                          = In (Pure (APP_H f x))--- NOTE: This is basically a shortcut, it can be caught by the Composition Law and Homomorphism law--- Functor Composition Law: f <$> (g <$> p)             = (f . g) <$> p-optimise (f :<$>: In (g :<$>: p))                       = optimise (COMPOSE_H f g :<$>: p)--- Composition Law: u <*> (v <*> w)                     = (.) <$> u <*> v <*> w-optimise (u :<*>: In (v :<*>: w))                       = optimise (optimise (optimise (COMPOSE :<$>: u) :<*>: v) :<*>: w)--- Definition of *>-optimise (In (FLIP_CONST :<$>: p) :<*>: q)              = In (p :*>: q)--- Definition of <*-optimise (In (CONST :<$>: p) :<*>: q)                   = In (p :<*: q)--- Reassociation Law 1: (u *> v) <*> w                  = u *> (v <*> w)-optimise (In (u :*>: v) :<*>: w)                        = optimise (u :*>: (optimise (v :<*>: w)))--- Interchange Law: u <*> pure x                        = pure ($ x) <*> u-optimise (u :<*>: In (Pure x))                          = optimise (APP_H (FLIP_H ID) x :<$>: u)--- Right Absorption Law: (f <$> p) *> q                 = p *> q-optimise (In (_ :<$>: p) :*>: q)                        = In (p :*>: q)--- Left Absorption Law: p <* (f <$> q)                  = p <* q-optimise (p :<*: (In (_ :<$>: q)))                      = In (p :<*: q)--- Reassociation Law 2: u <*> (v <* w)                  = (u <*> v) <* w-optimise (u :<*>: In (v :<*: w))                        = optimise (optimise (u :<*>: v) :<*: w)--- Reassociation Law 3: u <*> (v $> x)                  = (u <*> pure x) <* v-optimise (u :<*>: In (v :$>: x))                        = optimise (optimise (u :<*>: In (Pure x)) :<*: v)--- ALTERNATIVE OPTIMISATION--- Left Catch Law: pure x <|> u                         = pure x-optimise (p@(In (Pure _)) :<|>: _)                      = p--- Left Neutral Law: empty <|> u                        = u-optimise (In Empty :<|>: u)                             = u--- Right Neutral Law: u <|> empty                       = u-optimise (u :<|>: In Empty)                             = u--- Associativity Law: (u <|> v) <|> w                   = u <|> (v <|> w)-optimise (In (u :<|>: v) :<|>: w)                       = In (u :<|>: optimise (v :<|>: w))--- SEQUENCING OPTIMISATION--- Identity law: pure x *> u                            = u-optimise (In (Pure _) :*>: u)                           = u--- Identity law: (u $> x) *> v                          = u *> v-optimise (In (u :$>: _) :*>: v)                         = In (u :*>: v)--- Associativity Law: u *> (v *> w)                     = (u *> v) *> w-optimise (u :*>: In (v :*>: w))                         = optimise (optimise (u :*>: v) :*>: w)--- Identity law: u <* pure x                            = u-optimise (u :<*: In (Pure _))                           = u--- Identity law: u <* (v $> x)                          = u <* v-optimise (u :<*: In (v :$>: _))                         = optimise (u :<*: v)--- Commutativity Law: x <$ u                            = u $> x-optimise (x :<$: u)                                     = optimise (u :$>: x)--- Associativity Law (u <* v) <* w                      = u <* (v <* w)-optimise (In (u :<*: v) :<*: w)                         = optimise (u :<*: optimise (v :<*: w))--- Pure lookahead: lookAhead (pure x)                   = pure x-optimise (LookAhead p@(In (Pure _)))                    = p--- Dead lookahead: lookAhead empty                      = empty-optimise (LookAhead p@(In Empty))                       = p--- Pure negative-lookahead: notFollowedBy (pure x)      = empty-optimise (NotFollowedBy (In (Pure _)))                  = In Empty--- Dead negative-lookahead: notFollowedBy empty         = unit-optimise (NotFollowedBy (In Empty))                     = In (Pure UNIT)--- Double Negation Law: notFollowedBy . notFollowedBy   = lookAhead . try . void-optimise (NotFollowedBy (In (NotFollowedBy p)))         = optimise (LookAhead (In (In (Try p) :*>: In (Pure UNIT))))--- Zero Consumption Law: notFollowedBy (try p)          = notFollowedBy p-optimise (NotFollowedBy (In (Try p)))                   = optimise (NotFollowedBy p)--- Idempotence Law: lookAhead . lookAhead               = lookAhead-optimise (LookAhead (In (LookAhead p)))                 = In (LookAhead p)--- Right Identity Law: notFollowedBy . lookAhead        = notFollowedBy-optimise (NotFollowedBy (In (LookAhead p)))             = optimise (NotFollowedBy p)--- Left Identity Law: lookAhead . notFollowedBy         = notFollowedBy-optimise (LookAhead (In (NotFollowedBy p)))             = In (NotFollowedBy p)--- Transparency Law: notFollowedBy (try p <|> q)        = notFollowedBy p *> notFollowedBy q-optimise (NotFollowedBy (In (In (Try p) :<|>: q)))      = optimise (optimise (NotFollowedBy p) :*>: optimise (NotFollowedBy q))--- Distributivity Law: lookAhead p <|> lookAhead q      = lookAhead (try p <|> q)-optimise (In (LookAhead p) :<|>: In (LookAhead q))      = optimise (LookAhead (optimise (In (Try p) :<|>: q)))--- Interchange Law: lookAhead (p $> x)                  = lookAhead p $> x-optimise (LookAhead (In (p :$>: x)))                    = optimise (optimise (LookAhead p) :$>: x)--- Interchange law: lookAhead (f <$> p)                 = f <$> lookAhead p-optimise (LookAhead (In (f :<$>: p)))                   = optimise (f :<$>: optimise (LookAhead p))--- Absorption Law: p <*> notFollowedBy q                = (p <*> unit) <* notFollowedBy q-optimise (p :<*>: In (NotFollowedBy q))                 = optimise (optimise (p :<*>: In (Pure UNIT)) :<*: In (NotFollowedBy q))--- Idempotence Law: notFollowedBy (p $> x)              = notFollowedBy p-optimise (NotFollowedBy (In (p :$>: _)))                = optimise (NotFollowedBy p)--- Idempotence Law: notFollowedBy (f <$> p)             = notFollowedBy p-optimise (NotFollowedBy (In (_ :<$>: p)))               = optimise (NotFollowedBy p)--- Interchange Law: try (p $> x)                        = try p $> x-optimise (Try (In (p :$>: x)))                          = optimise (optimise (Try p) :$>: x)--- Interchange law: try (f <$> p)                       = f <$> try p-optimise (Try (In (f :<$>: p)))                         = optimise (f :<$>: optimise (Try p))--- pure Left law: branch (pure (Left x)) p q            = p <*> pure x-optimise (Branch (In (Pure (l@(_val -> Left x)))) p _)  = optimise (p :<*>: In (Pure (makeQ x qx))) where qx = [||case $$(_code l) of Left x -> x||]--- pure Right law: branch (pure (Right x)) p q          = q <*> pure x-optimise (Branch (In (Pure (r@(_val -> Right x)))) _ q) = optimise (q :<*>: In (Pure (makeQ x qx))) where qx = [||case $$(_code r) of Right x -> x||]--- Generalised Identity law: branch b (pure f) (pure g) = either f g <$> b-optimise (Branch b (In (Pure f)) (In (Pure g)))         = optimise (makeQ (either (_val f) (_val g)) [||either $$(_code f) $$(_code g)||] :<$>: b)--- Interchange law: branch (x *> y) p q                 = x *> branch y p q-optimise (Branch (In (x :*>: y)) p q)                   = optimise (x :*>: optimise (Branch y p q))--- Negated Branch law: branch b p empty                 = branch (swapEither <$> b) empty p-optimise (Branch b p (In Empty))                        = In (Branch (In (In (Pure (makeQ (either Right Left) [||either Right Left||])) :<*>: b)) (In Empty) p)--- Branch Fusion law: branch (branch b empty (pure f)) empty k                  = branch (g <$> b) empty k where g is a monad transforming (>>= f)-optimise (Branch (In (Branch b (In Empty) (In (Pure f)))) (In Empty) k) = optimise (Branch (optimise (In (Pure (makeQ g qg)) :<*>: b)) (In Empty) k)-  where-    g (Left _) = Left ()-    g (Right x) = case _val f x of-      Left _ -> Left ()-      Right x -> Right x-    qg = [||\case Left _ -> Left ()-                  Right x -> case $$(_code f) x of-                               Left _ -> Left ()-                               Right y -> Right y||]--- Distributivity Law: f <$> branch b p q                = branch b ((f .) <$> p) ((f .) <$> q)-optimise (f :<$>: In (Branch b p q))                     = optimise (Branch b (optimise (APP_H COMPOSE f :<$>: p)) (optimise (APP_H COMPOSE f :<$>: q)))--- pure Match law: match vs (pure x) f def               = if elem x vs then f x else def-optimise (Match (In (Pure x)) fs qs def)                 = foldr (\(f, q) k -> if _val f (_val x) then q else k) def (zip fs qs)--- TODO I'm not actually sure this one is a good optimisation? might have some size constraint on it--- Generalised Identity Match law: match vs p (pure . f) def = f <$> (p >?> flip elem vs) <|> def-{-optimise (Match p fs qs def)-  | all (\case {In (Pure _) -> True; _ -> False}) qs     = optimise (optimise (makeQ apply qapply :<$>: (p >?> (makeQ validate qvalidate))) :<|>: def)-    where apply x    = foldr (\(f, In (Pure y)) k -> if _val f x then _val y else k) (error "whoopsie") (zip fs qs)-          qapply     = [||\x -> $$(foldr (\(f, In (Pure y)) k -> [||if $$(_code f) x then $$(_code y) else $$k||]) ([||error "whoopsie"||]) (zip fs qs))||]-          validate x = foldr (\f b -> _val f x || b) False fs-          qvalidate  = [||\x -> $$(foldr (\f k -> [||$$(_code f) x || $$k||]) [||False||] fs)||]-}--- Distributivity Law: f <$> match vs p g def            = match vs p ((f <$>) . g) (f <$> def)-optimise (f :<$>: (In (Match p fs qs def)))              = In (Match p fs (map (optimise . (f :<$>:)) qs) (optimise (f :<$>: def)))--- Trivial let-bindings - NOTE: These will get moved when Let nodes no longer have the "source" in them-optimise (Let False _ p@(In (Pure _)))                               = p-optimise (Let False _ p@(In Empty))                                  = p-optimise (Let False _ p@(In (Satisfy _)))                            = p-optimise (Let False _ p@(In (In (Satisfy _) :$>: _)))                = p-optimise (Let False _ p@(In (GetRegister _)))                        = p-optimise (Let False _ p@(In (In (Pure _) :<*>: In (GetRegister _)))) = p-optimise p                                                           = In p---- try (lookAhead p *> p *> lookAhead q) = lookAhead (p *> q) <* try p--{-(>?>) :: Fix Combinator a -> Defunc (a -> Bool) -> Fix Combinator a-p >?> f = In (Branch (In (makeQ g qg :<$>: p)) (In Empty) (In (Pure ID)))-  where-    g x = if _val f x then Right x else Left ()-    qg = [||\x -> if $$(_code f) x then Right x else Left ()||]-}

@@ -1,20 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-|-Module      : Parsley.Internal.Trace-Description : Definition of `Trace` class for debugging internals-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : stable--This module contains the defintion of the `Trace` class, used to print additional debug information-from the internals.--@since 0.1.0.0--}-module Parsley.Internal.Trace (Trace, trace, traceShow) where--class Trace where-  trace :: String -> a -> a--traceShow :: (Trace, Show a) => a -> a-traceShow = show >>= trace

@@ -1,29 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-|-Module      : Parsley.Internal.Verbose-Description : Contains instance that enables verbose debugging output for Parsley compiler-License     : BSD-3-Clause-Maintainer  : Jamie Willis-Stability   : stable--This module contains a single orphan instance that enables debugging output on the Parsley compiler.-This output is not useful for the user, but may potentially serve as useful additional information-when submitting a bug report.--@since 0.1.0.0--}--module Parsley.Internal.Verbose () where--import Parsley.Internal.Trace (Trace(trace))-import qualified Debug.Trace (trace)--{-|-This instance, when in scope, will enable additional debug output from the Parsley compilation-process. It will always superscede the default instance defined in "Parsley".--@since 0.1.0.0--}-instance Trace where-  trace = Debug.Trace.trace