parsley-core 1.2.0.1 → 1.3.0.0

raw patch · 14 files changed

+100/−77 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• parsley-core.cabal +1/−1
• src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs +1/−1
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs +15/−10
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +6/−9
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs +3/−6
• src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs +1/−1
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs +15/−10
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs +4/−7
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs +3/−6
• src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +3/−3
• src/ghc/Parsley/Internal/Core.hs +1/−1
• src/ghc/Parsley/Internal/Core/Defunc.hs +23/−5
• src/ghc/Parsley/Internal/Core/Lam.hs +18/−17

@@ -34,3 +34,9 @@ ## 1.2.0.1 -- 2021-07-03  * Added Jump-Elision optimisation to the code generator.++## 1.3.0.0 -- 2021-07-03++* Improved the `Lam` reduction algorithm+* Preliminary support for `if true` reduction from `item` and `const True`+* Introduced `_if` and `ap` in `Machine.Defunc`, removed `genDefunc1`

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

@@ -20,7 +20,7 @@ import Data.ByteString                               (ByteString) import Data.Dependent.Map                            (DMap) import Data.Text                                     (Text)-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(SAME), user)+import Parsley.Internal.Backend.Machine.Defunc       (Defunc(SAME), user, userBool) import Parsley.Internal.Backend.Machine.Identifiers import Parsley.Internal.Backend.Machine.InputOps     (InputPrep(..), PositionOps) import Parsley.Internal.Backend.Machine.Instructions

@@ -7,7 +7,7 @@ import Parsley.Internal.Common.Utils             (Code) import Parsley.Internal.Core.Lam                 (Lam, normaliseGen, normalise) -import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm)+import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm, lamTermBool) import qualified Parsley.Internal.Core.Lam    as Lam  (Lam(..))  data Defunc a where@@ -19,27 +19,32 @@ user :: Core.Defunc a -> Defunc a user = LAM . Core.lamTerm +userBool :: Core.Defunc (a -> Bool) -> Defunc (a -> Bool)+userBool = LAM . Core.lamTermBool++ap :: Defunc (a -> b) -> Defunc a -> Defunc b+ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x))+ ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c 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 = LAM (Lam.App (Lam.App (seal f) (seal x)) (seal y))-  where-    seal :: Defunc a -> Lam a-    seal (LAM x) = x-    seal x        = Lam.Var False (genDefunc x)+ap2 f x y = ap (ap f x) y +_if :: Defunc Bool -> Code a -> Code a -> Code a+_if c t e = normaliseGen (Lam.If (unliftDefunc c) (Lam.Var False t) (Lam.Var False e))++unliftDefunc :: Defunc a -> Lam a+unliftDefunc (LAM x) = x+unliftDefunc x       = Lam.Var False (genDefunc x)+ genDefunc :: Defunc a -> Code a genDefunc (LAM x)    = normaliseGen x genDefunc BOTTOM      = [||undefined||] 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 (LAM f) qx = normaliseGen (Lam.App f (Lam.Var True qx))-genDefunc1 f qx       = [|| $$(genDefunc f) $$qx ||]  pattern NormLam :: Lam a -> Defunc a pattern NormLam t <- LAM (normalise -> t)

@@ -12,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(OFFSET), pattern FREEVAR, genDefunc, genDefunc1, ap2)+import Parsley.Internal.Backend.Machine.Defunc        (Defunc(OFFSET), pattern FREEVAR, genDefunc, ap, ap2, _if) import Parsley.Internal.Backend.Machine.Identifiers   (MVar(..), ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps      (InputDependant, PositionOps, LogOps, InputOps(InputOps)) import Parsley.Internal.Backend.Machine.InputRep      (Rep)@@ -96,10 +96,10 @@      | 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 Nothing mk γ = sat (ap p) mk (raise γ) γ     maybeEmitCheck (Just n) mk γ =-      --[|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (genDefunc1 p) mk [||bad||]) [||bad||] γ)||]-      emitLengthCheck n (sat (genDefunc1 p) mk (raise γ)) (raise γ) γ+      --[|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (ap p) mk [||bad||]) [||bad||] γ)||]+      emitLengthCheck n (sat (ap p) mk (raise γ)) (raise γ) γ  evalEmpt :: MachineMonad s o xs (Succ n) r a evalEmpt = return $! raise@@ -128,11 +128,8 @@   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 γ+    go x (f:fs) (mk:mks) def γ = _if (ap f x) (mk γ) (go x fs mks def γ)+    go _ _      _        def γ = def γ  evalIter :: RecBuilder o          => MVar Void -> Machine s o '[] One Void a -> Machine s o (o : xs) n r a

@@ -22,7 +22,7 @@ import Debug.Trace                                   (trace) import GHC.Exts                                      (Int(..), (-#)) import Language.Haskell.TH.Syntax                    (liftTyped)-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(OFFSET), genDefunc, pattern FREEVAR)+import Parsley.Internal.Backend.Machine.Defunc       (Defunc(OFFSET), genDefunc, _if, pattern FREEVAR) import Parsley.Internal.Backend.Machine.Identifiers  (MVar, ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps     (PositionOps(..), LogOps(..), InputOps, next, more) import Parsley.Internal.Backend.Machine.InputRep     (Rep{-, representationTypes-})@@ -51,11 +51,8 @@ type Ops o = (HandlerOps o, JoinBuilder o, RecBuilder o, PositionOps o, MarshalOps 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-  ||]+sat :: (?ops :: InputOps (Rep o)) => (Defunc Char -> Defunc Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))+sat p k bad γ@Γ{..} = next input $ \c input' -> let v = FREEVAR c in _if (p v) (k (γ {operands = Op v operands, input = input'})) bad  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 γ

@@ -20,7 +20,7 @@ import Data.ByteString                               (ByteString) import Data.Dependent.Map                            (DMap) import Data.Text                                     (Text)-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(SAME), user)+import Parsley.Internal.Backend.Machine.Defunc       (Defunc(SAME), user, userBool) import Parsley.Internal.Backend.Machine.Identifiers import Parsley.Internal.Backend.Machine.InputOps     (InputPrep(..), PositionOps) import Parsley.Internal.Backend.Machine.InputRep     (Rep)

@@ -5,7 +5,7 @@ import Parsley.Internal.Common.Utils             (Code) import Parsley.Internal.Core.Lam                 (Lam, normaliseGen, normalise) -import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm)+import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm, lamTermBool) import qualified Parsley.Internal.Core.Lam    as Lam  (Lam(..))  data Defunc a where@@ -16,21 +16,26 @@ user :: Core.Defunc a -> Defunc a user = LAM . Core.lamTerm +userBool :: Core.Defunc (a -> Bool) -> Defunc (a -> Bool)+userBool = LAM . Core.lamTermBool++ap :: Defunc (a -> b) -> Defunc a -> Defunc b+ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x))+ ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c-ap2 f x y = LAM (Lam.App (Lam.App (seal f) (seal x)) (seal y))-  where-    seal :: Defunc a -> Lam a-    seal (LAM x) = x-    seal x       = Lam.Var False (genDefunc x)+ap2 f x y = ap (ap f x) y +_if :: Defunc Bool -> Code a -> Code a -> Code a+_if c t e = normaliseGen (Lam.If (unliftDefunc c) (Lam.Var False t) (Lam.Var False e))++unliftDefunc :: Defunc a -> Lam a+unliftDefunc (LAM x) = x+unliftDefunc x       = Lam.Var False (genDefunc x)+ genDefunc :: Defunc a -> Code a genDefunc (LAM x) = normaliseGen x genDefunc BOTTOM  = [||undefined||] genDefunc SAME    = same--genDefunc1 :: Defunc (a -> b) -> Code a -> Code b-genDefunc1 (LAM f) qx = normaliseGen (Lam.App f (Lam.Var True qx))-genDefunc1 f qx       = [|| $$(genDefunc f) $$qx ||]  pattern NormLam :: Lam a -> Defunc a pattern NormLam t <- LAM (normalise -> t)

@@ -11,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, pattern FREEVAR, genDefunc, genDefunc1, ap2)+import Parsley.Internal.Backend.Machine.Defunc        (Defunc, pattern FREEVAR, genDefunc, ap, ap2, _if) import Parsley.Internal.Backend.Machine.Identifiers   (MVar(..), ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps      (InputDependant(..), PositionOps, BoxOps, LogOps, InputOps(InputOps)) import Parsley.Internal.Backend.Machine.Instructions  (Instr(..), MetaInstr(..), Access(..))@@ -94,9 +94,9 @@      | 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 Nothing mk γ = sat (ap p) mk (raise γ) γ     maybeEmitCheck (Just n) mk γ =-      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (genDefunc1 p) mk [||bad||]) [||bad||] γ)||]+      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (ap p) mk [||bad||]) [||bad||] γ)||]  evalEmpt :: (BoxOps o, HandlerOps o) => MachineMonad s o xs (Succ n) r a evalEmpt = return $! raise@@ -125,10 +125,7 @@   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 x (f:fs) (mk:mks) def γ = _if (ap f x) (mk γ) (go x fs mks def γ)     go _ _ _ def γ = def γ  evalIter :: (RecBuilder o, ReturnOps o, HandlerOps o)

@@ -17,7 +17,7 @@ import Data.Text                                     (Text) import Data.Void                                     (Void) import Debug.Trace                                   (trace)-import Parsley.Internal.Backend.Machine.Defunc       (Defunc, pattern FREEVAR, genDefunc)+import Parsley.Internal.Backend.Machine.Defunc       (Defunc, pattern FREEVAR, genDefunc, _if) 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-})@@ -38,11 +38,8 @@ 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-  ||]+sat :: (?ops :: InputOps o) => (Defunc Char -> Defunc Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))+sat p k bad γ@Γ{..} = next input $ \c input' -> let v = FREEVAR c in _if (p v) (k (γ {operands = Op v operands, input = input'})) bad  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 γ

@@ -5,7 +5,7 @@ import Data.Maybe                                    (isJust) import Data.Set                                      (Set, elems) import Control.Monad.Trans                           (lift)-import Parsley.Internal.Backend.Machine              (Defunc(SAME), user, LetBinding, makeLetBinding, Instr(..),+import Parsley.Internal.Backend.Machine              (Defunc(SAME), user, userBool, LetBinding, makeLetBinding, Instr(..),                                                       _Fmap, _App, _Modify, _Get, _Put, _Make, _If,                                                       addCoins, refundCoins, drainCoins, PositionOps,                                                       IMVar, IΦVar, IΣVar, MVar(..), ΦVar(..), ΣVar(..))@@ -108,7 +108,7 @@  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 (Satisfy p)   m = do return $! In4 (Sat (userBool 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@@ -135,7 +135,7 @@   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 userBool 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'))) shallow (Let _ μ _)            m = do return $! tailCallOptimise μ m

@@ -14,6 +14,6 @@     module Parsley.Internal.Core.InputTypes   ) where -import Parsley.Internal.Core.Defunc hiding (genDefunc, genDefunc1, genDefunc2, ap, unsafeBLACK, lamTerm, adaptLam)+import Parsley.Internal.Core.Defunc hiding (genDefunc, genDefunc1, genDefunc2, ap, unsafeBLACK, lamTerm, lamTermBool, adaptLam) import Parsley.Internal.Core.InputTypes import Parsley.Internal.Core.Primitives (Parser, ParserOps)

@@ -1,10 +1,19 @@-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PatternSynonyms, TypeApplications #-} module Parsley.Internal.Core.Defunc (module Parsley.Internal.Core.Defunc) where -import Language.Haskell.TH.Syntax (Lift(..))+--import Data.Typeable                 (Typeable, (:~:)(Refl), eqT)+import Language.Haskell.TH.Syntax    (Lift(..)) import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))-import Parsley.Internal.Core.Lam (normaliseGen, Lam(..))+import Parsley.Internal.Core.Lam     (normaliseGen, Lam(..)) +{-+  TODO: We should support Typeable in LIFTED to be more general, but I don't want changes to+  Defunc to impact back-compat in parsley itself. We should consider not exposing the datatype+  anymore, but exposing smart-constructors in Parsley.Defunctionalized.+  This will come in parsley-2.0.0.0.+-}++ {-| 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@@ -28,7 +37,7 @@   -- | 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+  LIFTED  :: (Show a, Lift a{-, Typeable 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@@ -114,11 +123,20 @@ ap :: Defunc (a -> b) -> Defunc a -> Defunc b ap f x = APP_H f x -lamTerm :: Defunc a -> Lam a+-- TODO: This is deprecated in favour of Typeable as of parsley 2.0.0.0+lamTermBool :: Defunc (a -> Bool) -> Lam (a -> Bool)+lamTermBool (APP_H CONST (LIFTED True)) = Abs (const T)+lamTermBool (APP_H CONST (LIFTED False)) = Abs (const F)+lamTermBool f = lamTerm f++lamTerm :: forall a. Defunc a -> Lam a lamTerm ID = Abs id lamTerm COMPOSE = Abs (\f -> Abs (\g -> Abs (\x -> App f (App g x)))) lamTerm FLIP = Abs (\f -> Abs (\x -> Abs (\y -> App (App f y) x))) lamTerm (APP_H f x) = App (lamTerm f) (lamTerm x)+{-lamTerm (LIFTED b) | Just Refl <- eqT @a @Bool = case b of+  False -> F+  True -> T-} lamTerm (LIFTED x) = Var True [||x||] lamTerm (EQ_H x) = Abs (\y -> App (App (Var True [||(==)||]) (lamTerm x)) y) lamTerm CONS = Var True [||(:)||]

@@ -12,35 +12,36 @@     F   :: Lam Bool  normalise :: Lam a -> Lam a-normalise x = reduce x+normalise x = if normal x then x else reduce x   where     reduce :: Lam a -> Lam a-    reduce x-      | normal x = x-      | otherwise = reduce (reduceStep x)--    reduceStep :: Lam a -> Lam a-    reduceStep (App (Abs f) x) = f x-    reduceStep (App f x)-      | normal f = App f (reduceStep x)-      | otherwise = App (reduceStep f) x-    reduceStep (If T x _) = x-    reduceStep (If F _ y) = y-    reduceStep x = x+    reduce (App (Abs f) x) = case f x of+      x | normal x -> x+      x            -> reduce x+    reduce (App f x) = case reduce f of+      f@(Abs _) -> reduce (App f x)+      f         -> App f x+    reduce (If c x y) = case reduce c of+      T -> x+      F -> y+      c -> If c x y+    reduce x = x      normal :: Lam a -> Bool     normal (App (Abs _) _) = False-    normal (App f x) = normal f && normal x+    normal (App f _) = normal f     normal (If T _ _) = False     normal (If F _ _) = False+    normal (If x _ _) = normal x     normal _ = True  generate :: Lam a -> Code a generate (Abs f)    = [||\x -> $$(normaliseGen (f (Var True [||x||])))||]--- These have already been reduced, since we only expose `normaliseGen`-generate (App f x)  = [||$$(generate f) $$(generate x)||]+-- f has already been reduced, since we only expose `normaliseGen`+generate (App f x)  = [||$$(generate f) $$(normaliseGen x)||] generate (Var _ x)  = x-generate (If c t e) = [||if $$(normaliseGen c) then $$(normaliseGen t) else $$(normaliseGen e)||]+-- c has already been reduced, since we only expose `normaliseGen`+generate (If c t e) = [||if $$(generate c) then $$(normaliseGen t) else $$(normaliseGen e)||] generate (Let b i)  = [||let x = $$(normaliseGen b) in $$(normaliseGen (i (Var True [||x||])))||] generate T          = [||True||] generate F          = [||False||]