packages feed

parsley-core 1.0.1.1 → 1.1.0.0

raw patch · 13 files changed

+107/−70 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- Parsley.Internal.Backend.Machine: [BOTTOM] :: Defunc a
- Parsley.Internal.Backend.Machine: [FREEVAR] :: Code a -> Defunc a
- Parsley.Internal.Backend.Machine: [OFFSET] :: Code (Rep o) -> Defunc o
- Parsley.Internal.Backend.Machine: [USER] :: Defunc a -> Defunc a
- Parsley.Internal.Backend.Machine.Defunc: [FREEVAR] :: Code a -> Defunc a
- Parsley.Internal.Backend.Machine.Defunc: [USER] :: Defunc a -> Defunc a
- Parsley.Internal.Backend.Machine.Defunc: genDefunc2 :: Defunc (a -> b -> c) -> Code a -> Code b -> Code c
- Parsley.Internal.Backend.Machine.Instructions: pattern App :: Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : ((x -> y) : xs)) n r a
- Parsley.Internal.Backend.Machine.Instructions: pattern Fmap :: Defunc (x -> y) -> Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : xs) n r a
- Parsley.Internal.Backend.Machine.Instructions: 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
+ Parsley.Internal.Backend.Machine: user :: Defunc a -> Defunc a
+ Parsley.Internal.Backend.Machine.Defunc: [LAM] :: Lam a -> Defunc a
+ Parsley.Internal.Backend.Machine.Defunc: pattern FREEVAR :: Code a -> Defunc a
+ Parsley.Internal.Backend.Machine.Defunc: pattern NormLam :: Lam a -> Defunc a
+ Parsley.Internal.Backend.Machine.Defunc: user :: Defunc a -> Defunc a
+ Parsley.Internal.Backend.Machine.Instructions: _App :: Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : ((x -> y) : xs)) n r a
+ Parsley.Internal.Backend.Machine.Instructions: _Fmap :: Defunc (x -> y) -> Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : xs) n r a
+ Parsley.Internal.Backend.Machine.Instructions: _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
+ Parsley.Internal.Core.Lam: instance GHC.Show.Show (Parsley.Internal.Core.Lam.Lam a)
+ Parsley.Internal.Core.Lam: normalise :: Lam a -> Lam a

Files

ChangeLog.md view
@@ -13,3 +13,8 @@ ## 1.0.1.1 -- 2021-06-27  * Added input factoring to `try p <|> q` and also forms with `f <$> try p <|> q` and `try p $> x <|> q`++## 1.1.0.0 -- 2021-07-01++* Switched both backends to make use of `Lam` instead of `Core.Defunc`, reducing burden on GHC+* Added duplication avoidance optimisation when value to be duplicated is `Lam.Var True`
parsley-core.cabal view
@@ -5,7 +5,7 @@ --                   | +------- breaking internal API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.0.1.1+version:             1.1.0.0 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         This package contains the internals of the @parsley@ package.                      .
src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs view
@@ -20,7 +20,7 @@ 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.Defunc       (Defunc(SAME), user) import Parsley.Internal.Backend.Machine.Identifiers import Parsley.Internal.Backend.Machine.InputOps     (InputPrep(..), PositionOps) import Parsley.Internal.Backend.Machine.Instructions
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs view
@@ -1,49 +1,56 @@-{-# LANGUAGE StandaloneKindSignatures, TypeApplications #-}+{-# LANGUAGE PatternSynonyms, StandaloneKindSignatures, TypeApplications, ViewPatterns #-} 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)+import Parsley.Internal.Core.Lam                 (Lam, normaliseGen, normalise) -import qualified Parsley.Internal.Core.Defunc as Core (Defunc, ap, genDefunc, genDefunc1, genDefunc2, unsafeBLACK)+import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm)+import qualified Parsley.Internal.Core.Lam    as Lam  (Lam(..))  data Defunc a where-  USER    :: Core.Defunc a -> Defunc a+  LAM     :: Lam a -> Defunc a   BOTTOM  :: Defunc a   SAME    :: PositionOps o => Defunc (o -> o -> Bool)-  FREEVAR :: Code a -> Defunc a   OFFSET  :: Code (Rep o) -> Defunc o +user :: Core.Defunc a -> Defunc a+user = LAM . Core.lamTerm+ ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c-ap2 f@SAME (OFFSET o1) (OFFSET o2) = USER (Core.unsafeBLACK (apSame f o1 o2))+ap2 f@SAME (OFFSET o1) (OFFSET o2) = LAM (Lam.Var False (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))+ap2 f x y = LAM (Lam.App (Lam.App (seal f) (seal x)) (seal y))   where-    seal :: Defunc a -> Core.Defunc a-    seal (USER x) = x-    seal x        = Core.unsafeBLACK (genDefunc x)+    seal :: Defunc a -> Lam a+    seal (LAM x) = x+    seal x        = Lam.Var False (genDefunc x)  genDefunc :: Defunc a -> Code a-genDefunc (USER x)    = Core.genDefunc x+genDefunc (LAM x)    = normaliseGen 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 ||]+genDefunc1 (LAM f) qx = normaliseGen (Lam.App f (Lam.Var True 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 ||]+pattern NormLam :: Lam a -> Defunc a+pattern NormLam t <- LAM (normalise -> t) +pattern FREEVAR :: Code a -> Defunc a+pattern FREEVAR v <- NormLam (Lam.Var True v)+  where+    FREEVAR v = LAM (Lam.Var True v)+ instance Show (Defunc a) where-  show (USER x) = show x+  show (LAM x) = show x   show SAME = "same"   show BOTTOM = "[[irrelevant]]"   show (FREEVAR _) = "x"
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ImplicitParams,              MultiWayIf,+             PatternSynonyms,              RecordWildCards,              TypeApplications,              UnboxedTuples #-}@@ -11,7 +12,7 @@ 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.Defunc        (Defunc(OFFSET), pattern FREEVAR, 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)@@ -28,7 +29,7 @@  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+  do let !(# next, more, offset #) = $$input      $$(let ?ops = InputOps [||more||] [||next||]         in letRec fs              nameLet
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs view
@@ -5,6 +5,7 @@              CPP,              ImplicitParams,              MagicHash,+             PatternSynonyms,              RecordWildCards,              TypeApplications #-} module Parsley.Internal.Backend.Machine.Ops (module Parsley.Internal.Backend.Machine.Ops) where@@ -20,7 +21,7 @@ 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.Defunc       (Defunc(OFFSET), genDefunc, pattern FREEVAR) import Parsley.Internal.Backend.Machine.Identifiers  (MVar, ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps     (PositionOps(..), LogOps(..), InputOps, next, more) import Parsley.Internal.Backend.Machine.InputRep     (Rep{-, representationTypes-})
src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs view
@@ -20,7 +20,7 @@ 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.Defunc       (Defunc(SAME), user) import Parsley.Internal.Backend.Machine.Identifiers import Parsley.Internal.Backend.Machine.InputOps     (InputPrep(..), PositionOps) import Parsley.Internal.Backend.Machine.InputRep     (Rep)
src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs view
@@ -1,39 +1,46 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-} 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)+import Parsley.Internal.Core.Lam                 (Lam, normaliseGen, normalise) -import qualified Parsley.Internal.Core.Defunc as Core (Defunc, ap, genDefunc, genDefunc1, genDefunc2, unsafeBLACK)+import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm)+import qualified Parsley.Internal.Core.Lam    as Lam  (Lam(..))  data Defunc a where-  USER    :: Core.Defunc a -> Defunc a+  LAM     :: Lam a -> Defunc a   BOTTOM  :: Defunc a   SAME    :: PositionOps o => Defunc (o -> o -> Bool)-  FREEVAR :: Code a -> Defunc a +user :: Core.Defunc a -> Defunc a+user = LAM . Core.lamTerm+ 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))+ap2 f x y = LAM (Lam.App (Lam.App (seal f) (seal x)) (seal y))   where-    seal :: Defunc a -> Core.Defunc a-    seal (USER x) = x-    seal x        = Core.unsafeBLACK (genDefunc x)+    seal :: Defunc a -> Lam a+    seal (LAM x) = x+    seal x       = Lam.Var False (genDefunc x)  genDefunc :: Defunc a -> Code a-genDefunc (USER x)    = Core.genDefunc x-genDefunc BOTTOM      = [||undefined||]-genDefunc SAME        = same-genDefunc (FREEVAR x) = x+genDefunc (LAM x) = normaliseGen x+genDefunc BOTTOM  = [||undefined||]+genDefunc SAME    = same  genDefunc1 :: Defunc (a -> b) -> Code a -> Code b-genDefunc1 (USER f) qx = Core.genDefunc1 f qx-genDefunc1 f qx        = [|| $$(genDefunc f) $$qx ||]+genDefunc1 (LAM f) qx = normaliseGen (Lam.App f (Lam.Var True 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 ||]+pattern NormLam :: Lam a -> Defunc a+pattern NormLam t <- LAM (normalise -> t) +pattern FREEVAR :: Code a -> Defunc a+pattern FREEVAR v <- NormLam (Lam.Var True v)+  where+    FREEVAR v = LAM (Lam.Var True v)+ instance Show (Defunc a) where-  show (USER x) = show x+  show (LAM x) = show x   show SAME = "same"   show BOTTOM = "[[irrelevant]]"-  show (FREEVAR _) = "x"
src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ImplicitParams,              MultiWayIf,+             PatternSynonyms,              RecordWildCards,              TypeApplications #-} module Parsley.Internal.Backend.Machine.Eval (eval) where@@ -10,7 +11,7 @@ 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.Defunc        (Defunc, pattern 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(..))
src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs view
@@ -5,6 +5,7 @@              CPP,              ImplicitParams,              MagicHash,+             PatternSynonyms,              RecordWildCards,              TypeApplications #-} module Parsley.Internal.Backend.Machine.Ops (module Parsley.Internal.Backend.Machine.Ops) where@@ -16,7 +17,7 @@ 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.Defunc       (Defunc, pattern 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-})@@ -52,6 +53,7 @@  {- General Operations -} dup :: Defunc x -> (Defunc x -> Code r) -> Code r+dup (FREEVAR x) k = k (FREEVAR x) dup x k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]  {-# INLINE returnST #-}
src/ghc/Parsley/Internal/Backend/CodeGenerator.hs view
@@ -5,8 +5,8 @@ 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,+import Parsley.Internal.Backend.Machine              (Defunc(SAME), user, LetBinding, makeLetBinding, Instr(..),+                                                      _Fmap, _App, _Modify, _Get, _Put, _Make, _If,                                                       addCoins, refundCoins, drainCoins, PositionOps,                                                       IMVar, IΦVar, IΣVar, MVar(..), ΦVar(..), ΣVar(..)) import Parsley.Internal.Backend.InstructionAnalyser  (coinsNeeded)@@ -51,7 +51,7 @@ 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))))))+parsecHandler k = In4 (Tell (In4 (Lift2 SAME (In4 (_If k (In4 Empt))))))  altNoCutCompile :: CodeGen o a y -> CodeGen o a x                 -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) (o : xs) (Succ n) r a)@@ -74,9 +74,9 @@ chainPreCompile op p preOp preP m =   do μ <- askM      σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (Fmap (USER (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))-     pc <- freshM (runCodeGen p (In4 (App m)))-     return $! In4 (Push (USER ID) (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preP pc)))))))))+     opc <- freshM (runCodeGen op (In4 (_Fmap (user (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))+     pc <- freshM (runCodeGen p (In4 (_App m)))+     return $! In4 (Push (user ID) (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preP pc)))))))))  chainPostCompile :: PositionOps o => CodeGen o a x -> CodeGen o a (x -> x)                  -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a)@@ -89,10 +89,10 @@      freshM (runCodeGen p (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preM m)))))))))  deep :: PositionOps o => Combinator (Cofree Combinator (CodeGen o a)) x -> Maybe (CodeGen o a x)-deep (f :<$>: (p :< _)) = Just $ CodeGen $ \m -> runCodeGen p (In4 (Fmap (USER f) m))+deep (f :<$>: (p :< _)) = Just $ CodeGen $ \m -> runCodeGen p (In4 (_Fmap (user f) m)) deep (TryOrElse p q) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) id-deep ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) (In4 . Pop . In4 . Push (USER x))-deep ((_ :< (f :<$>: (_ :< Try (p :< _)))) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) (In4 . Fmap (USER f))+deep ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) (In4 . Pop . In4 . Push (user x))+deep ((_ :< (f :<$>: (_ :< Try (p :< _)))) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) (In4 . _Fmap (user f)) deep (MetaCombinator RequiresCut (_ :< ((p :< _) :<|>: (q :< _)))) = Just $ CodeGen $ \m ->   do (binder, φ) <- makeΦ m      pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))@@ -107,9 +107,9 @@ addCoinsNeeded = coinsNeeded >>= addCoins  shallow :: 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)-shallow (Pure x)      m = do return $! In4 (Push (USER x) m)-shallow (Satisfy p)   m = do return $! In4 (Sat (USER p) m)-shallow (pf :<*>: px) m = do pxc <- runCodeGen px (In4 (App m)); runCodeGen pf pxc+shallow (Pure x)      m = do return $! In4 (Push (user x) m)+shallow (Satisfy p)   m = do return $! In4 (Sat (user p) m)+shallow (pf :<*>: px) m = do pxc <- runCodeGen px (In4 (_App m)); runCodeGen pf pxc shallow (p :*>: q)    m = do qc <- runCodeGen q m; runCodeGen p (In4 (Pop qc)) shallow (p :<*: q)    m = do qc <- runCodeGen q (In4 (Pop m)); runCodeGen p qc shallow Empty         _ = do return $! In4 Empt@@ -122,11 +122,11 @@   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)))))+     return $! In4 (Catch (addCoins (max (np - nm) 0) (In4 (Tell pc))) (In4 (Seek (In4 (Push (user UNIT) m))))) shallow (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 φ)))))+     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)@@ -135,15 +135,15 @@   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 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')))+     fmap binder (runCodeGen p (In4 (Choices (map user fs) qcs' defc'))) shallow (Let _ μ _)            m = do return $! tailCallOptimise μ m shallow (ChainPre op p)        m = do chainPreCompile op p addCoinsNeeded id m shallow (ChainPost p op)       m = do chainPostCompile p op addCoinsNeeded id m shallow (MakeRegister σ p q)   m = do qc <- runCodeGen q m; runCodeGen p (In4 (_Make σ qc)) shallow (GetRegister σ)        m = do return $! In4 (_Get σ m)-shallow (PutRegister σ p)      m = do runCodeGen p (In4 (_Put σ (In4 (Push (USER UNIT) m))))+shallow (PutRegister σ p)      m = do runCodeGen p (In4 (_Put σ (In4 (Push (user UNIT) m)))) shallow (Debug name p)         m = do fmap (In4 . LogEnter name) (runCodeGen p (In4 (Commit (In4 (LogExit name m))))) shallow (MetaCombinator Cut p) m = do runCodeGen p (addCoins (coinsNeeded m) m)
src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs view
@@ -8,7 +8,7 @@ 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.Backend.Machine.Defunc as Machine (Defunc, user) import Parsley.Internal.Core.Defunc            as Core    (Defunc(ID), pattern FLIP_H)  data Instr (o :: Type) (k :: [Type] -> Nat -> Type -> Type -> Type) (xs :: [Type]) (n :: Nat) (r :: Type) (a :: Type) where@@ -56,14 +56,14 @@ 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+_App :: Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : (x -> y) : xs) n r a+_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))+_Fmap :: Machine.Defunc (x -> y) -> Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : xs) n r a+_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 σ+_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@@ -75,8 +75,8 @@ _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+_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+_If t e = Choices [user ID] [t] e  instance IFunctor4 (Instr o) where   imap4 _ Ret                 = Ret
src/ghc/Parsley/Internal/Core/Lam.hs view
@@ -1,4 +1,4 @@-module Parsley.Internal.Core.Lam (normaliseGen, Lam(..)) where+module Parsley.Internal.Core.Lam (normaliseGen, normalise, Lam(..)) where  import Parsley.Internal.Common.Utils (Code) @@ -47,3 +47,16 @@  normaliseGen :: Lam a -> Code a normaliseGen = generate . normalise++instance Show (Lam a) where+  show = show' . normalise++show' :: Lam a -> String+show' (Abs f) = concat ["(\\x -> ", show (f (Var True undefined)), ")"]+show' (App f x) = concat ["(", show' f, " ", show' x, ")"]+show' (Var True _) = "x"+show' (Var False _) = "complex"+show' (If c t e) = concat ["if ", show' c, " then ", show t, " else ", show e]+show' (Let x f) = concat ["let x = ", show x, " in ", show' (f (Var True undefined))]+show' T = "True"+show' F = "False"