parsley-core 1.0.0.0 → 1.0.1.0

raw patch · 9 files changed

+110/−62 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• parsley-core.cabal +2/−1
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs +4/−7
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs +7/−6
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs +3/−3
• src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +4/−4
• src/ghc/Parsley/Internal/Core.hs +1/−1
• src/ghc/Parsley/Internal/Core/Defunc.hs +35/−40
• src/ghc/Parsley/Internal/Core/Lam.hs +49/−0

@@ -4,3 +4,8 @@  * First version. Released on an unsuspecting world. * Core factored out of the main `parsley` package++## 1.0.1.0 -- 2021-06-26++* Introduced `Lam` to the API and conversion functions for `Core.Defunc`+* Extra type ascriptions added to generated code

@@ -5,7 +5,7 @@ --                   | +------- breaking internal API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.0.0.0+version:             1.0.1.0 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         This package contains the internals of the @parsley@ package.                      .@@ -49,6 +49,7 @@                        Parsley.Internal.Core.Defunc,                        Parsley.Internal.Core.Identifiers,                        Parsley.Internal.Core.InputTypes,+                       Parsley.Internal.Core.Lam,                        Parsley.Internal.Core.Primitives,                         Parsley.Internal.Frontend,

@@ -4,9 +4,9 @@ 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 Parsley.Internal.Common.Utils             (Code) -import qualified Parsley.Internal.Core.Defunc as Core (Defunc(BLACK), ap, genDefunc, genDefunc1, genDefunc2)+import qualified Parsley.Internal.Core.Defunc as Core (Defunc, ap, genDefunc, genDefunc1, genDefunc2, unsafeBLACK)  data Defunc a where   USER    :: Core.Defunc a -> Defunc a@@ -16,7 +16,7 @@   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))+ap2 f@SAME (OFFSET o1) (OFFSET o2) = USER (Core.unsafeBLACK (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)@@ -25,10 +25,7 @@   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+    seal x        = Core.unsafeBLACK (genDefunc x)  genDefunc :: Defunc a -> Code a genDefunc (USER x)    = Core.genDefunc x

@@ -62,6 +62,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 #-}@@ -135,7 +136,7 @@ #define deriveContOps(_o)                                                              \ instance ContOps _o where                                                              \ {                                                                                      \-  suspend m γ = [|| \x (!o#) -> $$(m (γ {operands = Op (FREEVAR [||x||]) (operands γ), \+  suspend m γ = [|| \x !(o# :: Rep _o) -> $$(m (γ {operands = Op (FREEVAR [||x||]) (operands γ), \                                          input = [||o#||]})) ||];                      \ }; inputInstances(deriveContOps)@@ -177,15 +178,15 @@ instance RecBuilder _o where                                                \ {                                                                           \   buildIter ctx μ l h o = [||                                               \-      let handler !o# = $$(h [||o#||]);                                     \-          loop !o# =                                                        \+      let handler !(o# :: Rep _o) = $$(h [||o#||]);                                     \+          loop !(o# :: Rep _o) =                                                        \         $$(run l                                                            \             (Γ Empty (noreturn @_o) [||o#||] (VCons [||handler o#||] VNil)) \-            (voidCoins (insertSub μ [||\_ (!o#) _ -> loop o#||] ctx)))      \+            (voidCoins (insertSub μ [||\_ !(o# :: Rep _o) _ -> loop o#||] ctx)))      \       in loop $$o                                                           \     ||];                                                                    \   buildRec rs ctx k = takeFreeRegisters rs ctx (\ctx ->                     \-    [|| \(!ret) (!o#) h ->                                                  \+    [|| \(!ret) !(o# :: Rep _o) h ->                                                  \       $$(run k (Γ Empty [||ret||] [||o#||] (VCons [||h||] VNil)) ctx) ||]); \ }; inputInstances(deriveRecBuilder)@@ -220,7 +221,7 @@ #define deriveLogHandler(_o)                                                                   \ instance LogHandler _o where                                                                   \ {                                                                                              \-  logHandler name ctx γ _ = let VCons h _ = handlers γ in [||\(!o#) ->                         \+  logHandler name ctx γ _ = let VCons h _ = handlers γ in [||\ !(o# :: Rep _o) ->                         \       trace $$(preludeString name '<' (γ {input = [||o#||]}) ctx (color Red " Fail")) ($$h o#) \     ||];                                                                                       \ };

@@ -1,9 +1,9 @@ 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 Parsley.Internal.Common.Utils             (Code) -import qualified Parsley.Internal.Core.Defunc as Core (Defunc(BLACK), ap, genDefunc, genDefunc1, genDefunc2)+import qualified Parsley.Internal.Core.Defunc as Core (Defunc, ap, genDefunc, genDefunc1, genDefunc2, unsafeBLACK)  data Defunc a where   USER    :: Core.Defunc a -> Defunc a@@ -16,7 +16,7 @@   where     seal :: Defunc a -> Core.Defunc a     seal (USER x) = x-    seal x        = Core.BLACK (WQ undefined (genDefunc x))+    seal x        = Core.unsafeBLACK (genDefunc x)  genDefunc :: Defunc a -> Code a genDefunc (USER x)    = Core.genDefunc x

@@ -46,8 +46,8 @@ 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 :< _)+--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))@@ -60,10 +60,10 @@ 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!+{-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 φ))+     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) φ))))))

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

@@ -3,6 +3,7 @@  import Language.Haskell.TH.Syntax (Lift(..)) import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))+import Parsley.Internal.Core.Lam (normaliseGen, Lam(..))  {-| This datatype is useful for providing an /inspectable/ representation of common Haskell functions.@@ -78,7 +79,7 @@   _val (IF_S c t e) = if _val c then _val t else _val e   _val (LAM_S f)    = \x -> _val (f (makeQ x undefined))   _val (LET_S x f)  = let y = _val x in _val (f (makeQ y undefined))-  _code = genDefunc+  _code = normaliseGen . lamTerm   (>*<) = APP_H  {-|@@ -113,50 +114,44 @@ ap :: Defunc (a -> b) -> Defunc a -> Defunc b ap f x = APP_H f x +lamTerm :: 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 x) = Var True [||x||]+lamTerm (EQ_H x) = Abs (\y -> App (App (Var True [||(==)||]) (lamTerm x)) y)+lamTerm CONS = Var True [||(:)||]+lamTerm EMPTY = Var True [||[]||]+lamTerm CONST = Abs (\x -> Abs (\_ -> x))+lamTerm (BLACK x) = Var False (_code x)+lamTerm (LAM_S f) = Abs (adaptLam f)+lamTerm (IF_S c t e) = If (lamTerm c) (lamTerm t) (lamTerm e)+lamTerm (LET_S x f) = Let (lamTerm x) (adaptLam f)++adaptLam :: (Defunc a -> Defunc b) -> (Lam a -> Lam b)+adaptLam f = lamTerm . f . defuncTerm+  where+    defuncTerm :: Lam a -> Defunc a+    defuncTerm (Abs f)    = LAM_S (defuncTerm . f . lamTerm)+    defuncTerm (App f x)  = APP_H (defuncTerm f) (defuncTerm x)+    defuncTerm (Var _ x)  = unsafeBLACK x+    defuncTerm (If c t e) = IF_S (defuncTerm c) (defuncTerm t) (defuncTerm e)+    defuncTerm (Let x f)  = LET_S (defuncTerm x) (defuncTerm . f . lamTerm)+    defuncTerm T          = LIFTED True+    defuncTerm F          = LIFTED False+ genDefunc :: Defunc a -> Code a-genDefunc ID                        = [|| \x -> x ||]-genDefunc COMPOSE                   = [|| \f g x -> f (g x) ||]-genDefunc FLIP                      = [|| \f x y -> f y x ||]-genDefunc (COMPOSE_H f g)           = [|| \x -> $$(genDefunc1 (COMPOSE_H f g) [||x||]) ||]-genDefunc CONST                     = [|| \x _ -> x ||]-genDefunc FLIP_CONST                = [|| \_ y -> y ||]-genDefunc (FLIP_H f)                = [|| \x -> $$(genDefunc1 (FLIP_H f) [||x||]) ||]-genDefunc (APP_H f x)               = genDefunc1 f (genDefunc x)-genDefunc (LIFTED x)                = [|| x ||]-genDefunc (EQ_H x)                  = [|| \y -> $$(genDefunc1 (EQ_H x) [||y||]) ||]-genDefunc CONS                      = [|| \x xs -> x : xs ||]-genDefunc EMPTY                     = [|| [] ||]-genDefunc (IF_S (LIFTED True) t _)  = genDefunc t-genDefunc (IF_S (LIFTED False) _ e) = genDefunc e-genDefunc (IF_S c t e)              = [|| if $$(genDefunc c) then $$(genDefunc t) else $$(genDefunc e) ||]-genDefunc (LAM_S f)                 = [|| \x -> $$(genDefunc1 (LAM_S f) [||x||]) ||]-genDefunc (LET_S x f)               = [|| let y = $$(genDefunc x) in $$(genDefunc (f (makeQ undefined [||y||]))) ||]-genDefunc (BLACK f)                 = _code f+genDefunc = normaliseGen . lamTerm  genDefunc1 :: Defunc (a -> b) -> Code a -> Code b-genDefunc1 ID              qx = qx-genDefunc1 COMPOSE         qf = [|| \g x -> $$qf (g x) ||]-genDefunc1 FLIP            qf = [|| \x y -> $$qf y x ||]-genDefunc1 (COMPOSE_H f g) qx = genDefunc1 f (genDefunc1 g qx)-genDefunc1 (APP_H ID f)    qx = genDefunc1 f qx-genDefunc1 (APP_H f x)     qy = genDefunc2 f (genDefunc x) qy-genDefunc1 CONST           qx = [|| \_ -> $$qx ||]-genDefunc1 FLIP_CONST      _  = genDefunc ID-genDefunc1 (FLIP_H f)      qx = [|| \y -> $$(genDefunc2 (FLIP_H f) qx [||y||]) ||]-genDefunc1 (EQ_H x)        qy = [|| $$(genDefunc x)  == $$qy ||]-genDefunc1 (LAM_S f)       qx = genDefunc (f (makeQ undefined qx))-genDefunc1 f               qx = [|| $$(genDefunc f) $$qx ||]+genDefunc1 f x = genDefunc (APP_H f (unsafeBLACK x))  genDefunc2 :: Defunc (a -> b -> c) -> Code a -> Code b -> Code c-genDefunc2 ID              qf qx  = [|| $$qf $$qx ||]-genDefunc2 COMPOSE         qf qg  = [|| \x -> $$qf ($$qg x) ||]-genDefunc2 FLIP            qf qx  = [|| \y -> $$qf y $$qx ||]-genDefunc2 (COMPOSE_H f g) qx qy  = genDefunc2 f (genDefunc1 g qx) qy-genDefunc2 CONST           qx _   = qx-genDefunc2 FLIP_CONST      _  qy  = qy-genDefunc2 (FLIP_H f)      qx qy  = genDefunc2 f qy qx-genDefunc2 CONS            qx qxs = [|| $$qx : $$qxs ||]-genDefunc2 f               qx qy  = [|| $$(genDefunc1 f qx) $$qy ||]+genDefunc2 f x y = genDefunc (APP_H (APP_H f (unsafeBLACK x)) (unsafeBLACK y))++unsafeBLACK :: Code a -> Defunc a+unsafeBLACK = BLACK . WQ undefined  instance Show (Defunc a) where   show COMPOSE = "(.)"

@@ -0,0 +1,49 @@+module Parsley.Internal.Core.Lam (normaliseGen, Lam(..)) where++import Parsley.Internal.Common.Utils (Code)++data Lam a where+    Abs :: (Lam a -> Lam b) -> Lam (a -> b)+    App :: Lam (a -> b) -> Lam a -> Lam b+    Var :: Bool {- Simple -} -> Code a -> Lam a+    If  :: Lam Bool -> Lam a -> Lam a -> Lam a+    Let :: Lam a -> (Lam a -> Lam b) -> Lam b+    T   :: Lam Bool+    F   :: Lam Bool++normalise :: Lam a -> Lam a+normalise x = 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++    normal :: Lam a -> Bool+    normal (App (Abs _) _) = False+    normal (App f x) = normal f && normal x+    normal (If T _ _) = False+    normal (If F _ _) = False+    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)||]+generate (Var _ x)  = x+generate (If c t e) = [||if $$(normaliseGen 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||]++normaliseGen :: Lam a -> Code a+normaliseGen = generate . normalise