packages feed

lens-th-rewrite (empty) → 0.1.0.0

raw patch · 5 files changed

+326/−0 lines, 5 filesdep +basedep +ghcdep +lenssetup-changed

Dependencies added: base, ghc, lens

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for lens-th-rewrite++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2020-2021, David M. Johnson+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lens-th-rewrite.cabal view
@@ -0,0 +1,28 @@+cabal-version:       >=1.10+name:                lens-th-rewrite+version:             0.1.0.0+synopsis:            Rewrites Template Haskell splices using the API+description:         A GHC plugin to perform source-to-source transformation on parsed Haskell, used to manually inline Template Haskell calls for lens.+bug-reports:         https://github.com/dmjio/lens-th-rewrite/issues+license:             BSD3+license-file:        LICENSE+author:              David Johnson+maintainer:          djohnson.m@gmail.com+copyright:           David Johnson (c) 2020+category:            Data+build-type:          Simple+extra-source-files:  CHANGELOG.md++library+  exposed-modules:+    GHC.Plugin.LensThRewrite+  build-depends:+    base < 5, ghc, lens+  hs-source-dirs:+    src+  default-language:+    Haskell2010++source-repository head+  type: git+  location: https://github.com/dmjio/lens-th-rewrite.git
+ src/GHC/Plugin/LensThRewrite.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns    #-}+{-# LANGUAGE BangPatterns    #-}+--------------------------------------------------------------------------------+-- |+-- Module      : GHC.Plugin.LensThRewrite+-- Copyright   : (c) 2020 David Johnson+-- License     : All Rights Reserved+-- Maintainer  : David Johnson <djohnson.m@gmail.com>+-- Stability   : Experimental+-- Portability : GHC+--+-- GHC Plugin to rewrite makeLenses call into pure functions.+--+--------------------------------------------------------------------------------+module GHC.Plugin.LensThRewrite ( plugin ) where++import Control.Arrow+import Control.Lens+import Data.Function                           (on)+import Data.List++import CoreSyn+import GhcPlugins+import HsDecls+import HsDumpAst+import HsExtension+import HsSyn+import OccName+import RdrName+import TcEvidence+import Var++import System.IO.Unsafe++-- | Lens rewrite plugin.+plugin :: Plugin+plugin+  = defaultPlugin+  { parsedResultAction = \_ _ -> rewriteMakeLenses+  , pluginRecompile = purePlugin+  }++rewriteMakeLenses+   :: HsParsedModule+   -> Hsc HsParsedModule+rewriteMakeLenses parsed = do+--  liftIO $ print "Rewriting makeLenses to use lens"+  pure $ parsed+       & moduleDecls+       %~ concatMap (modifyDecls (parsed ^. (hsMod . located)))++parsedModule :: Lens' HsParsedModule (Located (HsModule GhcPs))+parsedModule = lens hpm_module $ \r f -> r { hpm_module = f }++moduleDecls :: Lens' HsParsedModule [LHsDecl GhcPs]+moduleDecls = hsMod . located . decls++hsMod :: Lens' HsParsedModule (Located (HsModule GhcPs))+hsMod = lens hpm_module $ \f r -> f { hpm_module = r }++located :: Lens' (Located a) a+located = lens getter setter+  where+    getter (L _ r) = r+    setter (L x _) y = L x y++decls :: Lens' (HsModule a) [LHsDecl a]+decls = lens hsmodDecls $ \f r -> f { hsmodDecls = r }++modifyDecls :: HsModule GhcPs -> LHsDecl GhcPs -> [LHsDecl GhcPs]+modifyDecls m (L x decl) | not (isMakeLensesThSplice decl) = pure (L x decl)+modifyDecls m (L x decl) = emptyL <$> toDecls decl+  where+    toDecls :: HsDecl GhcPs -> [HsDecl GhcPs]+    toDecls decl = concat $ genDecls (getDecls m) =<< getMakeLensesSplices decl+        where+          genDecls decls type'+            | Just fields <- lookup type' decls = genLensCall type' <$> fields+            | otherwise = []++isMakeLensesThSplice :: HsDecl GhcPs -> Bool+isMakeLensesThSplice (SpliceD _ (SpliceDecl _ (L _ splice) _)) =+  case splice of+    HsUntypedSplice _ _ _ (L _ expr) ->+      case expr of+        HsApp _ (L _ l) (L _ r) ->+          case l of+            HsVar NoExt (L _ (Unqual (occNameString -> "makeLenses"))) ->+              True+            _ -> False+        _ -> False+    _ -> False+isMakeLensesThSplice _ = False++getMakeLensesSplices :: HsDecl GhcPs -> [String]+getMakeLensesSplices (SpliceD _ (SpliceDecl _ (L _ splice) _)) =+  case splice of+    HsUntypedSplice _ _ _ (L _ expr) ->+      case expr of+        HsApp _ (L _ l) (L _ r) ->+          case l of+            HsVar NoExt (L _ (Unqual (occNameString -> "makeLenses"))) ->+              case r of+                HsBracket NoExt (VarBr NoExt False (Unqual (occNameString -> typ))) ->+                  [typ]+                _ -> []+            _ -> []+        _ -> []+    _ -> []+getMakeLensesSplices _ = []++mkVar :: String -> HsExpr GhcPs+mkVar x = HsVar NoExt (mkName x)++-- | test+-- main :: IO ()+-- main = do+--   Right (_, L _ s) <- parseModule "Main.hs"+--   putStrLn $ showSDocUnsafe (showAstData BlankSrcSpan s)+--   let n = s & decls %~ concatMap (modifyDecls s)+--   putStrLn $ showSDocUnsafe (ppr n)++type FieldName = String+type TypeName = String++genSigD+  :: FieldName+  -> TypeName+  -- ^ Inner type, i.e. "Person" in Lens' Person Int+  -> HsType GhcPs+  -- ^ Outer type, i.e. "Int" in Lens' Person Int+  -> HsDecl GhcPs+genSigD fieldName innerType outerType =+  SigD NoExt (TypeSig NoExt [ mkName fieldName ] hsWc)+    where+      hsWc = HsWC NoExt hsIb+      hsIb = HsIB NoExt (emptyL result)+      result = tyVarLens `appTy` tyVarTypeInner `appTy` outerType+      tyVarTypeInner = tyVar innerType++appTy :: HsType GhcPs -> HsType GhcPs -> HsType GhcPs+appTy = HsAppTy NoExt `on` emptyL++tyVarLens :: HsType GhcPs+tyVarLens = tyC "Lens'"++tyVar :: String -> HsType GhcPs+tyVar s = HsTyVar NoExt NotPromoted (mkTyVarName s)++tyC :: String -> HsType GhcPs+tyC s = HsTyVar NoExt NotPromoted (mkTyCName s)++getDecls :: HsModule GhcPs -> [(TypeName, [(FieldName, HsType GhcPs)])]+getDecls mod = concatMap go $ fmap (^. located) (hsmodDecls mod)+  where+    go :: HsDecl GhcPs -> [(String, [(String,HsType GhcPs)])]+    go (TyClD NoExt d) = [(getDeclTypeName &&& getFieldAndTypeName) d]+    go _ = []++mkName :: String -> Located RdrName+mkName = emptyL . mkRdrUnqual . mkOccName OccName.varName++mkTyVarName :: String -> Located RdrName+mkTyVarName = emptyL . mkRdrUnqual . mkOccName OccName.tcName++mkTyCName :: String -> Located RdrName+mkTyCName = emptyL . mkRdrUnqual . mkOccName OccName.tcName+++-- | Extract existing type information from a Type or class Decl+getDeclTypeName :: TyClDecl GhcPs -> String+getDeclTypeName DataDecl {..} =+  case tcdLName ^. located of+    Unqual (occNameString -> s) -> s+getDeclTypeName _ = mempty++-- | Extract field name information from a record+getFieldAndTypeName :: TyClDecl GhcPs -> [(String,HsType GhcPs)]+getFieldAndTypeName DataDecl {..} = concat . concat $+  dd_cons tcdDataDefn <&> \(L _ ConDeclH98 {..}) ->+    case con_args of+      RecCon (L _ xs) ->+        xs <&> \(L _ ConDeclField{..}) ->+          case cd_fld_names of+            [ L _ FieldOcc {..} ] ->+              case rdrNameFieldOcc of+                L _ (Unqual fieldName) ->+                  pure (occNameString fieldName, cd_fld_type ^. located)+                _ -> []+            _ -> []+      _ -> []+getFieldAndTypeName _ = []++genLensCall+  :: String+  -> (String, HsType GhcPs)+  -> [HsDecl GhcPs]+genLensCall lensInnerType (fieldName, fieldType) =+  [ genSigD lensName lensInnerType fieldType, valD (funBind lensName mg) ]+  where+    lensName = drop 1 fieldName+    mg =+      matchGroup+      [ match (funRhs lensName) $ grhss+        [ grhs $+          (hsVar "lens" `hsApp` hsVar fieldName)+            `hsApp`+               (hsPar+                 $ hsLam+                 $ matchGroup+                 [ lambdaMatch [ varPat "r", varPat "f" ] $+                   grhss+                   [ grhs $ recordUpd (hsVar "r")+                     [ hsRecUpdField fieldName (hsVar "f")+                     ]+                   ]+                 ]+               )+        ]+      ]++valD :: HsBind GhcPs -> HsDecl GhcPs+valD = ValD NoExt++funBind :: String -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsBind GhcPs+funBind s mg = FunBind NoExt (mkName s) mg WpHole []++matchGroup :: [Match GhcPs (LHsExpr GhcPs)] -> MatchGroup GhcPs (LHsExpr GhcPs)+matchGroup xs = MG NoExt (emptyL (fmap emptyL xs)) FromSource++match+  :: HsMatchContext (NameOrRdrName (IdP GhcPs)) -- see funRhs+  -> GRHSs GhcPs (LHsExpr GhcPs)+  -> Match GhcPs (LHsExpr GhcPs)+match x y = Match NoExt x [] y++lambdaMatch+  :: [LPat GhcPs]+  -> GRHSs GhcPs (LHsExpr GhcPs)+  -> Match GhcPs (LHsExpr GhcPs)+lambdaMatch xs y = Match NoExt LambdaExpr xs y++funRhs :: String -> HsMatchContext (NameOrRdrName (IdP GhcPs))+funRhs x = FunRhs (mkName x) Prefix NoSrcStrict++emptyL :: e -> GenLocated SrcSpan e+emptyL = L noSrcSpan++grhss :: [GRHS GhcPs (LHsExpr GhcPs)] -> GRHSs GhcPs (LHsExpr GhcPs)+grhss xs = GRHSs NoExt (fmap emptyL xs) (emptyL (EmptyLocalBinds NoExt))++grhs :: HsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs)+grhs = GRHS NoExt [] . emptyL++hsApp :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs+hsApp l r = HsApp NoExt (emptyL l) (emptyL r)++hsVar :: String -> HsExpr GhcPs+hsVar = HsVar NoExt . mkName++hsPar :: HsExpr GhcPs -> HsExpr GhcPs+hsPar = HsPar NoExt . emptyL++hsLam :: MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs+hsLam = HsLam NoExt++recordUpd :: HsExpr GhcPs -> [HsRecUpdField GhcPs] -> HsExpr GhcPs+recordUpd e fs = RecordUpd NoExt (emptyL e) (emptyL <$> fs)++hsRecUpdField+  :: String+  -> HsExpr GhcPs+  -> HsRecUpdField GhcPs+hsRecUpdField s e = HsRecField (emptyL (ambig s)) (emptyL e) False+  where+    ambig :: String -> AmbiguousFieldOcc GhcPs+    ambig s = Unambiguous NoExt (mkName s)++varPat :: String -> Pat GhcPs+varPat = VarPat NoExt . mkName