parsley-garnish (empty) → 0.1.0.0

raw patch · 7 files changed

+352/−0 lines, 7 filesdep +basedep +ghcdep +ghc-tcplugins-extra

Dependencies added: base, ghc, ghc-tcplugins-extra, parsley, syb, template-haskell

Files

ChangeLog.md +5/−0
LICENSE +30/−0
README.md +51/−0
parsley-garnish.cabal +51/−0
src/Parsley/OverloadedQuotesPlugin.hs +38/−0
src/Parsley/OverloadedQuotesPlugin/Plugin.hs +123/−0
src/Parsley/PluginUtils.hs +54/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for `parsley-garnish`++## 0.1.0.0 -- 2021-06-10++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2021, Jamie Willis, Matthew Pickering++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, Matthew Pickering, 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,51 @@+# Parsley Garnish+This repo houses the `parsley`-specific GHC plugins to help make writing +parsers with `parsley` take less boilerplate.++Each plugin here will in some way interact to produce values of either +type `Parsley.WQ` or `Parsley.Defunctionalized.Defunc`. These datatypes +are how `parsley`'s API interacts with user-land functions.++By default, the user can produce values of these types by using the +`makeQ` function:++```hs+makeQ :: Quapplicative q => a -> Code a -> q a+```++Where both `WQ` and `Defunc` are instances of `Quapplicative`. However, +this can be tedious to do by hand.++## `OverloadedQuotes`+The first plugin found in the garnish hijacks the regular Haskell syntax +for _Untyped_ Template Haskell (UTH). Since `parsley` uses _Typed_ +Template Haskell (TTH), it is unlikely that a user of the library will +need to be using UTH in the same file (with the possible exception of +top-level splices, or quotes other than the basic `[|x|]`). This plugin +will transform every UTH quote in a file so that it represents a value of +`Quapplicative q => q a`. This transformation is as follows:++```hs+qsucc :: Quapplicative q => q Int -> q Int+qsucc qx = [|$(qx) + 1|]+-- goes to:+qsucc qx = makeQ (_val qx + 1) [||$$(_code qx) + 1||]+```++Values of `Defunc` can also be spliced in directly:++```hs+diffcons :: Defunc a -> Defunc ([a] -> [a]) -> Defunc ([a] -> [a])+diffcons qx qdxs = [| $(COMPOSE) ($(CONS) $(qx)) $(qdxs) |]+```++And lambda abstraction works too (along with any other syntax):++```hs+diffcons' :: Defunc (a -> ([a] -> [a]) -> [a] -> [a])+diffcons' = [|\x dxs -> $(diffcons [|x|] [|dxs|])|]+```++The disadvantage to this plugin _currently_ is that it does not make any +attempt to  leverage the specialised parts of `Defunc` to improve the code +generation and inspectibility. The user would be left to use this manually.

+ parsley-garnish.cabal view

@@ -0,0 +1,51 @@+name:               parsley-garnish+version:            0.1.0.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@.+homepage:           https://github.com/j-mie6/parsley-garnish+bug-reports:        https://github.com/j-mie6/parsley-garnish/issues             +license:            BSD3+license-file:       LICENSE+author:             Jamie Willis, Garnish Contributors+-- When the lift-plugin + overloaded-syntax is in this can change+--, Matthew Pickering+maintainer:         Jamie Willis <j.willis19@imperial.ac.uk>+category:           Plugin+build-type:         Simple+extra-doc-files:    ChangeLog.md+                    README.md+cabal-version:      1.18++library+  exposed-modules:  +--                    Parsley.Garnish,+--                    Parsley.LiftPlugin+--                    Parsley.OverloadedSyntaxPlugin+                    Parsley.OverloadedQuotesPlugin+  other-modules:    Parsley.PluginUtils+--                    -- Lift Plugin+--                    Parsley.LiftPlugin.Plugin+--                    Parsley.LiftPlugin.Error+--                    Parsley.LiftPlugin.Fake+--                    Parsley.LiftPlugin.LiftReplace+--                    Parsley.LiftPlugin.LiftFind+                    -- Overloaded Syntax Plugin+--                    Parsley.OverloadedSyntaxPlugin.Plugin+                    -- Overloaded Quotes Plugin+                    Parsley.OverloadedQuotesPlugin.Plugin++  build-depends:    base                >= 4.10    && < 5,+                    parsley             >= 0.1     && < 0.2,+                    template-haskell    >= 2.14    && < 3,+                    ghc-tcplugins-extra >= 0.3     && < 0.5,+                    ghc                 >= 8.6     && < 9,+                    syb                 >= 0.7     && < 0.8++  hs-source-dirs:   src+  ghc-options:      -Wall+  default-language: Haskell2010++source-repository head+  type:                git+  location:            https://github.com/j-mie6/parsley-garnish

+ src/Parsley/OverloadedQuotesPlugin.hs view

@@ -0,0 +1,38 @@+{-|+Module      : Parsley.OverloadedQuotesPlugin+Description : Plugin for replacing Untyped Template Haskell quotes with+              @parsley@'s @Quapplicative@ values.+License     : BSD-3-CLAUSE+Maintainer  : Jamie Willis+Stability   : stable++This plugin hijacks the regular Haskell syntax +for /Untyped/ Template Haskell (UTH). Since @parsley@ uses /Typed/ +Template Haskell (TTH), it is unlikely that a user of the library will +need to be using UTH in the same file (with the possible exception of +top-level splices, or quotes other than the basic @[|x|]@). This plugin +will transform every UTH quote in a file so that it represents a value of +@Quapplicative q => q a@. This transformation is as follows:++> qsucc :: Quapplicative q => q Int -> q Int+> qsucc qx = [|$(qx) + 1|]+> -- goes to:+> qsucc qx = makeQ (_val qx + 1) [||$$(_code qx) + 1||]++Values of @Parsley.Defunctionalized.Defunc@ can also be spliced in directly:++> diffcons :: Defunc a -> Defunc ([a] -> [a]) -> Defunc ([a] -> [a])+> diffcons qx qdxs = [| $(COMPOSE) ($(CONS) $(qx)) $(qdxs) |]++And lambda abstraction works too (along with any other syntax):++> diffcons' :: Defunc (a -> ([a] -> [a]) -> [a] -> [a])+> diffcons' = [|\x dxs -> $(diffcons [|x|] [|dxs|])|]++The disadvantage to this plugin /currently/ is that it does not make any +attempt to  leverage the specialised parts of @Defunc@ to improve the code +generation and inspectibility. The user would be left to use this manually.+-}+module Parsley.OverloadedQuotesPlugin (module Plugin) where++import Parsley.OverloadedQuotesPlugin.Plugin as Plugin

+ src/Parsley/OverloadedQuotesPlugin/Plugin.hs view

@@ -0,0 +1,123 @@+{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+module Parsley.OverloadedQuotesPlugin.Plugin (plugin) where++import Plugins       (Plugin (..), defaultPlugin, purePlugin)+import TcRnTypes     (TcGblEnv, TcM)+import Data.Generics (GenericT, GenericQ, mkT, mkQ, everywhere, gmapT)+import GHC.Generics  (Generic)++import qualified GHC               (HsGroup, GhcRn, Name, GenLocated(L), SrcSpan)+import qualified GhcPlugins as GHC (CommandLineOption)+import qualified TcRnMonad as GHC  (getTopEnv)++#if __GLASGOW_HASKELL__ < 810+import qualified HsExpr as Expr+#else+import qualified GHC.Hs.Expr as Expr+#endif++import Parsley.PluginUtils (lookupModuleInPackage, lookupName, lookupNames)++#if __GLASGOW_HASKELL__ >= 810+import GHC.Hs.Extension+noExt :: NoExtField+noExt = noExtField+#else+import GHC (noExt)+#endif++type Expr = Expr.LHsExpr GHC.GhcRn++{-|+This plugin repurposes /Untyped/ Template Haskell quotes (and splices within them)+to be @Parsley.Quapplicative@ values.+-}+plugin :: Plugin+plugin = defaultPlugin { renamedResultAction = overloadedQuotes, pluginRecompile = purePlugin }++data QOps a = QOps {+    _code :: a,+    _val :: a,+    makeQ :: a+  } deriving (Functor, Foldable, Traversable, Generic)++quapplicativeStrings :: QOps String+quapplicativeStrings = QOps {+    _code = "_code",+    _val  = "_val",+    makeQ = "makeQ"+  }++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"+  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)++mkApp :: GHC.SrcSpan -> Expr -> Expr -> Expr+mkApp s f = GHC.L s . Expr.HsApp noExt f . mkPar s++mkVar :: GHC.SrcSpan -> GHC.Name -> Expr+mkVar s = GHC.L s . Expr.HsVar noExt . GHC.L s++mkPar :: GHC.SrcSpan -> Expr -> Expr+mkPar s = GHC.L s . Expr.HsPar noExt++pattern LUTHQuote s ex1 ex2 x <- GHC.L s (Expr.HsRnBracketOut ex1 (Expr.ExpBr ex2 x) _)+pattern LUTHSplice s ex1 ex2 dec name x = GHC.L s (Expr.HsSpliceE ex1 (Expr.HsUntypedSplice ex2 dec name x))++isQuote :: Expr -> Bool+isQuote (LUTHQuote _ _ _ _) = True+isQuote _                   = False++-- The goal here is to find [|e|] and turn it into makeQ e [||e||]+-- The catch is that for any $qe in the quote, it must be hoisted out, let bound and then re-incorporated+-- such that `[|x .. $qe .. y|]` ~> `let qe' = qe in makeQ (x .. _val qe' .. y) [||x .. $$(_code qe') .. y||]`+-- This means that the content of the splice _cannot_ use any of the free-variables defined within+-- 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" $+  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++transformUTHQuoteVar :: GHC.Name -> (Expr -> Expr) -> Expr -> Expr+transformUTHQuoteVar _    makeVal (LUTHQuote _ _ _ x)      = makeVal x+transformUTHQuoteVar _val _       (LUTHSplice s _ _ _ _ x) = mkApp s (mkVar s _val) x+transformUTHQuoteVar _    _       x                        = x++transformUTHQuoteCode :: GHC.Name -> (Expr -> Expr) -> Expr -> Expr+transformUTHQuoteCode _     makeCode (LUTHQuote s ex ex' x)         = makeCode (GHC.L s (Expr.HsBracket ex (Expr.TExpBr ex' x)))+transformUTHQuoteCode _code _        (LUTHSplice s ex ex' d name x) = GHC.L s . Expr.HsSpliceE ex . Expr.HsTypedSplice ex' d name $+  mkApp s (mkVar s _code) x+transformUTHQuoteCode _     _        x                              = x++onlyTopmost :: GenericQ Bool -> GenericT -> GenericT+onlyTopmost q f = go+  where+    go :: GenericT+    go x+      | q x = f x+      | otherwise = gmapT go x

+ src/Parsley/PluginUtils.hs view

@@ -0,0 +1,54 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module Parsley.PluginUtils where++import qualified GHC.TcPluginM.Extra as TCPluginExtra (lookupName)++-- GHC API+import TcRnTypes (TcM, TcPluginM)+import Outputable++-- ghc+import qualified GhcPlugins as GHC+import qualified IfaceEnv as GHC (lookupOrig)+import Finder (findImportedModule, FindResult(Found))+import FastString (mkFastString)+import Module (Module, mkModuleName)+import Name (Name)+import Control.Monad.IO.Class ( liftIO )++class Monad m => Lookup m where+  lookupOrig :: Module -> GHC.OccName -> m Name++instance Lookup TcM where+  lookupOrig = GHC.lookupOrig++instance Lookup TcPluginM where+  lookupOrig = TCPluginExtra.lookupName++pprTouch :: Outputable a => String -> a -> a+pprTouch name x = pprTrace name (ppr x) x++lookupNames :: (Lookup m, Traversable t) => Module -> t String -> m (t Name)+lookupNames = traverse . lookupName++lookupName :: Lookup m => Module -> String -> m Name+lookupName pm = lookupOrig pm . GHC.mkVarOcc++lookupClass :: Lookup m => Module -> String -> m Name+lookupClass pm = lookupOrig pm . GHC.mkTcOcc++lookupIds :: Traversable t => Module -> t String -> TcM (t GHC.Id)+lookupIds = traverse . lookupId++lookupId :: Module -> String -> TcM GHC.Id+lookupId pm name = lookupName pm name >>= GHC.lookupId++lookupModule :: GHC.HscEnv -> String -> TcM Module+lookupModule hscEnv modName = do+  Found _ md <- liftIO (findImportedModule hscEnv (mkModuleName modName) Nothing)+  return md++lookupModuleInPackage :: GHC.HscEnv -> String -> String -> TcM Module+lookupModuleInPackage hscEnv package modName = do+  Found _ md <- liftIO (findImportedModule hscEnv (mkModuleName modName) (Just (mkFastString package)))+  return md