From b2489c1deaaddd6580fe6d7e9533405932ff5609 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Sat, 12 Jun 2021 15:34:24 +0100 Subject: [PATCH] Depend on parsley-core instead --- ChangeLog.md | 7 ++++- parsley-garnish.cabal | 5 ++-- src/Parsley/Garnish.hs | 7 +---- src/Parsley/Internal/Bridge.hs | 18 +++++++++++++ src/Parsley/OverloadedQuotesPlugin/Plugin.hs | 28 +++++++++++--------- test/src/A.hs | 10 ++++--- test/src/Main.hs | 19 ++++++------- test/test.cabal | 2 +- 8 files changed, 61 insertions(+), 35 deletions(-) create mode 100644 src/Parsley/Internal/Bridge.hs diff --git a/ChangeLog.md b/ChangeLog.md index 4598ec9..cf3eb34 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -6,4 +6,9 @@ ## 0.1.0.1 -- 2021-06-11 -* Support for GHC 9.0 in place. \ No newline at end of file +* Support for GHC 9.0 in place. + +## 0.1.1.0 -- 2021-06-12 + +* Switched to support `parsley-core` as the base +* Introduced the `Parsley.Internal.Bridge` module to provide functions for the plugin to latch onto \ No newline at end of file diff --git a/parsley-garnish.cabal b/parsley-garnish.cabal index cf68173..050d6d2 100644 --- a/parsley-garnish.cabal +++ b/parsley-garnish.cabal @@ -1,5 +1,5 @@ name: parsley-garnish -version: 0.1.0.1 +version: 0.1.1.0 synopsis: A collection of GHC plugins to work with parsley description: This package contains a collection (for now one) to help remove boilerplate when writing parsers using @parsley@. @@ -27,6 +27,7 @@ library -- Parsley.LiftPlugin -- Parsley.OverloadedSyntaxPlugin Parsley.OverloadedQuotesPlugin + Parsley.Internal.Bridge other-modules: Parsley.PluginUtils -- -- Lift Plugin -- Parsley.LiftPlugin.Plugin @@ -40,7 +41,7 @@ library Parsley.OverloadedQuotesPlugin.Plugin build-depends: base >= 4.10 && < 5, - parsley >= 0.1 && < 0.2, + parsley-core >= 1.0 && < 1.1, template-haskell >= 2.14 && < 3, ghc-tcplugins-extra >= 0.3 && < 0.5, ghc >= 8.6 && < 9.2, diff --git a/src/Parsley/Garnish.hs b/src/Parsley/Garnish.hs index c57d638..d544b4c 100644 --- a/src/Parsley/Garnish.hs +++ b/src/Parsley/Garnish.hs @@ -12,16 +12,11 @@ import Parsley.LiftPlugin (LiftTo(..)) import Parsley.OverloadedSyntaxPlugin (Syntax(..), overload) import Parsley (Quapplicative(makeQ, _val, _code, (>*<)), WQ, Code) import Parsley.Defunctionalized (Defunc) +import Parsley.Internal.Bridge (mkCode, mkVal) instance LiftTo WQ where code x = makeQ x [||x||] instance LiftTo Defunc where code x = makeQ x [||x||] -mkVal :: Quapplicative q => a -> q a -mkVal x = makeQ x undefined - -mkCode :: Quapplicative q => Code a -> q a -mkCode qx = makeQ undefined qx - instance (LiftTo q, Quapplicative q) => Syntax q where _if cond _then _else = makeQ (if _val cond then _val _then else _val _else) diff --git a/src/Parsley/Internal/Bridge.hs b/src/Parsley/Internal/Bridge.hs new file mode 100644 index 0000000..db2df4f --- /dev/null +++ b/src/Parsley/Internal/Bridge.hs @@ -0,0 +1,18 @@ +module Parsley.Internal.Bridge (_code, _val, makeQ, mkVal, mkCode) where + +import qualified Parsley.Internal.Common.Utils as Parsley (Quapplicative(..), Code) + +_code :: Parsley.Quapplicative q => q a -> Parsley.Code a +_code = Parsley._code + +_val :: Parsley.Quapplicative q => q a -> a +_val = Parsley._val + +makeQ :: Parsley.Quapplicative q => a -> Parsley.Code a -> q a +makeQ = Parsley.makeQ + +mkVal :: Parsley.Quapplicative q => a -> q a +mkVal x = Parsley.makeQ x undefined + +mkCode :: Parsley.Quapplicative q => Parsley.Code a -> q a +mkCode qx = Parsley.makeQ undefined qx \ No newline at end of file diff --git a/src/Parsley/OverloadedQuotesPlugin/Plugin.hs b/src/Parsley/OverloadedQuotesPlugin/Plugin.hs index 7bfdb37..0c9cfdf 100644 --- a/src/Parsley/OverloadedQuotesPlugin/Plugin.hs +++ b/src/Parsley/OverloadedQuotesPlugin/Plugin.hs @@ -12,7 +12,7 @@ module Parsley.OverloadedQuotesPlugin.Plugin (plugin) where import Data.Generics (GenericT, GenericQ, mkT, mkQ, everywhere, gmapT) import GHC.Generics (Generic) -import Parsley.PluginUtils (lookupModuleInPackage, lookupName, lookupNames) +import Parsley.PluginUtils (lookupModule, lookupNames) #if __GLASGOW_HASKELL__ >= 900 import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin) @@ -58,27 +58,29 @@ plugin = defaultPlugin { renamedResultAction = overloadedQuotes, pluginRecompile data QOps a = QOps { _code :: a, _val :: a, - makeQ :: a + makeQ :: a, + mkCode :: a, + mkVal :: a } deriving (Functor, Foldable, Traversable, Generic) quapplicativeStrings :: QOps String quapplicativeStrings = QOps { _code = "_code", _val = "_val", - makeQ = "makeQ" + makeQ = "makeQ", + mkCode = "mkCode", + mkVal = "mkVal" } overloadedQuotes :: [GHC.CommandLineOption] -> TcGblEnv -> GHC.HsGroup GHC.GhcRn -> TcM (TcGblEnv, GHC.HsGroup GHC.GhcRn) overloadedQuotes _ gEnv rn = do hscEnv <- GHC.getTopEnv - parsley <- lookupModuleInPackage hscEnv "parsley" "Parsley.Internal.Common.Utils" + parsley <- lookupModule hscEnv "Parsley.Internal.Bridge" qops <- lookupNames parsley quapplicativeStrings - prelude <- lookupModuleInPackage hscEnv "base" "GHC.Err" - undef <- lookupName prelude "undefined" -- This is a little inefficient, since the top-down transformation means no quotes can be -- found under a top-level one: we use a top-down version of everywhereBut to stop traversal -- of this whenever it fires - return (gEnv, onlyTopmost (mkQ False isQuote) (mkT (transformUTHQuote qops undef)) rn) + return (gEnv, onlyTopmost (mkQ False isQuote) (mkT (transformUTHQuote qops)) rn) mkApp :: GHC.SrcSpan -> Expr -> Expr -> Expr mkApp s f = GHC.L s . Expr.HsApp noExt f . mkPar s @@ -103,17 +105,19 @@ isQuote _ = False -- the original quote. Perhaps in that case we could just inline the definition into both holes... -- As `transform` works bottom up, we can always assume nested quotes are already handled: this might -- get tricky, however. -transformUTHQuote :: QOps GHC.Name -> GHC.Name -> Expr -> Expr -transformUTHQuote ops undef (LUTHQuote s ex ex' x) = --pprTouch "new quote" $ +transformUTHQuote :: QOps GHC.Name -> Expr -> Expr +transformUTHQuote ops (LUTHQuote s ex ex' x) = --pprTouch "new quote" $ mkPar s (makeQS `mkAppS` everywhere (mkT (transformUTHQuoteVar (_val ops) makeVal)) x `mkAppS` mkQuote (everywhere (mkT (transformUTHQuoteCode (_code ops) makeCode)) x)) where mkQuote y = GHC.L s (Expr.HsBracket ex (Expr.TExpBr ex' y)) mkAppS = mkApp s makeQS = mkVar s (makeQ ops) - makeVal y = mkPar s (makeQS `mkAppS` y `mkAppS` mkVar s undef) - makeCode y = mkPar s (makeQS `mkAppS` mkVar s undef `mkAppS` y) -transformUTHQuote _ _ x = x + mkValS = mkVar s (mkVal ops) + mkCodeS = mkVar s (mkCode ops) + makeVal y = mkPar s (mkValS `mkAppS` y) + makeCode y = mkPar s (mkCodeS `mkAppS` y) +transformUTHQuote _ x = x transformUTHQuoteVar :: GHC.Name -> (Expr -> Expr) -> Expr -> Expr transformUTHQuoteVar _ makeVal (LUTHQuote _ _ _ x) = makeVal x diff --git a/test/src/A.hs b/test/src/A.hs index 93f676a..065ecfb 100644 --- a/test/src/A.hs +++ b/test/src/A.hs @@ -1,14 +1,15 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fplugin=Parsley.LiftPlugin #-} -{-# OPTIONS_GHC -fplugin=Parsley.OverloadedSyntaxPlugin #-} +--{-# OPTIONS_GHC -fplugin=Parsley.LiftPlugin #-} +--{-# OPTIONS_GHC -fplugin=Parsley.OverloadedSyntaxPlugin #-} {-# OPTIONS_GHC -fplugin=Parsley.OverloadedQuotesPlugin #-} module A where import Data.Functor.Identity -import Parsley.Garnish +import Parsley.Internal +--import Parsley.Garnish liftTest :: Int -> WQ Int liftTest x = [|x|] @@ -19,6 +20,7 @@ id' = id test :: WQ Int test = [|$(id' [|7|]) + 1 |] +{- instance LiftTo Identity where code = Identity @@ -133,4 +135,4 @@ staticPowerId = overload (\n -> \k -> staticPower_s :: (Quapplicative r, Syntax r) => Int -> r Int -> r Int staticPower_s n k = if n == 0 then code 1 - else (overload ((code (*)) k)) >*< staticPower_s (n - 1) k + else (overload ((code (*)) k)) >*< staticPower_s (n - 1) k-} diff --git a/test/src/Main.hs b/test/src/Main.hs index 0e1909f..23c0f1c 100644 --- a/test/src/Main.hs +++ b/test/src/Main.hs @@ -3,16 +3,17 @@ module Main(main) where import A import Data.Functor.Identity -import Parsley (_code, WQ) +import Parsley.Internal (_code, WQ) main = do - print ($$(_code @WQ test3) 'a') - print ((runIdentity test4) 'a') - print (just 'a') - print (qux 'a') + putStrLn "Testing" + --print ($$(_code @WQ test3) 'a') + --print ((runIdentity test4) 'a') + --print (just 'a') + --print (qux 'a') -just :: a -> Maybe a -just = $$(_code @WQ test7) +--just :: a -> Maybe a +--just = $$(_code @WQ test7) -qux :: a -> a -qux = $$(_code @WQ test5) +--qux :: a -> a +--qux = $$(_code @WQ test5) diff --git a/test/test.cabal b/test/test.cabal index 0f5ae97..645b41e 100644 --- a/test/test.cabal +++ b/test/test.cabal @@ -18,7 +18,7 @@ cabal-version: >=1.10 executable test main-is: Main.hs other-modules: A - build-depends: base >=4.11 && <5, parsley-garnish, parsley, template-haskell + build-depends: base >=4.11 && <5, parsley-garnish, parsley-core, template-haskell hs-source-dirs: src --ghc-options: -ddump-ds-preopt default-language: Haskell2010