packages feed

parsley (empty) → 0.1.0.1

raw patch · 58 files changed

+6167/−0 lines, 58 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers, dependent-map, dependent-sum, ghc-prim, hashable, mtl, pretty-terminal, template-haskell, text, unordered-containers

Files

+ ChangeLog.md view
@@ -0,0 +1,11 @@+# Revision history for `parsley`++## 0.1.0.0  -- 2021-05-22++* First version. Released on an unsuspecting world.++## 0.1.0.1  -- 2021-05-22++* Moved tests and benchmarks into a subproject, which will be easier later down the line.+* Removed useless `dump-core` flag (only used by test and bench, not by the library).+* Fleshed out README properly!
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Jamie Willis++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jamie Willis nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,72 @@+# 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?include_prereleases&sort=semver) [![GitHub license](https://img.shields.io/github/license/j-mie6/ParsleyHaskell.svg)](https://github.com/j-mie6/ParsleyHakell/blob/master/LICENSE)++## 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)+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.++### How does Parsley being a _Staged Selective_ library change its use?+By being a _Selective_ Parser Combinator library, Parsley does not support monadic operations such+as `(>>=)` or `return`. Instead, the most powerful operations are `select` or `branch`. Most monadic+power can be recovered using the functionality provided by `Parsley.Register`, as well as the+selectives.++The reason monads are not supported is because of the _Staging_: Parsley parsers are compiled ahead+of time to produce fast code, but this means the entirety of the parser must be known before any+input is provided, ruling out dynamic monadic operations. The use of staging (in this instance provided+by Typed Template Haskell) means that the signatures of the combinators do not correspond to their+counterparts in other libraries: they don't use raw values, they use code of values. A consequence+of this is that Parsley does not implement instances of `Functor`, `Applicative`, `Alternative`,+or indeed `Selective`; `do`-notation also cannot be used even with `ApplicativeDo`, except perhaps+if `RebindableSyntax` is used.++Code is provided to the combinators by way of the datatype `WQ` (or `Defunc` if you're feeling fancy),+which pairs a normal value with its Haskell code representation:++```hs+data WQ a = WQ a (Code a)+```++This gives us combinators like:++```hs+pure :: WQ a -> Parser a+satisfy :: WQ a -> Parser a++char :: Char -> Parser a+char c = satisfy (WQ (== c) [||(== c)||])+```++Using `WQ` explicitly like this can get annoying, which is what the `lift-plugin` and the+`idioms-plugin` are both for: versions compatible with Parsley can be found on my GitHub, and the+`cabal.project` in this repo shows how these should be installed until they are properly released.++## How does it work?+In short, Parsley represents all parsers as Abstract Syntax Trees (ASTs). The representation of the+parsers the users write is called the Combinator Tree, which is analysed and optimised by Parsley.+This representation is then transformed into an Abstract Machine in CPS form, this is analysed further+before being partially evaluated at compile-time to generate high quality Haskell code. For the long+version, I'd recommend checking out the paper!++## 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.++## References+* This work spawned a paper at ICFP 2020: [**Staged Selective Parser Combinators**](https://dl.acm.org/doi/10.1145/3409002)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ parsley.cabal view
@@ -0,0 +1,153 @@+cabal-version:       2.2+name:                parsley+-- https://wiki.haskell.org/Package_versioning_policy+-- PVP summary:      +--------- breaking API changes+--                   | +------- breaking internal API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.1+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+                     Haskell to generate very fast code. Currently there are no error messages+                     but there are plans for this in the works.+                     .+                     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+bug-reports:         https://github.com/j-mie6/ParsleyHaskell/issues+license:             BSD-3-Clause+license-file:        LICENSE+author:              Jamie Willis+maintainer:          Jamie Willis <j.willis19@imperial.ac.uk>+category:            Parsing+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++library+  exposed-modules:     Parsley,+                       Parsley.Applicative,+                       Parsley.Alternative,+                       Parsley.Defunctionalized,+                       Parsley.Selective,+                       Parsley.Register,+                       Parsley.Combinator,+                       Parsley.Fold,+                       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,+                       FlexibleContexts,+                       FlexibleInstances,+                       KindSignatures,+                       PolyKinds,+                       RankNTypes,+                       ScopedTypeVariables,+                       TemplateHaskell,+                       TypeOperators,++                       NoStarIsType++--                     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,+                       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.19+  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+                       -Wno-name-shadowing+                       -Wno-unused-do-bind+                       -Wno-implicit-prelude+                       -Wno-missing-import-lists+                       -Wno-missing-local-signatures+                       -Wno-safe+                       -Wno-unsafe+                       -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+                       -Wno-prepositive-qualified-module+                       -Wno-unused-packages++source-repository head+  type:                git+  location:            https://github.com/j-mie6/HaskellParsley
+ src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs view
@@ -0,0 +1,49 @@+{-|+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
+ src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs view
@@ -0,0 +1,53 @@+{-# 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"
+ src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs view
@@ -0,0 +1,185 @@+{-# 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
+ src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs view
@@ -0,0 +1,231 @@+{-# 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+    ||]-}
+ src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputRep.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE MagicHash,+             TypeFamilies,+             UnboxedTuples,+             StandaloneKindSignatures #-}+module Parsley.Internal.Backend.Machine.InputRep (+    Rep,+    intSame, intLess, min#, max#,+    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#
+ src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs view
@@ -0,0 +1,233 @@+{-# 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)-}
+ src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs view
@@ -0,0 +1,160 @@+{-# 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"
+ src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs view
@@ -0,0 +1,50 @@+{-|+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
+ src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs view
@@ -0,0 +1,39 @@+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"
+ src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs view
@@ -0,0 +1,183 @@+{-# 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
+ src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputOps.hs view
@@ -0,0 +1,229 @@+{-# 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+    ||]-}
+ src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputRep.hs view
@@ -0,0 +1,131 @@+{-# 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
+ src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs view
@@ -0,0 +1,221 @@+{-# 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)-}
+ src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs view
@@ -0,0 +1,160 @@+{-# 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"
+ src/ghc/Parsley.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : Parsley+Description : Main functionality exports+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This module contains the core execution functions `runParser` and `parseFromFile`.+It exports the `Parser` type, as well as the `ParserOps` typeclass, which may be needed+as a constraint to create more general combinators. It also exports several of the more+important modules and functionality in particular the core set of combinators.++@since 0.1.0.0+-}+module Parsley (+    runParser, parseFromFile,+    module Core,+    module Primitives,+    module Applicative,+    module Alternative,+    module Selective,+    module Combinator,+    module Fold,+    module THUtils,+  ) where++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.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.Selective                as Selective++{-|+The standard way to compile a parser, it returns `Code`, which means+that it must be /spliced/ into a function definition to produce a+function of type @input -> Maybe a@ for a chosen input type. As an example:++/In @Parser.hs@/:++> helloParsley :: Parser String+> helloParsley = string "hello Parsley!"++/In @Main.hs@/:++> parseHelloParsley :: String -> Maybe String+> parseHelloParsley = $$(runParser helloParsley)++Note that the definition of the parser __must__ be in a separate module to+the splice (@$$@).++See `Input` for what the valid input types for Parsley are.++The `Trace` instance is used to enable verbose debugging output for+the compilation pipeline when "Parsley.Internal.Verbose" is imported.++@since 0.1.0.0+-}+runParser :: (Trace, Input input)+          => Parser a                -- ^ The parser to be compiled+          -> Code (input -> Maybe a) -- ^ The generated parsing function+runParser p = [||\input -> $$(eval [||input||] (compile p codeGen))||]++{-|+This function generates a function that reads input from a file+and parses it. The input files contents are treated as `Text16`.++See `runParser` for more information.++@since 0.1.0.0+-}+parseFromFile :: Trace+              => Parser a                        -- ^ The parser to be compiled+              -> Code (FilePath -> IO (Maybe a)) -- ^ The generated parsing function+parseFromFile p = [||\filename -> do input <- readFile filename; return ($$(runParser p) (Text16 input))||]++{-|+The default instance for `Trace`, which disables all debugging output about the parser compilation+process. If "Parsley.Internal.Verbose" is imported, this instance will be supersceded.++@since 0.1.0.0+-}+instance {-# INCOHERENT #-} Trace where+  trace = flip const
+ src/ghc/Parsley/Alternative.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE PatternSynonyms #-}+{-|+Module      : Parsley.Alterative+Description : The @Alternative@ combinators+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This modules contains the @Alternative@ combinators that would normally be found in+@Control.Applicative@. However, since Parsley makes use of staging, the signatures+of these combinators do not correctly match the signatures of those in base Haskell (due to a lack+of @Applicative@ constraint).++@since 0.1.0.0+-}+module Parsley.Alternative (+    (<|>), empty,+    (<+>), option, optionally, optional, choice, maybeP, manyTill+  ) where++import Prelude hiding      (pure, (<$>))+import Parsley.Applicative (pure, (<$>), ($>), (<:>))+import Parsley.Internal    (makeQ, Parser, Defunc(EMPTY), pattern UNIT, ParserOps, (<|>), empty)++{-|+This combinator is similar to @(`<|>`)@, except it allows both branches to differ in type by+producing a co-product as a result.++@since 0.1.0.0+-}+infixl 3 <+>+(<+>) :: Parser a -> Parser b -> Parser (Either a b)+p <+> q = makeQ Left [||Left||] <$> p <|> makeQ Right [||Right||] <$> q++{-|+@option x p@ first tries to parse @p@ and, if it fails without consuming input, will return+@x@ as a result.++@since 0.1.0.0+-}+option :: ParserOps rep => rep a -> Parser a -> Parser a+option x p = p <|> pure x++{-|+@optionally p x@ will try to parse @p@ and will always return @x@. If @p@ fails having consumed+input, then this combinator will fail.++@since 0.1.0.0+-}+optionally :: ParserOps rep => Parser a -> rep b -> Parser b+optionally p x = option x (p $> x)++{-|+Attempts to parse a given parser, and will always return @()@. (See `optionally`)++@since 0.1.0.0+-}+optional :: Parser a -> Parser ()+optional = flip optionally UNIT++{-|+Tries to parse each of the given parsers in turn until one of them succeeds using @(`<|>`)@. If+given the empty list, it will fail unconditionally.++@since 0.1.0.0+-}+choice :: [Parser a] -> Parser a+choice = foldr (<|>) empty++{-|+Tries to parse a given parser, returning its result in @Just@ if it succeeds and @Nothing@ if it+fails having not consumed input.++@since 0.1.0.0+-}+maybeP :: Parser a -> Parser (Maybe a)+maybeP p = option (makeQ Nothing [||Nothing||]) (makeQ Just [||Just||] <$> p)++{-|+The combinator @someTill p end@ will try and parse @p@ as many times as possible so long as @end@+cannot be successfully parsed. It will return the results from the successful parses of @p@.++@since 0.1.0.0+-}+manyTill :: Parser a -> Parser b -> Parser [a]+manyTill p end = let go = end $> EMPTY <|> p <:> go in go
+ src/ghc/Parsley/Applicative.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE PatternSynonyms #-}+{-|+Module      : Parsley.Applicative+Description : The @Applicative@ combinators+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This modules contains all of the @Applicative@ combinators that would normally be found in+@Data.Functor@ or @Control.Applicative@. However, since Parsley makes use of staging, the signatures+of these combinators do not correctly match the signatures of those in base Haskell.++@since 0.1.0.0+-}+module Parsley.Applicative (+    pure, (<*>), (*>), (<*),+    fmap, (<$>), void, (<$), ($>), (<&>), constp,+    unit, (<~>), (<~), (~>),+    liftA2, liftA3,+    (<:>), (<**>),+    sequence, traverse, repeat,+    between,+    (>>)+  ) where++import Prelude hiding   (pure, (<*>), (*>), (<*), (>>), (<$>), fmap, (<$), traverse, sequence, repeat)+import Parsley.Internal (makeQ, Parser, Defunc(CONS, CONST, ID, EMPTY), pattern FLIP_H, pattern UNIT, ParserOps, pure, (<*>), (*>), (<*))++-- Functor Operations+{-|+Maps a function over the result of a parser.++@since 0.1.0.0+-}+fmap :: ParserOps rep => rep (a -> b) -> Parser a -> Parser b+fmap f = (pure f <*>)++{-|+Alias of `fmap`.++@since 0.1.0.0+-}+infixl 4 <$>+(<$>) :: ParserOps rep => rep (a -> b) -> Parser a -> Parser b+(<$>) = fmap++{-|+This combinator \"forgets\" the result of a parser, and replaces it with @()@.++@since 0.1.0.0+-}+void :: Parser a -> Parser ()+void p = p $> UNIT++{-|+This combinator \"forgets\" the result of a parser, and replaces it the given value.++@since 0.1.0.0+-}+infixl 4 <$+(<$) :: ParserOps rep => rep b -> Parser a -> Parser b+x <$ p = p *> pure x++{-|+This combinator \"forgets\" the result of a parser, and replaces it the given value.++@since 0.1.0.0+-}+infixl 4 $>+($>) :: ParserOps rep => Parser a -> rep b -> Parser b+($>) = flip (<$)++{-|+Maps a function over the result of a parser.++@since 0.1.0.0+-}+infixl 4 <&>+(<&>) :: ParserOps rep => Parser a -> rep (a -> b) -> Parser b+(<&>) = flip fmap++-- | @since 0.1.0.0+constp :: Parser a -> Parser (b -> a)+constp = (CONST <$>)++-- Alias Operations+{-|+Alias of @(`*>`)@++@since 0.1.0.0+-}+infixl 1 >>+(>>) :: Parser a -> Parser b -> Parser b+(>>) = (*>)++-- Monoidal Operations+{-|+This parser always returns @()@ without consuming input.++@since 0.1.0.0+-}+unit :: Parser ()+unit = pure UNIT++{-|+Sequential zipping of one parser's result with another's. The parsers must both succeed, one after+the other to pair their results. If either parser fails then the combinator will fail.++@since 0.1.0.0+-}+infixl 4 <~>+(<~>) :: Parser a -> Parser b -> Parser (a, b)+(<~>) = liftA2 (makeQ (,) [||(,)||])++{-|+Alias of @(`<*`)@++@since 0.1.0.0+-}+infixl 4 <~+(<~) :: Parser a -> Parser b -> Parser a+(<~) = (<*)++{-|+Alias of @(`*>`)@++@since 0.1.0.0+-}+infixl 4 ~>+(~>) :: Parser a -> Parser b -> Parser b+(~>) = (*>)++-- Lift Operations+{-|+Sequential combination of two parsers results. The results are combined using the given function.++@since 0.1.0.0+-}+liftA2 :: ParserOps rep => rep (a -> b -> c) -> Parser a -> Parser b -> Parser c+liftA2 f p q = f <$> p <*> q++{-|+Sequential combination of three parsers results. The results are combined using the given function.++@since 0.1.0.0+-}+liftA3 :: ParserOps rep => rep (a -> b -> c -> d) -> Parser a -> Parser b -> Parser c -> Parser d+liftA3 f p q r = f <$> p <*> q <*> r++{-|+Sequential consing of one parser's result with 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 -> Parser [a] -> Parser [a]+(<:>) = liftA2 CONS++{-|+A variant of @(`<*>`)@ with the arguments reversed.++@since 0.1.0.0+-}+infixl 4 <**>+(<**>) :: Parser a -> Parser (a -> b) -> Parser b+(<**>) = liftA2 (FLIP_H ID)++-- Auxillary functions+{-|+Given a list of parsers, `sequence` will parse each in turn and collect all their results into a+list. All the parsers in the list must succeed.++@since 0.1.0.0+-}+sequence :: [Parser a] -> Parser [a]+sequence = foldr (<:>) (pure EMPTY)++{-|+Like `sequence`, but the parsers to sequence are generated from seed values using a given generator+function.++@since 0.1.0.0+-}+traverse :: (a -> Parser b) -> [a] -> Parser [b]+traverse f = sequence . map f++{-|+The combinator @repeat n p@ will attempt to parse @p@ exactly @n@ times. That is not to say that+the parser must fail on the @n+1@th try, but there must be @n@ successes for the combinator to+succeed. All the results generated from @p@ will be collected into a list.++@since 0.1.0.0+-}+repeat :: Int -> Parser a -> Parser [a]+repeat n = sequence . replicate n++{-|+The combinator @between open close p@ will first parse @open@ then @p@ and then @close@, yielding+the result given by @p@.++@since 0.1.0.0+-}+between :: Parser o -> Parser c -> Parser a -> Parser a+between open close p = open *> p <* close
+ src/ghc/Parsley/Combinator.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE PatternSynonyms #-}+{-|+Module      : Parsley.Combinator+Description : The parsing combinators+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This module contains the classic parser combinator operations specific to parsers themselves.+This means any combinators that deal with input consumption at a primitive level.++@since 0.1.0.0+-}+module Parsley.Combinator (+    satisfy, char, item,+    string, token,+    oneOf, noneOf,+    eof, more,+    someTill,+    try,+    lookAhead, notFollowedBy+  ) where++import Prelude hiding      (traverse, (*>))+import Parsley.Alternative (manyTill)+import Parsley.Applicative (($>), void, traverse, (<:>), (*>))+import Parsley.Internal    (Code, makeQ, Parser, Defunc(LIFTED, EQ_H, CONST), pattern APP_H, satisfy, lookAhead, try, notFollowedBy)++{-|+This combinator will attempt match a given string. If the parser fails midway through, this+combinator will fail having consumed input. On success, the string itself is returned and input+will be consumed.++@since 0.1.0.0+-}+string :: String -> Parser String+string = traverse char++{-|+This combinator will attempt to match any one of the provided list of characters. If one of those+characters is found, it will be returned and the input consumed. If not, the combinator will fail+having consumed no input.++@since 0.1.0.0+-}+oneOf :: [Char] -> Parser Char+oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])++{-|+This combinator will attempt to not match any one of the provided list of characters. If one of those+characters is found, the combinator will fail having consumed no input. If not, it will return+the character that was not an element of the provided list.++@since 0.1.0.0+-}+noneOf :: [Char] -> Parser Char+noneOf cs = satisfy (makeQ (not . flip elem cs) [||\c -> not $$(ofChars cs [||c||])||])++ofChars :: [Char] -> Code Char -> Code Bool+ofChars = foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])++{-|+Like `string`, excepts parses the given string atomically using `try`. Never consumes input on+failure.++@since 0.1.0.0+-}+token :: String -> Parser String+token = try . string++{-|+This parser succeeds only if there is no input left to consume, and fails without consuming input+otherwise.++@since 0.1.0.0+-}+eof :: Parser ()+eof = notFollowedBy item++{-|+This parser succeeds if there is still input left to consume, and fails otherwise.++@since 0.1.0.0+-}+more :: Parser ()+more = lookAhead (void item)++-- Parsing Primitives+{-|+This combinator will attempt to match a given character. If that character is the next input token,+the parser succeeds and the character is returned. Otherwise, the combinator will fail having not+consumed any input.++@since 0.1.0.0+-}+char :: Char -> Parser Char+char c = satisfy (EQ_H (LIFTED c)) $> LIFTED c++{-|+Reads any single character. This combinator will only fail if there is no more input remaining.+The parsed character is returned.++@since 0.1.0.0+-}+item :: Parser Char+item = satisfy (APP_H CONST ((makeQ True [||True||])))++-- Composite Combinators+{-|+The combinator @someTill p end@ will try and parse @p@ as many times as possible (but at least once)+so long as @end@ cannot be successfully parsed. It will return the results from the successful parses of @p@.++@since 0.1.0.0+-}+someTill :: Parser a -> Parser b -> Parser [a]+someTill p end = notFollowedBy end *> (p <:> manyTill p end)
+ src/ghc/Parsley/Defunctionalized.hs view
@@ -0,0 +1,19 @@+{-|+Module      : Parsley.Defunctionalized+Description : Defunctionalised operators usable in place of plain Haskell equivalents+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This module exports the `Defunc` type and associated patterns. These are by no means required+to use Parsley, however they can serve as useful shortcuts to their regular Haskell equivalents.+As they are in datatype form, they are inspectable by the internal Parsley machinery, which may+improve optimisation opportunities or code generation.++@since 0.1.0.0+-}+module Parsley.Defunctionalized (+    module Parsley.Internal.Core.Defunc+  ) where++import Parsley.Internal.Core.Defunc hiding (genDefunc, genDefunc1, genDefunc2, ap)
+ src/ghc/Parsley/Fold.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE PatternSynonyms #-}+{-|+Module      : Parsley.Fold+Description : The "folding" combinators: chains and iterators+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This module contains the combinator concerned with some form of iteration or input folding. Notably,+this includes the traditional `many` and `some` combinators.++@since 0.1.0.0+-}+module Parsley.Fold (+    many, some, manyN,+    skipMany, skipSome, skipManyN,+    sepBy, sepBy1, endBy, endBy1, sepEndBy, sepEndBy1,+    chainl1, chainr1, chainl, chainr,+    chainl1', chainr1', chainPre, chainPost,+    pfoldr, pfoldl,+    pfoldr1, pfoldl1+  ) where++import Prelude hiding      (pure, (<*>), (<$>), (*>), (<*))+import Parsley.Alternative ((<|>), option)+import Parsley.Applicative (pure, (<*>), (<$>), (*>), (<*), (<:>), (<**>), void)+import Parsley.Internal    (Parser, Defunc(FLIP, ID, COMPOSE, EMPTY, CONS, CONST), ParserOps, pattern FLIP_H, pattern COMPOSE_H, pattern UNIT, chainPre, chainPost)+import Parsley.Register    (bind, get, modify, newRegister_)++{-chainPre :: Parser (a -> a) -> Parser a -> Parser a+chainPre op p = newRegister_ ID $ \acc ->+  let go = modify acc (FLIP_H COMPOSE <$> op) *> go+       <|> get acc+  in go <*> p-}++{-chainPost :: Parser a -> Parser (a -> a) -> Parser a+chainPost p op = newRegister p $ \acc ->+  let go = modify acc op *> go+       <|> get acc+  in go-}++-- Parser Folds+{-|+@pfoldr f k p@ parses __zero__ or more @p@s and combines the results using the function @f@. When @p@+fails without consuming input, the terminal result @k@ is returned.++> many = pfoldr CONS EMPTY++@since 0.1.0.0+-}+pfoldr :: (ParserOps repf, ParserOps repk) => repf (a -> b -> b) -> repk b -> Parser a -> Parser b+pfoldr f k p = chainPre (f <$> p) (pure k)++{-|+@pfoldr1 f k p@ parses __one__ or more @p@s and combines the results using the function @f@. When @p@+fails without consuming input, the terminal result @k@ is returned.++> some = pfoldr1 CONS EMPTY++@since 0.1.0.0+-}+pfoldr1 :: (ParserOps repf, ParserOps repk) => repf (a -> b -> b) -> repk b -> Parser a -> Parser b+pfoldr1 f k p = f <$> p <*> pfoldr f k p++{-|+@pfoldl f k p@ parses __zero__ or more @p@s and combines the results using the function @f@. The+accumulator is initialised with the value @k@.++@since 0.1.0.0+-}+pfoldl :: (ParserOps repf, ParserOps repk) => repf (b -> a -> b) -> repk b -> Parser a -> Parser b+pfoldl f k p = chainPost (pure k) ((FLIP <$> pure f) <*> p)++{-|+@pfoldl1 f k p@ parses __one__ or more @p@s and combines the results using the function @f@. The+accumulator is initialised with the value @k@.++@since 0.1.0.0+-}+pfoldl1 :: (ParserOps repf, ParserOps repk) => repf (b -> a -> b) -> repk b -> Parser a -> Parser b+pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((FLIP <$> pure f) <*> p)++-- Chain Combinators+{-|+@chainl1' wrap p op @ parses one or more occurrences of @p@, separated by @op@. Returns a value obtained+by a /left/ associative application of all functions returned by @op@ to the values returned by @p@.+The function @wrap@ is used to transform the initial value from @p@ into the correct form.++@since 0.1.0.0+-}+chainl1' :: ParserOps rep => rep (a -> b) -> Parser a -> Parser (b -> a -> b) -> Parser b+chainl1' f p op = chainPost (f <$> p) (FLIP <$> op <*> p)++{-|+The classic version of the left-associative chain combinator. See `chainl1'`.++> chainl1 p op = chainl1' ID p op++@since 0.1.0.0+-}+chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a+chainl1 = chainl1' ID++{-|+@chainr1' wrap p op @ parses one or more occurrences of @p@, separated by @op@. Returns a value obtained+by a /right/ associative application of all functions returned by @op@ to the values returned by @p@.+The function @wrap@ is used to transform the final value from @p@ into the correct form.++@since 0.1.0.0+-}+chainr1' :: ParserOps rep => rep (a -> b) -> Parser a -> Parser (a -> b -> b) -> Parser b+chainr1' f p op = newRegister_ ID $ \acc ->+  let go = bind p $ \x ->+           modify acc (FLIP_H COMPOSE <$> (op <*> x)) *> go+       <|> f <$> x+  in go <**> get acc++{-|+The classic version of the right-associative chain combinator. See `chainr1'`.++> chainr1 p op = chainr1' ID p op++@since 0.1.0.0+-}+chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a+chainr1 = chainr1' ID++{-|+Like `chainr1`, but may parse zero occurences of @p@ in which case the value is returned.++@since 0.1.0.0+-}+chainr :: ParserOps rep => Parser a -> Parser (a -> a -> a) -> rep a -> Parser a+chainr p op x = option x (chainr1 p op)++{-|+Like `chainl1`, but may parse zero occurences of @p@ in which case the value is returned.++@since 0.1.0.0+-}+chainl :: ParserOps rep => Parser a -> Parser (a -> a -> a) -> rep a -> Parser a+chainl p op x = option x (chainl1 p op)++-- Derived Combinators+{-|+Attempts to parse the given parser __zero__ or more times, collecting all of the successful results+into a list. Same as @manyN 0@++@since 0.1.0.0+-}+many :: Parser a -> Parser [a]+many = pfoldr CONS EMPTY++{-|+Attempts to parse the given parser __n__ or more times, collecting all of the successful results+into a list.++@since 0.1.0.0+-}+manyN :: Int -> Parser a -> Parser [a]+manyN n p = foldr (const (p <:>)) (many p) [1..n]++{-|+Attempts to parse the given parser __one__ or more times, collecting all of the successful results+into a list. Same as @manyN 1@++@since 0.1.0.0+-}+some :: Parser a -> Parser [a]+some = manyN 1++{-|+Like `many`, excepts discards its results.++@since 0.1.0.0+-}+skipMany :: Parser a -> Parser ()+--skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp+skipMany = void . pfoldl CONST UNIT -- the void here will encourage the optimiser to recognise that the register is unused++{-|+Like `manyN`, excepts discards its results.++@since 0.1.0.0+-}+skipManyN :: Int -> Parser a -> Parser ()+skipManyN n p = foldr (const (p *>)) (skipMany p) [1..n]++{-|+Like `some`, excepts discards its results.++@since 0.1.0.0+-}+skipSome :: Parser a -> Parser ()+skipSome = skipManyN 1++{-|+@sepBy p sep@ parses __zero__ or more occurrences of @p@, separated by @sep@.+Returns a list of values returned by @p@.++@since 0.1.0.0+-}+sepBy :: Parser a -> Parser b -> Parser [a]+sepBy p sep = option EMPTY (sepBy1 p sep)++{-|+@sepBy1 p sep@ parses __one__ or more occurrences of @p@, separated by @sep@.+Returns a list of values returned by @p@.++@since 0.1.0.0+-}+sepBy1 :: Parser a -> Parser b -> Parser [a]+sepBy1 p sep = p <:> many (sep *> p)++{-|+@endBy p sep@ parses __zero__ or more occurrences of @p@, separated and ended by @sep@.+Returns a list of values returned by @p@.++@since 0.1.0.0+-}+endBy :: Parser a -> Parser b -> Parser [a]+endBy p sep = many (p <* sep)++{-|+@endBy1 p sep@ parses __one__ or more occurrences of @p@, separated and ended by @sep@.+Returns a list of values returned by @p@.++@since 0.1.0.0+-}+endBy1 :: Parser a -> Parser b -> Parser [a]+endBy1 p sep = some (p <* sep)++{-|+@sepEndBy p sep@ parses __zero__ or more occurrences of @p@, separated and /optionally/ ended by @sep@.+Returns a list of values returned by @p@.++@since 0.1.0.0+-}+sepEndBy :: Parser a -> Parser b -> Parser [a]+sepEndBy p sep = option EMPTY (sepEndBy1 p sep)++{-|+@sepEndBy1 p sep@ parses __one__ or more occurrences of @p@, separated and /optionally/ ended by @sep@.+Returns a list of values returned by @p@.++@since 0.1.0.0+-}+sepEndBy1 :: Parser a -> Parser b -> Parser [a]+sepEndBy1 p sep = newRegister_ ID $ \acc ->+  let go = modify acc (COMPOSE_H (FLIP_H COMPOSE) CONS <$> p)+         *> (sep *> (go <|> get acc) <|> get acc)+  in go <*> pure EMPTY++{-sepEndBy1 :: Parser a -> Parser b -> Parser [a]+sepEndBy1 p sep =+  let seb1 = p <**> (sep *> (FLIP_H CONS <$> option EMPTY seb1)+                 <|> pure (APP_H (FLIP_H CONS) EMPTY))+  in seb1-}
+ src/ghc/Parsley/InputExtras.hs view
@@ -0,0 +1,22 @@+{-|+Module      : Parsley.InputExtras+Description : Extra datatypes that can be used to wrap input+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This module exports the `Stream` datatype, which can be used as an infinite input to a+parser. It also exports `Text16` and `CharList`, which can be wrapped around+@Text@ and @String@ respectively to force them to be parsed faithfully to their+representation. By default, @String@s are converted to character arrays for performance,+but `CharList` will be uncoverted. On the other hand, `Text16` enables a faster, but+potentially less general processing of @Text@ data by assuming all characters+are exactly 16-bits in width.++@since 0.1.0.0+-}+module Parsley.InputExtras (+    module Parsley.Internal+  ) where++import Parsley.Internal (Text16(..), CharList(..), Stream(..), nomore)
+ src/ghc/Parsley/Internal.hs view
@@ -0,0 +1,36 @@+{-# 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))
+ src/ghc/Parsley/Internal/Backend.hs view
@@ -0,0 +1,16 @@+{-|+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)
+ src/ghc/Parsley/Internal/Backend/CodeGenerator.hs view
@@ -0,0 +1,192 @@+{-# 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))
+ src/ghc/Parsley/Internal/Backend/InstructionAnalyser.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE MultiParamTypeClasses,+             TypeFamilies,+             UndecidableInstances #-}+module Parsley.Internal.Backend.InstructionAnalyser (coinsNeeded, relevancy) 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
+ src/ghc/Parsley/Internal/Backend/Machine/Identifiers.hs view
@@ -0,0 +1,30 @@+{-# 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
+ src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs view
@@ -0,0 +1,141 @@+{-# 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"
+ src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs view
@@ -0,0 +1,32 @@+{-# 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)
+ src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs view
@@ -0,0 +1,50 @@+{-# 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
+ src/ghc/Parsley/Internal/Backend/Optimiser.hs view
@@ -0,0 +1,17 @@+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
+ src/ghc/Parsley/Internal/Common.hs view
@@ -0,0 +1,22 @@+{-|+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
+ src/ghc/Parsley/Internal/Common/Fresh.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FunctionalDependencies,+             GeneralisedNewtypeDeriving,+             DerivingStrategies,+             UndecidableInstances #-}+module Parsley.Internal.Common.Fresh (+    VFreshT, HFreshT, VFresh, HFresh,+    runFreshT, runFresh,+    evalFreshT, evalFresh,+    execFreshT, execFresh,+    MonadFresh(..), construct, mapVFreshT+  ) 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
+ src/ghc/Parsley/Internal/Common/Indexed.hs view
@@ -0,0 +1,98 @@+{-# 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}
+ src/ghc/Parsley/Internal/Common/Queue.hs view
@@ -0,0 +1,41 @@+{-# 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
+ src/ghc/Parsley/Internal/Common/State.hs view
@@ -0,0 +1,87 @@+{-# 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)
+ src/ghc/Parsley/Internal/Common/Utils.hs view
@@ -0,0 +1,116 @@+{-# 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)
+ src/ghc/Parsley/Internal/Common/Vec.hs view
@@ -0,0 +1,23 @@+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
+ src/ghc/Parsley/Internal/Core.hs view
@@ -0,0 +1,19 @@+{-|+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)
+ src/ghc/Parsley/Internal/Core/CombinatorAST.hs view
@@ -0,0 +1,132 @@+{-# 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')
+ src/ghc/Parsley/Internal/Core/Defunc.hs view
@@ -0,0 +1,143 @@+{-# 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++{-|+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+  _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 (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 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  = [|| $$(genDefunc 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 _ = "x"
+ src/ghc/Parsley/Internal/Core/Identifiers.hs view
@@ -0,0 +1,44 @@+{-# 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
+ src/ghc/Parsley/Internal/Core/InputTypes.hs view
@@ -0,0 +1,38 @@+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
+ src/ghc/Parsley/Internal/Core/Primitives.hs view
@@ -0,0 +1,247 @@+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)))
+ src/ghc/Parsley/Internal/Frontend.hs view
@@ -0,0 +1,14 @@+{-|+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)
+ src/ghc/Parsley/Internal/Frontend/CombinatorAnalyser.hs view
@@ -0,0 +1,241 @@+{-# 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+-}
+ src/ghc/Parsley/Internal/Frontend/Compiler.hs view
@@ -0,0 +1,179 @@+{-# 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))
+ src/ghc/Parsley/Internal/Frontend/Dependencies.hs view
@@ -0,0 +1,164 @@+{-# 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 σ)
+ src/ghc/Parsley/Internal/Frontend/Optimiser.hs view
@@ -0,0 +1,177 @@+{-# 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 ({-([either f g])-}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 ()||]-}
+ src/ghc/Parsley/Internal/Trace.hs view
@@ -0,0 +1,20 @@+{-# 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
+ src/ghc/Parsley/Internal/Verbose.hs view
@@ -0,0 +1,29 @@+{-# 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
+ src/ghc/Parsley/Precedence.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE AllowAmbiguousTypes,+             MultiParamTypeClasses #-}+{-|+Module      : Parsley.Precedence+Description : The precedence parser functionality+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This module exposes the required machinery for parsing expressions given by a precedence+table. Unlike those found in [parser-combinators](https://hackage.haskell.org/package/parser-combinators-1.3.0/docs/Control-Monad-Combinators-Expr.html)+or [parsec](https://hackage.haskell.org/package/parsec-3.1.14.0/docs/Text-Parsec-Expr.html), this+implementation allows the precedence layers to change type in the table.++@since 0.1.0.0+-}+module Parsley.Precedence (module Parsley.Precedence) where++import Prelude hiding      ((<$>))+import Parsley.Alternative (choice)+import Parsley.Applicative ((<$>))+import Parsley.Fold        (chainPre, chainPost, chainl1', chainr1')+import Parsley.Internal    (WQ, Parser, Defunc(BLACK, ID))++{-|+This combinator will construct and expression parser will provided with a table of precedence along+with a terminal atom.++@since 0.1.0.0+-}+precedence :: Prec a b -> Parser a -> Parser b+precedence NoLevel atom = atom+precedence (Level lvl lvls) atom = precedence lvls (level lvl atom)+  where+    level (InfixL ops wrap) atom  = chainl1' wrap atom (choice ops)+    level (InfixR ops wrap) atom  = chainr1' wrap atom (choice ops)+    level (Prefix ops wrap) atom  = chainPre (choice ops) (wrap <$> atom)+    level (Postfix ops wrap) atom = chainPost (wrap <$> atom) (choice ops)++{-|+A simplified version of `precedence` that does not use the heterogeneous list `Prec`, but+instead requires all layers of the table to have the same type.++@since 0.1.0.0+-}+monolith :: [Level a a] -> Prec a a+monolith = foldr Level NoLevel++{-|+A heterogeneous list that represents a precedence table so that @Prec a b@ transforms the type @a@+into @b@ via various layers of operators.++@since 0.1.0.0+-}+data Prec a b where+  NoLevel :: Prec a a+  Level :: Level a b -> Prec b c -> Prec a c++{-|+This datatype represents levels of the precedence table `Prec`, where each constructor+takes many parsers of the same level and fixity.++@since 0.1.0.0+-}+data Level a b = InfixL  [Parser (b -> a -> b)] (Defunc (a -> b)) -- ^ left-associative infix operators+               | InfixR  [Parser (a -> b -> b)] (Defunc (a -> b)) -- ^ right-associative infix operators+               | Prefix  [Parser (b -> b)]      (Defunc (a -> b)) -- ^ prefix unary operators+               | Postfix [Parser (b -> b)]      (Defunc (a -> b)) -- ^ postfix unary operators++{-|+This class provides a way of working with the `Level` datatype without needing to+provide wrappers, or not providing `Defunc` arguments.++@since 0.1.0.0+-}+class Monolith a b c where+  -- | Used to construct a precedence level of infix left-associative operators+  infixL  :: [Parser (b -> a -> b)] -> c+  -- | Used to construct a precedence level of infix right-associative operators+  infixR  :: [Parser (a -> b -> b)] -> c+  -- | Used to construct a precedence level of prefix operators+  prefix  :: [Parser (b -> b)]      -> c+  -- | Used to construct a precedence level of postfix operators+  postfix :: [Parser (b -> b)]      -> c++{-|+This instance is used to handle monolithic types where the input and output are the same,+it does not require the wrapping function to be provided.++@since 0.1.0.0+-}+instance x ~ a => Monolith x a (Level a a) where+  infixL  = flip InfixL ID+  infixR  = flip InfixR ID+  prefix  = flip Prefix ID+  postfix = flip Postfix ID++{-|+This instance is used to handle non-monolithic types: i.e. where the input and output types of+a level differ.++@since 0.1.0.0+-}+instance {-# INCOHERENT #-} x ~ (WQ (a -> b) -> Level a b) => Monolith a b x where+  infixL  ops = InfixL ops . BLACK+  infixR  ops = InfixR ops . BLACK+  prefix  ops = Prefix ops . BLACK+  postfix ops = Postfix ops . BLACK
+ src/ghc/Parsley/Register.hs view
@@ -0,0 +1,153 @@+{-|+Module      : Parsley.Register+Description : The register combinators+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++This module exposes combinators designed to work with /registers/. These are small pieces of state+that are carried through the parsing process. They can be used, for example, to perform indentation+sensitive parsing. In fact, they are a flexible replacement for the monadic combinators, in conjunction+with the "Parsley.Selective" combinators. In particular, the `bind` combinator implements a limited form+of the @(>>=)@ operation, where the structure of the resulting parser will still be statically+determinable. Registers paired with "Parsley.Selective" combinators are Turing-Compete.++@since 0.1.0.0+-}+module Parsley.Register (+    Reg, newRegister, get, put,+    newRegister_,+    put_,+    gets, gets_,+    modify, modify_,+    move, swap,+    bind, local, rollback,+    for+  ) where++import Prelude hiding      (pure, (<*>), (*>), (<*))+import Parsley.Alternative (empty, (<|>))+import Parsley.Applicative (pure, (<*>), (*>), (<*))+import Parsley.Internal    (Parser, ParserOps, Reg, newRegister, get, put)+import Parsley.Selective   (when, while)++{-|+Like `newRegister`, except the initial value of the register is seeded from a pure value as opposed+to the result of a parser.++@since 0.1.0.0+-}+newRegister_ :: ParserOps rep => rep a -> (forall r. Reg r a -> Parser b) -> Parser b+newRegister_ x = newRegister (pure x)++{-|+Like `put`, except the new value of the register is a pure value as opposed to the result of a parser.++@since 0.1.0.0+-}+put_ :: ParserOps rep => Reg r a -> rep a -> Parser ()+put_ r = put r . pure++{-|+@gets reg p@ first parses @p@ to get as a result, function @f@. Then, taking into account any changes+made during @p@, the value is fetched from @reg@ and applied to @f@.++@since 0.1.0.0+-}+gets :: Reg r a -> Parser (a -> b) -> Parser b+gets r p = p <*> get r++{-|+Like `gets`, except the adapter function is a pure argument as opposed to the result of a parser.++@since 0.1.0.0+-}+gets_ :: ParserOps rep => Reg r a -> rep (a -> b) -> Parser b+gets_ r = gets r . pure++{-|+@modify reg p@ first parses @p@ to collect the function @f@, then taking into account any changes+made during @f@, the value in @reg@ is modified using the function @f@ and put back into it.++@since 0.1.0.0+-}+modify :: Reg r a -> Parser (a -> a) -> Parser ()+modify r p = put r (gets r p)++{-|+Like `modify`, except the modification function is a pure argument as opposed to the result of a parser.++@since 0.1.0.0+-}+modify_ :: ParserOps rep => Reg r a -> rep (a -> a) -> Parser ()+modify_ r = modify r . pure++{-|+@move dst src@ takes the value stored in @src@ and additionally stores it into @dst@.++@since 0.1.0.0+-}+move :: Reg r1 a -> Reg r2 a -> Parser ()+move dst src = put dst (get src)++{-|+This combinator uses registers to emulate a restricted form of @(`>>=`)@: in a traditional monadic+setting, this would be considered to be the implementation:++> bind p f = p >>= f . pure++Essentially, the result of @p@ is available to be summoned purely as many times as needed. However,+it cannot be used to dynamically create structure: the selective combinators can be used to provide+that functionality partially.++@since 0.1.0.0+-}+bind :: Parser a -> (Parser a -> Parser b) -> Parser b+bind p f = newRegister p (f . get)++{-|+@local reg p q@ first parses @p@ and stores its value in @reg@ for the /duration/ of parsing @q@.+If @q@ succeeds, @reg@ will be restored to its original state /before/ @p@ was parsed.++@since 0.1.0.0+-}+local :: Reg r a -> Parser a -> Parser b -> Parser b+local r p q = bind (get r) $ \x -> put r p+                                *> q+                                <* put r x++{-|+This combinator will swap the values contained in two registers.++@since 0.1.0.0+-}+swap :: Reg r1 a -> Reg r2 a -> Parser ()+swap r1 r2 = bind (get r1) $ \x -> move r1 r2+                                *> put r2 x++{-|+@rollback reg p@ will perform @p@ and if it fails without consuming input, @reg@ will be restored+to its original state from /before/ @p@ was parsed, and the combinator will fail. If @p@ succeeds+the state in @reg@ will not be restored to an old version.++@since 0.1.0.0+-}+rollback :: Reg r a -> Parser b -> Parser b+rollback r p = bind (get r) $ \x -> p <|> put r x *> empty++{-|+This combinator is like a traditional imperative-style @for@-loop. Given @for init cond step body@,+@init@ is first parsed to initialise a register called @i@; the parser @cond@ is then performed to+check that the value in @i@ adheres to the predicate it returns; if so, then the @body@ is parsed,+@step@ modifies the state in @i@, and then the process repeats from @cond@ again. When @cond@ returns+@False@ for the predicate applied to @i@'s state, the loop terminates gracefully. If any component+of this parser fails the loop will fail.++@since 0.1.0.0+-}+for :: Parser a -> Parser (a -> Bool) -> Parser (a -> a) -> Parser () -> Parser ()+for init cond step body =+  newRegister init $ \i ->+    let cond' :: Parser Bool+        cond' = gets i cond+    in when cond' (while (body *> modify i step *> cond'))
+ src/ghc/Parsley/Selective.hs view
@@ -0,0 +1,164 @@+{-|+Module      : Parsley.Selective+Description : The @Selective@ combinators+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : stable++A version of the @Selective@ combinators as described in [/Selective Applicative Functors/+(Mokhov et al. 2019)](https://dl.acm.org/doi/10.1145/3341694).++Like the @Applicative@ and @Alternative@ combinators, these cannot be properly described by the+@Selective@ typeclass, since the API relies on Template Haskell code being used by @Applicative@.++@since 0.1.0.0+-}+module Parsley.Selective (+    branch, select,+    (>??>), filteredBy, (>?>),+    predicate, (<?:>),+    conditional, match, (||=),+    when, while,+    fromMaybeP+  ) where++import Prelude hiding             (pure, (<$>))+import Data.Function              (fix)+import Language.Haskell.TH.Syntax (Lift(..))+import Parsley.Alternative        (empty)+import Parsley.Applicative        (pure, (<$>), liftA2, unit, constp)+import Parsley.Internal           (makeQ, Code, Parser, Defunc(ID, EQ_H), ParserOps, conditional, branch)++{-|+Similar to `branch`, except the given branch is only executed on a @Left@ returned.++> select p q = branch p q (pure id)++@since 0.1.0.0+-}+select :: Parser (Either a b) -> Parser (a -> b) -> Parser b+select p q = branch p q (pure ID)++-- Filter Combinators+{-|+This combinator is used for filtering. Given @px >??> pf@, if @px@ succeeds, then @pf@ will be+attempted too. Then the result of @px@ is given to @pf@'s. If the function returns true then the+parser succeeds and returns the result of @px@, otherwise it will fail.++@since 0.1.0.0+-}+infixl 4 >??>+(>??>) :: Parser a -> Parser (a -> Bool) -> Parser a+px >??> pf = select (liftA2 (makeQ g qg) pf px) empty+  where+    g :: (a -> Bool) -> a -> Either () a+    g f x = if f x then Right x else Left ()+    qg :: Code ((a -> Bool) -> a -> Either () a)+    qg = [||\f x -> if f x then Right x else Left ()||]++{-|+An alias for @(`>?>`)@.++@since 0.1.0.0+-}+filteredBy :: ParserOps rep => Parser a -> rep (a -> Bool) -> Parser a+filteredBy p f = p >??> pure f++{-|+This combinator is used for filtering, similar to @(`>??>`)@ except the predicate is given without+parsing anything.++> px >?> f = px >??> pure f++@since 0.1.0.0+-}+infixl 4 >?>+(>?>) :: ParserOps rep => Parser a -> rep (a -> Bool) -> Parser a+(>?>) = filteredBy++-- Conditional Combinators+{-|+Similar to an @if@ statement: @predicate f p t e@ first parses @p@ and collects its result @x@.+If @f x@ is @True@ then @t@ is parsed, else @e@ is parsed.++@since 0.1.0.0+-}+predicate :: ParserOps rep => rep (a -> Bool) -> Parser a -> Parser b -> Parser b -> Parser b+predicate cond p t e = conditional [(cond, t)] p e++{-|+A \"ternary\" combinator, essentially `predicate` given the identity function.++@since 0.1.0.0+-}+infixl 4 <?:>+(<?:>) :: Parser Bool -> (Parser a, Parser a) -> Parser a+cond <?:> (p, q) = predicate ID cond p q++-- Match Combinators+{-|+The `match` combinator can be thought of as a restricted form of @(>>=)@, where there is a fixed+domain on the valid outputs of the second argument.++More concretely, @match dom p f def@ first parses @p@, and, if its result is an element of the list+@dom@, its result is applied to the function @f@ and the resulting parser is executed. If the result+was not in @dom@, then @def@ will be executed.++Note: To eliminate the dynamic nature of the operation, every possible outcome of the parser is+enumerated and tried in turn.++@since 0.1.0.0+-}+match :: (Eq a, Lift a)+      => [a]             -- ^ The domain of the function given as the third argument+      -> Parser a        -- ^ The parser whose result will be given to the function+      -> (a -> Parser b) -- ^ A function uses to generate the parser to execute+      -> Parser b        -- ^ A parser to execute if the result is not in the domain of the function+      -> Parser b+match vs p f = conditional (map (\v -> (EQ_H (makeQ v [||v||]), f v)) vs) p++{-|+This combinator, known as @sbind@ in the literature, is best avoided for efficiency sake. It is+built on `match`, but where the domain of the function is /all/ of the possible values of the+datatype. This means the type must be finite, or else this combinator would never terminate.++The problem with the combinator is not so much that it takes linear time to take the right branch+(as opposed to monadic @(>>=)@) but that it generates a /massive/ amount of code when the datatype+gets too big. For instance, using it for `Char` would generate a 66535-way case split!++The role this combinator fulfils is the branching behaviour that monadic operations can provide.+For the persistence or duplication of data that monads can provide, `Parsley.Register.bind` is a much better+alternative.++@since 0.1.0.0+-}+infixl 1 ||=+(||=) :: (Enum a, Bounded a, Eq a, Lift a) => Parser a -> (a -> Parser b) -> Parser b+p ||= f = match [minBound..maxBound] p f empty++-- Composite Combinators+{-|+This combinator will only execute its second argument if the first one returned @True@.++@since 0.1.0.0+-}+when :: Parser Bool -> Parser () -> Parser ()+when p q = p <?:> (q, unit)++{-|+The fixed-point of the `when` combinator: it will continuously parse its argument until either it+fails (in which case it fails), or until it returns @False@.++@since 0.1.0.0+-}+while :: Parser Bool -> Parser ()+while x = fix (when x)++{-|+Given @fromMaybeP p def@, if @p@ returns a @Nothing@ then @def@ is executed, otherwise the result+of @p@ will be returned with the @Just@ removed.++@since 0.1.0.0+-}+fromMaybeP :: Parser (Maybe a) -> Parser a -> Parser a+fromMaybeP pm px = select (makeQ (maybe (Left ()) Right) [||maybe (Left ()) Right||] <$> pm) (constp px)