auto-extract (empty) → 0.1.0.0
raw patch · 10 files changed
+1135/−0 lines, 10 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, directory, ghc, ghc-exactprint, ghc-paths, process, syb, tasty, tasty-hunit, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- README.md +83/−0
- auto-extract.cabal +66/−0
- src/AutoExtract.hs +235/−0
- src/AutoExtract/Expr.hs +364/−0
- src/AutoExtract/GhcFacade.hs +87/−0
- src/AutoExtract/Parser.hs +106/−0
- src/AutoExtract/Renamer.hs +109/−0
- test/Main.hs +51/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for auto-extract++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2025, Aaron Allen+++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 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.
+ README.md view
@@ -0,0 +1,83 @@+# auto-extract :fork_and_knife:++This is a GHC plugin that edits the file being compiled by extracting a target+expression as a top level declaration. This is useful for breaking up large+functions into smaller reusable pieces.++### Usage++This plugin is intended to be used with GHCi or adjacent utilities such as+`ghcid` and `ghciwatch` as a developement tool, not as a package dependency.+Here is an example command for starting a REPL for a stack project with the+`auto-extract` plugin enabled (you may need to add `auto-extract` to your+`extra-deps` first):++```+stack repl my-project --package auto-extract --ghci-options='-fplugin AutoExtract'+```++likewise for a cabal project (you may need to run `cabal update` first):++```+cabal repl my-project --build-depends auto-extract --repl-options='-fplugin AutoExtract'+```++With the plugin enabled, mark the expression to be extracted using+`EXTRACT@name (<expr>)` then compile the module. A top level definition will be+added identified by the given name and having the expression enclosed in parens+as the body. The plugin will determine what arguments are necessary and will+include a type signature based on the inferred type of the expression.+Compilation is aborted after the code is updated.++For example, given this program:++```haskell+doubleInput :: IO ()+doubleInput = do+ input <- do+ putStrLn "Enter a number"+ readLn+ let doubled = input * 2+ print doubled+```++Insert the extraction targets:++```haskell+doubleInput :: IO ()+doubleInput = do+ input <- EXTRACT@promptNumber (do+ putStrLn "Enter a number"+ readLn)+ let doubled = EXTRACT@double (input * 2)+ print doubled+```++Note: the code can contain multiple `EXTRACT` directives and they can be nested+within one another.++Compiling the module will result in the source code being updated to:++```haskell+doubleInput :: IO ()+doubleInput = do+ input <- promptNumber+ let doubled = double input+ print doubled++promptNumber :: IO Integer+promptNumber = do+ putStrLn "Enter a number"+ readLn++double :: Num a => a -> a+double input = input * 2+```++### Caveats++- The resulting module must pass the type checker in order for the code to be+ updated.+- The plugin only supports certain GHC versions with the intent of supporting+ the four latest release series, i.e. `9.6.*` thru `9.12.*`. The cabal file+ indicates the currently supported versions.
+ auto-extract.cabal view
@@ -0,0 +1,66 @@+cabal-version: 3.0+name: auto-extract+version: 0.1.0.0+license: BSD-3-Clause+license-file: LICENSE+synopsis: Extract code segment to top level function+description: Extract code segment to top level function using a GHC plugin+author: Aaron Allen+maintainer: aaronallen8455@gmail.com+category: Development+build-type: Simple+extra-doc-files: CHANGELOG.md+ README.md+tested-with: GHC == 9.12.1, GHC == 9.10.1, GHC == 9.8.1, GHC == 9.6.1++source-repository head+ type: git+ location: https://github.com/aaronallen8455/auto-extract++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: AutoExtract+ other-modules: AutoExtract.GhcFacade+ AutoExtract.Expr+ AutoExtract.Renamer+ AutoExtract.Parser+ -- other-extensions:+ build-depends: base < 5,+ ghc >= 9.6 && < 9.13,+ containers,+ syb,+ bytestring < 0.13,+ ghc-exactprint,+ ghc-paths,+ transformers+ hs-source-dirs: src+ default-language: GHC2021++test-suite auto-extract-test+ import: warnings+ default-language: GHC2021+ -- other-modules:+ -- other-extensions:+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base <5,+ process,+ directory,+ tasty,+ tasty-hunit,+ ghc++-- executable play+-- hs-source-dirs: play+-- main-is: Main.hs+-- build-depends:+-- base,+-- auto-extract+-- default-language: GHC2021+-- ghc-options: -fplugin AutoExtract
+ src/AutoExtract.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+module AutoExtract+ ( plugin+ ) where++import Control.Monad (guard)+import Control.Monad.IO.Class (liftIO)+import Control.Exception (catch, throw)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Internal as BS+import qualified Data.Char as Char+import Data.Foldable+import qualified Data.Generics as Syb+import Data.IORef+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.String+import qualified GHC.Paths as Paths+import qualified Language.Haskell.GHC.ExactPrint as EP+import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP+import qualified Language.Haskell.GHC.ExactPrint.Utils as EP++import AutoExtract.Expr+import qualified AutoExtract.GhcFacade as Ghc+import AutoExtract.Parser (Extraction(..), ExtractedDecls, modifyParsedDecls, pattern ExtractPat)+import AutoExtract.Renamer (performExtractions)++plugin :: Ghc.Plugin+plugin = Ghc.defaultPlugin+ { Ghc.pluginRecompile = Ghc.purePlugin+ , Ghc.driverPlugin = \_opts env -> updateHscEnv env+ }++updateHscEnv :: Ghc.HscEnv -> IO Ghc.HscEnv+updateHscEnv hscEnv = do+ pure hscEnv+ { Ghc.hsc_hooks = (Ghc.hsc_hooks hscEnv) { Ghc.runPhaseHook = Just installHooks } }+ where+ installHooks :: Ghc.PhaseHook+ installHooks = Ghc.PhaseHook $ \phase -> case phase of+ Ghc.T_Hsc env modSum -> catch (runPhaseOrExistingHook phase)+ (\(Ghc.SourceError msgs) ->+ case any atParseErr $ Ghc.getMessages msgs of+ True | Just updatedBuffer <- updateBuffer =<< Ghc.ms_hspp_buf modSum+ -> do+ extractedNamesRef <- newIORef Map.empty+ let innerPlugin = mkInnerPlugin hscEnv extractedNamesRef+ updatedModSum = modSum { Ghc.ms_hspp_buf = Just updatedBuffer }+ staticPlugin = Ghc.StaticPlugin+ { Ghc.spPlugin = Ghc.PluginWithArgs innerPlugin []+#if MIN_VERSION_ghc(9,12,0)+ , Ghc.spInitialised = True+#endif+ }+ newEnv = env+ { Ghc.hsc_plugins = let plugins = Ghc.hsc_plugins hscEnv in plugins+ { Ghc.staticPlugins = staticPlugin : Ghc.staticPlugins plugins }+ }+ runPhaseOrExistingHook (Ghc.T_Hsc newEnv updatedModSum)+ _ -> throw $ Ghc.SourceError msgs+ )+ _ -> runPhaseOrExistingHook phase++ runPhaseOrExistingHook :: Ghc.TPhase res -> IO res+ runPhaseOrExistingHook =+ maybe Ghc.runPhase (\(Ghc.PhaseHook h) -> h)+ . Ghc.runPhaseHook $ Ghc.hsc_hooks hscEnv++ atParseErr msgEnv =+ case Ghc.errMsgDiagnostic msgEnv of+ Ghc.GhcPsMessage (Ghc.PsErrParse "@" _) -> True+ _ -> False++mkInnerPlugin :: Ghc.HscEnv -> IORef (Map.Map Ghc.Name [Ghc.Name]) -> Ghc.Plugin+mkInnerPlugin hscEnv extractedNamesRef = Ghc.defaultPlugin+ { Ghc.parsedResultAction = \_ _ result -> do+ pure $ rewriteToLet result+ , Ghc.renamedResultAction = \_ gblEnv grp -> do+ let (newNames, newGrp) = performExtractions gblEnv grp+ liftIO $ modifyIORef extractedNamesRef (Map.union (Map.fromList newNames))+ pure (gblEnv, newGrp)+ , Ghc.typeCheckResultAction = \_ tcModSum gblEnv -> do+ extractedNames <- liftIO $ readIORef extractedNamesRef+ let dynFlags = Ghc.ms_hspp_opts tcModSum `Ghc.gopt_set` Ghc.Opt_KeepRawTokenStream+ unitEnv = Ghc.hsc_unit_env hscEnv+ namePprCtx = Ghc.mkNamePprCtx (Ghc.initPromotionTickContext dynFlags) unitEnv (Ghc.tcg_rdr_env gblEnv)+ extractionParams <- Map.mapKeys nameToBS <$>+ Map.traverseWithKey+ (\nm args -> do+ ty <- Ghc.idType <$> Ghc.tcLookupId nm+ -- Converting Type to HsType would be tedious so instead we+ -- pretty print the Type and run it through the type parser.+ let tySDoc = Ghc.pprSigmaType ty+ tyStr = Ghc.showSDocForUser+ dynFlags { Ghc.pprCols = 5000 }+ (Ghc.hsc_units hscEnv)+ namePprCtx+ tySDoc+ mHsTy = either (const Nothing) (Just . EP.makeDeltaAst)+ $ EP.parseType dynFlags "" tyStr+ pure Extraction+ { argNames = Ghc.occName <$> args+ , extractedType = Ghc.unLoc <$> mHsTy+ }+ )+ extractedNames+ let extractErr =+ let fn = fromMaybe "<UNKNOWN>" $ Ghc.ml_hs_file (Ghc.ms_location tcModSum)+ in Ghc.mkPlainErrorMsgEnvelope+ (Ghc.mkGeneralSrcSpan $ fromString fn)+ (Ghc.ghcUnknownMessage ExtractDiag)++ case Ghc.ml_hs_file (Ghc.ms_location tcModSum) of+ Nothing -> pure gblEnv+ Just filePath -> do+ liftIO $ prepareSourceForParsing filePath+ parseResult <- liftIO $ parseModule hscEnv dynFlags filePath+ case parseResult of+ (Right parsedMod, usesCpp) ->+ liftIO $ modifyModule parsedMod usesCpp extractionParams filePath+ (Left _, _) -> pure ()+ Ghc.throwOneError extractErr+ }++updateBuffer :: Ghc.StringBuffer -> Maybe Ghc.StringBuffer+updateBuffer = fmap Ghc.stringBufferFromByteString . rewriteRawExtract . stringBufferToBS++rewriteRawExtract :: BS.ByteString -> Maybe BS.ByteString+rewriteRawExtract = update False+ where+ update matchFound bs =+ case BS.breakSubstring "EXTRACT@" bs of+ (before, "") -> if matchFound then Just before else Nothing+ (before, match) -> do+ let name = BS8.takeWhile (not . Char.isSpace) $ BS.drop 8 match+ guard . not $ BS.null name+ let rest = BS.drop (8 + BS.length name) match+ expr = "EXTRACT \"" <> name <> "\""+ newRest <- update True rest+ Just $ before <> expr <> newRest++stringBufferToBS :: Ghc.StringBuffer -> BS.ByteString+stringBufferToBS Ghc.StringBuffer {Ghc.buf = buf, Ghc.len = len} =+ BS.BS buf len++rewriteToLet :: Ghc.ParsedResult -> Ghc.ParsedResult+rewriteToLet result =+ let prm = Ghc.parsedResultModule result in result+ { Ghc.parsedResultModule = prm+ { Ghc.hpm_module = rewrite $ Ghc.hpm_module prm+ }+ }+ where+ rewrite = Syb.everywhere $ Syb.mkT appCase+ appCase :: Ghc.HsExpr Ghc.GhcPs -> Ghc.HsExpr Ghc.GhcPs+ appCase = \case+ ExtractPat bnd body -> mkRewrittenLet bnd body+ x -> x++-- | Parse the given module file. Accounts for CPP comments+parseModule+ :: Ghc.HscEnv+ -> Ghc.DynFlags+ -> FilePath+ -> IO (EP.ParseResult Ghc.ParsedSource, Bool)+parseModule env dynFlags filePath = EP.ghcWrapper Paths.libdir $ do+ Ghc.setSession env { Ghc.hsc_dflags = dynFlags }+ res <- EP.parseModuleEpAnnsWithCppInternal EP.defaultCppOptions dynFlags filePath+ let eCppComments = fmap (\(c, _, _) -> c) res+ hasCpp = case eCppComments of+ Right cs -> not $ null cs+ _ -> False+ pure+ ( liftA2 EP.insertCppComments+ (EP.postParseTransform res)+ eCppComments+ , hasCpp+ )++prepareSourceForParsing+ :: FilePath+ -> IO ()+prepareSourceForParsing filePath = do+ content <- BS.readFile filePath+ traverse_ (BS.writeFile filePath) (rewriteRawExtract content)++modifyModule+ :: Ghc.ParsedSource+ -> Bool+ -> ExtractedDecls+ -> FilePath+ -> IO ()+modifyModule parsedMod usesCpp extractedDecls filePath = do+ let ast = EP.makeDeltaAst parsedMod+ updatedDecls = modifyParsedDecls extractedDecls (runTransform $ EP.hsDecls ast)+ updatedMod = runTransform $ EP.replaceDecls ast updatedDecls+ -- If the source contains CPP, newlines are appended+ -- to the end of the file when exact printing. The simple+ -- solution is to remove trailing newlines after exact printing+ -- if the source contains CPP comments.+ let removeTrailingNewlines+ | usesCpp =+ reverse . ('\n' :) . dropWhile (== '\n') . reverse+ | otherwise = id+ printed = removeTrailingNewlines $ EP.exactPrint updatedMod+ writeFile filePath printed++#if MIN_VERSION_ghc(9,10,0)+runTransform :: a -> a+runTransform = id+#else+runTransform :: EP.Transform a -> a+runTransform t = case EP.runTransform t of+ (a, _, _) -> a+#endif++-- | Diagnostic thrown when extraction occurs+data ExtractDiag = ExtractDiag++instance Ghc.Diagnostic ExtractDiag where+ type DiagnosticOpts ExtractDiag = Ghc.NoDiagnosticOpts+ diagnosticMessage _ _ = Ghc.mkSimpleDecorated $+ Ghc.text "Module updated by auto-extract, compilation aborted"+ diagnosticReason _ = Ghc.ErrorWithoutFlag+ diagnosticHints _ = []+ diagnosticCode _ = Nothing+#if !MIN_VERSION_ghc(9,8,0)+ defaultDiagnosticOpts = Ghc.NoDiagnosticOpts+#endif
+ src/AutoExtract/Expr.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+module AutoExtract.Expr+ ( mkExtractionSig+ , mkExtractionDecl+ , mkRewrittenLet+ , pattern ExtractionLetExpr+ , mkExtractionBind+ , nameToBS+ ) where++import qualified Data.ByteString as BS+import qualified Language.Haskell.GHC.ExactPrint as EP++import qualified AutoExtract.GhcFacade as Ghc++mkExtractionSig :: Ghc.RdrName -> Ghc.HsType Ghc.GhcPs -> Ghc.LHsDecl Ghc.GhcPs+mkExtractionSig rdrName hsType =+ Ghc.L (Ghc.diffLine 2 0) $ Ghc.SigD Ghc.noExtField $+#if MIN_VERSION_ghc(9,12,0)+ Ghc.TypeSig+ (Ghc.AnnSig+ (Ghc.EpUniTok EP.d1 Ghc.NormalSyntax)+ Nothing+ Nothing+ )+ [Ghc.noLocA rdrName] $+ Ghc.HsWC Ghc.noExtField $ Ghc.L Ghc.anchorD1 $+ Ghc.HsSig Ghc.noExtField Ghc.mkHsOuterImplicit (Ghc.noLocA hsType)+#elif MIN_VERSION_ghc(9,10,0)+ Ghc.TypeSig+ (Ghc.AnnSig+ (Ghc.AddEpAnn Ghc.AnnDcolon EP.d1)+ []+ )+ [Ghc.noLocA rdrName] $+ Ghc.HsWC Ghc.noExtField $ Ghc.L Ghc.anchorD1 $+ Ghc.HsSig Ghc.noExtField Ghc.mkHsOuterImplicit (Ghc.noLocA hsType)+#else+ Ghc.TypeSig+ (Ghc.EpAnn+ (Ghc.Anchor Ghc.placeholderRealSpan EP.m0)+ (Ghc.AnnSig+ (Ghc.AddEpAnn Ghc.AnnDcolon EP.d1)+ []+ )+ Ghc.emptyComments+ )+ [Ghc.L (Ghc.diffLine 0 0) rdrName] $+ Ghc.HsWC Ghc.noExtField $ Ghc.L Ghc.anchorD1 $+ Ghc.HsSig Ghc.noExtField Ghc.mkHsOuterImplicit (Ghc.L (Ghc.diffLine 0 0) hsType)+#endif++--------------------------------------------------------------------------------++mkExtractionDecl+ :: Ghc.RdrName+ -> Ghc.LHsExpr Ghc.GhcPs+ -> [Ghc.GenLocated Ghc.SrcSpanAnnN Ghc.RdrName]+ -> Ghc.LHsDecl Ghc.GhcPs+mkExtractionDecl rdrName body arNames =+#if MIN_VERSION_ghc(9,12,0)+ Ghc.L (Ghc.diffLine 1 0) $+ Ghc.ValD Ghc.noExtField $ Ghc.FunBind Ghc.noExtField (Ghc.noLocA rdrName) $+ Ghc.MG Ghc.FromSource+ (Ghc.L Ghc.noSrcSpanA+ [Ghc.L Ghc.noAnn $ Ghc.Match+ Ghc.noExtField+ (Ghc.FunRhs (Ghc.noLocA rdrName) Ghc.Prefix Ghc.NoSrcStrict Ghc.noAnn)+ (Ghc.noLocA $ Ghc.L (Ghc.diffLine 0 1) . Ghc.VarPat Ghc.noExtField <$> arNames)+ grhss+ ]+ )+#elif MIN_VERSION_ghc(9,10,0)+ Ghc.L (Ghc.diffLine 1 1) $+ Ghc.ValD Ghc.noExtField $ Ghc.FunBind Ghc.noExtField (Ghc.L EP.noAnnSrcSpanDP0 rdrName) $+ Ghc.MG Ghc.FromSource+ (Ghc.L EP.noAnnSrcSpanDP0+ [Ghc.L Ghc.noAnn $ Ghc.Match+ []+ (Ghc.FunRhs (Ghc.L EP.noAnnSrcSpanDP0 rdrName) Ghc.Prefix Ghc.NoSrcStrict)+ (Ghc.L EP.noAnnSrcSpanDP0 . Ghc.VarPat Ghc.noExtField <$> arNames)+ grhss+ ]+ )+#else+ Ghc.L (Ghc.diffLine 1 0) $+ Ghc.ValD Ghc.noExtField $+ Ghc.FunBind Ghc.noExtField+ (Ghc.L (Ghc.diffLine 0 0) rdrName)+ $ Ghc.MG Ghc.FromSource+ (Ghc.L (Ghc.diffLine 0 0)+ [Ghc.L (Ghc.diffLine 0 0) $ Ghc.Match+ (Ghc.ann (Ghc.diffLine 0 0))+ (Ghc.FunRhs (Ghc.L (Ghc.diffLine 0 0) rdrName) Ghc.Prefix Ghc.NoSrcStrict)+ (Ghc.noLocA . Ghc.VarPat Ghc.noExtField <$> arNames)+ grhss+ ]+ )+#endif+ where+ grhss :: Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+#if MIN_VERSION_ghc(9,12,0)+ grhss = Ghc.GRHSs Ghc.emptyComments+ [Ghc.noLocA $ Ghc.GRHS+ (Ghc.EpAnn EP.d0+ (Ghc.GrhsAnn Nothing (Left (Ghc.EpTok EP.d1)))+ Ghc.emptyComments+ )+ []+ body+ ]+ (Ghc.EmptyLocalBinds Ghc.noExtField)+#elif MIN_VERSION_ghc(9,10,0)+ grhss = Ghc.GRHSs Ghc.emptyComments+ [Ghc.L Ghc.anchorD1 $ Ghc.GRHS+ (Ghc.EpAnn EP.d0+ (Ghc.GrhsAnn Nothing (Ghc.AddEpAnn Ghc.AnnEqual EP.d0))+ Ghc.emptyComments+ )+ []+ body+ ]+ (Ghc.EmptyLocalBinds Ghc.noExtField)+#else+ grhss = Ghc.GRHSs Ghc.emptyComments+ [Ghc.L Ghc.anchorD1 $ Ghc.GRHS+ (Ghc.EpAnn (Ghc.Anchor Ghc.placeholderRealSpan EP.m0)+ (Ghc.GrhsAnn Nothing (Ghc.AddEpAnn Ghc.AnnEqual EP.d0))+ Ghc.emptyComments+ )+ []+ body+ ]+ (Ghc.EmptyLocalBinds Ghc.noExtField)+#endif++--------------------------------------------------------------------------------++mkRewrittenLet+ :: Ghc.FastString+ -> Ghc.LHsExpr Ghc.GhcPs+ -> Ghc.HsExpr Ghc.GhcPs+mkRewrittenLet bnd body =+ let bndName = Ghc.mkVarUnqual $ bnd <> "_EXTRACT"+ mg :: Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+#if MIN_VERSION_ghc(9,12,0)+ mg = Ghc.MG Ghc.FromSource+ (Ghc.L Ghc.noSrcSpanA+ [Ghc.noLocA $ Ghc.Match+ Ghc.noExtField+ (Ghc.FunRhs (Ghc.noLocA bndName) Ghc.Prefix Ghc.SrcLazy Ghc.noAnn)+ (Ghc.noLocA [])+ grhss+ ]+ )+#elif MIN_VERSION_ghc(9,10,0)+ mg = Ghc.MG Ghc.FromSource+ (Ghc.L Ghc.noSrcSpanA+ [Ghc.noLocA $ Ghc.Match+ []+ (Ghc.FunRhs (Ghc.noLocA bndName) Ghc.Prefix Ghc.SrcLazy)+ []+ grhss+ ]+ )+#else+ mg = Ghc.MG Ghc.FromSource+ (Ghc.L Ghc.noSrcSpanA+ [Ghc.noLocA $ Ghc.Match+ Ghc.noAnn+ (Ghc.FunRhs (Ghc.noLocA bndName) Ghc.Prefix Ghc.SrcLazy)+ []+ grhss+ ]+ )+#endif+ grhss :: Ghc.GRHSs Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+#if MIN_VERSION_ghc(9,10,0)+ grhss = Ghc.GRHSs Ghc.emptyComments+ [Ghc.noLocA $ Ghc.GRHS Ghc.noSrcSpanA [] body]+ (Ghc.EmptyLocalBinds Ghc.noExtField)+#else+ grhss = Ghc.GRHSs Ghc.emptyComments+ [Ghc.noLocA $ Ghc.GRHS Ghc.noAnn [] body]+ (Ghc.EmptyLocalBinds Ghc.noExtField)+#endif+ expr :: Ghc.HsExpr Ghc.GhcPs+#if MIN_VERSION_ghc(9,10,0)+ expr = Ghc.HsLet Ghc.noAnn+ (Ghc.HsValBinds Ghc.noSrcSpanA+ (Ghc.ValBinds Ghc.NoAnnSortKey+ [ Ghc.noLocA $ Ghc.FunBind Ghc.noExtField (Ghc.noLocA bndName) mg ]+ []+ )+ )+ (Ghc.noLocA $ Ghc.HsVar Ghc.noExtField (Ghc.noLocA bndName))+#else+ expr = Ghc.HsLet Ghc.noAnn Ghc.noHsTok+ (Ghc.HsValBinds Ghc.noAnn+ (Ghc.ValBinds Ghc.NoAnnSortKey+ [ Ghc.noLocA $ Ghc.FunBind Ghc.noExtField (Ghc.noLocA bndName) mg ]+ []+ )+ )+ Ghc.noHsTok+ (Ghc.noLocA $ Ghc.HsVar Ghc.noExtField (Ghc.noLocA bndName))+#endif+ in expr++--------------------------------------------------------------------------------++pattern ExtractionLetExpr+ :: Ghc.FreeVars+ -> Ghc.Name+ -> Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+ -> Ghc.HsExpr Ghc.GhcRn+pattern ExtractionLetExpr freeVars bndName grhss <-+#if MIN_VERSION_ghc(9,12,0)+ Ghc.HsLet _+ (Ghc.HsValBinds _+ (Ghc.XValBindsLR+ (Ghc.NValBinds+ [ ( _recFlag+ , [ Ghc.L _+ (Ghc.FunBind freeVars (Ghc.L _ bndName)+ (Ghc.MG Ghc.FromSource+ (Ghc.L _+ [Ghc.L _+ (Ghc.Match+ _+ _+ _+ grhss@(Ghc.GRHSs _+ [Ghc.L _ (Ghc.GRHS _ [] _)]+ _+ )+ )+ ]+ )+ )+ )+ ]+ )+ ]+ []+ )+ )+ )+ _+#elif MIN_VERSION_ghc(9,10,0)+ Ghc.HsLet _+ (Ghc.HsValBinds _+ (Ghc.XValBindsLR+ (Ghc.NValBinds+ [ ( _recFlag+ , [ Ghc.L _+ (Ghc.FunBind freeVars (Ghc.L _ bndName)+ (Ghc.MG Ghc.FromSource+ (Ghc.L _+ [Ghc.L _+ (Ghc.Match+ _+ _+ _+ grhss@(Ghc.GRHSs _+ [Ghc.L _ (Ghc.GRHS _ [] _)]+ _+ )+ )+ ]+ )+ )+ )+ ]+ )+ ]+ []+ )+ )+ )+ _+#else+ Ghc.HsLet _ _+ (Ghc.HsValBinds _+ (Ghc.XValBindsLR+ (Ghc.NValBinds+ [ ( _recFlag+ , [ Ghc.L _+ (Ghc.FunBind freeVars (Ghc.L _ bndName)+ (Ghc.MG Ghc.FromSource+ (Ghc.L _+ [Ghc.L _+ (Ghc.Match+ _+ _+ _+ grhss@(Ghc.GRHSs _+ [Ghc.L _ (Ghc.GRHS _ [] _)]+ _+ )+ )+ ]+ )+ )+ )+ ]+ )+ ]+ []+ )+ )+ )+ _ _+#endif++--------------------------------------------------------------------------------++mkExtractionBind+ :: Ghc.FreeVars+ -> Ghc.Name+ -> [Ghc.Name]+ -> Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+ -> Ghc.HsBind Ghc.GhcRn+mkExtractionBind freeVars topLvlName args grhss =+#if MIN_VERSION_ghc(9,12,0)+ Ghc.FunBind freeVars (Ghc.noLocA topLvlName) $+ Ghc.MG Ghc.FromSource+ (Ghc.L Ghc.noSrcSpanA+ [Ghc.noLocA $ Ghc.Match+ Ghc.noExtField+ (Ghc.FunRhs (Ghc.noLocA topLvlName) Ghc.Prefix Ghc.SrcLazy Ghc.noAnn)+ (Ghc.noLocA $ Ghc.noLocA . Ghc.VarPat Ghc.noExtField . Ghc.noLocA <$> args)+ grhss+ ]+ )+#elif MIN_VERSION_ghc(9,10,0)+ Ghc.FunBind freeVars (Ghc.noLocA topLvlName) $+ Ghc.MG Ghc.FromSource+ (Ghc.L Ghc.noSrcSpanA+ [Ghc.noLocA $ Ghc.Match+ []+ (Ghc.FunRhs (Ghc.noLocA topLvlName) Ghc.Prefix Ghc.SrcLazy)+ (Ghc.noLocA . Ghc.VarPat Ghc.noExtField . Ghc.noLocA <$> args)+ grhss+ ]+ )+#else+ Ghc.FunBind freeVars (Ghc.noLocA topLvlName) $+ Ghc.MG Ghc.FromSource+ (Ghc.L Ghc.noSrcSpanA+ [Ghc.noLocA $ Ghc.Match+ Ghc.noAnn+ (Ghc.FunRhs (Ghc.noLocA topLvlName) Ghc.Prefix Ghc.SrcLazy)+ (Ghc.noLocA . Ghc.VarPat Ghc.noExtField . Ghc.noLocA <$> args)+ grhss+ ]+ )+#endif++nameToBS :: Ghc.HasOccName a => a -> BS.ByteString+nameToBS = Ghc.bytesFS . Ghc.occNameFS . Ghc.occName
+ src/AutoExtract/GhcFacade.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module AutoExtract.GhcFacade+ ( module Ghc+ , diffLine+ , anchorD1+ ) where++import GHC.Driver.Plugins as Ghc+import GHC as Ghc+import GHC.Utils.Outputable as Ghc+import GHC.Data.StringBuffer as Ghc+import GHC.Driver.Errors.Types as Ghc+import GHC.Parser.Errors.Types as Ghc+import GHC.Types.Error as Ghc+import GHC.Driver.Pipeline.Phases as Ghc+import GHC.Driver.Pipeline.Execute as Ghc+import GHC.Types.SourceError as Ghc+import GHC.Driver.Env as Ghc+import GHC.Driver.Hooks as Ghc+import GHC.Types.Name as Ghc+import GHC.Types.Name.Reader as Ghc+import GHC.Types.Basic as Ghc+import GHC.Tc.Types as Ghc (TcGblEnv(..))+import GHC.Types.Name.Set as Ghc+import GHC.Data.FastString as Ghc+import GHC.Tc.Utils.Env as Ghc+import GHC.Core.TyCo.Ppr as Ghc+import GHC.Utils.Error as Ghc+import GHC.Types.SrcLoc as Ghc+import GHC.Driver.Ppr as Ghc+import GHC.Types.Name.Ppr as Ghc+#if MIN_VERSION_ghc(9,8,0)+import GHC.Driver.DynFlags as Ghc+#else+import GHC.Driver.Session as Ghc+#endif++#if MIN_VERSION_ghc(9,10,0)+import qualified Language.Haskell.GHC.ExactPrint as EP+#endif++diffLine+ :: Int+ -> Int+#if MIN_VERSION_ghc(9,12,0)+ -> Ghc.NoAnn ann => Ghc.EpAnn ann+diffLine rowOffset colOffset =+ Ghc.EpAnn (Ghc.EpaDelta Ghc.noSrcSpan (Ghc.DifferentLine rowOffset colOffset) []) Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,10,0)+ -> Ghc.NoAnn ann => Ghc.EpAnn ann+diffLine rowOffset colOffset =+ Ghc.EpAnn (Ghc.EpaDelta (Ghc.DifferentLine rowOffset colOffset) []) Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,6,0)+ -> Monoid ann => Ghc.SrcAnn ann+diffLine rowOffset colOffset =+ Ghc.SrcSpanAnn+ (Ghc.EpAnn+ (Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor+ (if rowOffset == 0 then Ghc.SameLine colOffset else Ghc.DifferentLine rowOffset colOffset))+ )+ mempty+ Ghc.emptyComments+ )+ (Ghc.RealSrcSpan Ghc.placeholderRealSpan mempty)+#endif++anchorD1+#if MIN_VERSION_ghc(9,10,0)+ :: Ghc.NoAnn ann => Ghc.EpAnn ann+anchorD1 = Ghc.EpAnn EP.d1 Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,6,0)+ :: Monoid ann => Ghc.SrcAnn ann++-- blarg+instance Monoid Ghc.NoEpAnns where+ mempty = Ghc.NoEpAnns++anchorD1 =+ Ghc.SrcSpanAnn+ (Ghc.EpAnn+ (Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.SameLine 1)))+ mempty+ Ghc.emptyComments+ )+ Ghc.generatedSrcSpan+#endif
+ src/AutoExtract/Parser.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module AutoExtract.Parser+ ( Extraction(..)+ , ExtractedDecls+ , modifyParsedDecls+ , pattern ExtractPat+ ) where++import qualified Control.Monad.Trans.Writer.CPS as W+#if !MIN_VERSION_ghc(9,10,0)+import Data.Foldable -- foldl'+#endif+import qualified Data.ByteString as BS+import qualified Data.Generics as Syb+import qualified Data.Map.Strict as Map++import AutoExtract.Expr+import qualified AutoExtract.GhcFacade as Ghc++type ExtractedDecls = Map.Map BS.ByteString Extraction++data Extraction = Extraction+ { argNames :: [Ghc.OccName]+ , extractedType :: Maybe (Ghc.HsType Ghc.GhcPs)+ }+++modifyParsedDecls :: ExtractedDecls -> [Ghc.LHsDecl Ghc.GhcPs] -> [Ghc.LHsDecl Ghc.GhcPs]+modifyParsedDecls extrDecls = foldMap go+ where+ go decl =+ let (updDecl, newDecls) = W.runWriter $ Syb.everywhereM (Syb.mkM extract) decl+ in updDecl : newDecls+ extract :: Ghc.HsExpr Ghc.GhcPs -> W.Writer [Ghc.LHsDecl Ghc.GhcPs] (Ghc.HsExpr Ghc.GhcPs)+ extract = \case+ ExtractPat bnd body+ | Just inputs <- Map.lookup (Ghc.bytesFS bnd) extrDecls+ -> decls bnd body inputs+ x -> pure x++ decls :: Ghc.FastString -> Ghc.LHsExpr Ghc.GhcPs -> Extraction -> W.Writer [Ghc.LHsDecl Ghc.GhcPs] (Ghc.HsExpr Ghc.GhcPs)+ decls bnd body inputs =+ let rdrName = Ghc.mkRdrUnqual $ Ghc.mkVarOccFS bnd+ arNames = Ghc.L Ghc.anchorD1 . Ghc.mkRdrUnqual <$> argNames inputs+ callsite = foldl'+ (\acc arg ->+#if MIN_VERSION_ghc(9,10,0)+ Ghc.HsApp+ Ghc.noExtField+ (Ghc.noLocA acc)+ (Ghc.L Ghc.noAnn $ Ghc.HsVar Ghc.noExtField arg)+#else+ Ghc.HsApp+ Ghc.noComments+ (Ghc.noLocA acc)+ (Ghc.L Ghc.noSrcSpanA $ Ghc.HsVar Ghc.noExtField arg)+#endif+ )+ (Ghc.HsVar Ghc.noExtField $ Ghc.noLocA rdrName)+ arNames+ newDecl :: Ghc.LHsDecl Ghc.GhcPs+ newDecl = mkExtractionDecl rdrName body arNames+ mSig :: Maybe (Ghc.LHsDecl Ghc.GhcPs)+ mSig = do+ hsType <- extractedType inputs+ Just $ mkExtractionSig rdrName hsType+ in W.writer (callsite, maybe id (:) mSig [newDecl])++pattern ExtractPat :: Ghc.FastString -> Ghc.LHsExpr Ghc.GhcPs -> Ghc.HsExpr Ghc.GhcPs+pattern ExtractPat bnd body+ <- Ghc.HsApp _+ (Ghc.L _+ (Ghc.HsApp _+ (Ghc.L _ (Ghc.HsVar _ (Ghc.L _ (nameToBS -> "EXTRACT"))))+ (Ghc.L _ (Ghc.HsLit _ (Ghc.HsString _ bnd)))+ )+ )+ (removeParens -> body)++removeParens :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs+#if MIN_VERSION_ghc(9,10,0)+removeParens (Ghc.L l (Ghc.HsPar _ (Ghc.L _ x))) = Ghc.L l (doIndentCorrect x)+#else+removeParens (Ghc.L l (Ghc.HsPar _ _ (Ghc.L _ x) _)) = Ghc.L l x+#endif+removeParens x = x++-- | exact-print 9.10 has indentation issues. This corrects for do blocks.+#if MIN_VERSION_ghc(9,12,0)+doIndentCorrect :: Ghc.HsExpr Ghc.GhcPs -> Ghc.HsExpr Ghc.GhcPs+doIndentCorrect x = x+#elif MIN_VERSION_ghc(9,10,0)+doIndentCorrect :: Ghc.HsExpr Ghc.GhcPs -> Ghc.HsExpr Ghc.GhcPs+doIndentCorrect (Ghc.HsDo ann t (Ghc.L l2 s)) =+ let addCol = \case+ Ghc.EpaDelta (Ghc.DifferentLine r c) a ->+ Ghc.EpaDelta (Ghc.DifferentLine r (c + 1)) a+ x -> x+ in Ghc.HsDo ann t (Ghc.L l2 {Ghc.entry = addCol (Ghc.entry l2)} s)+doIndentCorrect x = x+#else+#endif
+ src/AutoExtract/Renamer.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module AutoExtract.Renamer+ ( performExtractions+ ) where++import qualified Control.Monad.Trans.Writer.CPS as W+import qualified Data.ByteString as BS+import Data.Foldable+import qualified Data.Generics as Syb+import qualified GHC.IsList as IsList++import AutoExtract.Expr+import qualified AutoExtract.GhcFacade as Ghc++performExtractions+ :: Ghc.TcGblEnv+ -> Ghc.HsGroup Ghc.GhcRn+ -> ([(Ghc.Name, [Ghc.Name])], Ghc.HsGroup Ghc.GhcRn)+performExtractions gblEnv grp =+ case Ghc.hs_valds grp of+ Ghc.XValBindsLR (Ghc.NValBinds bndTups sigs)+ | let extracted = bndExtract <$> bndTups ->+ ( foldMap snd extracted+ , grp+ { Ghc.hs_valds = Ghc.XValBindsLR (Ghc.NValBinds (fst <$> extracted) sigs) }+ )+ _ -> ([], grp)+ where+ bndExtract+ :: (Ghc.RecFlag, Ghc.LHsBinds Ghc.GhcRn)+ -> ((Ghc.RecFlag, Ghc.LHsBinds Ghc.GhcRn), [(Ghc.Name, [Ghc.Name])])+ bndExtract inp@(_, bnds) =+ let (newBnds, newNames) = foldMap extract bnds+ in if null newNames+ then (inp, [])+ else ((Ghc.Recursive, IsList.fromList newBnds), newNames)++ extract :: Ghc.LHsBind Ghc.GhcRn -> ([Ghc.LHsBind Ghc.GhcRn], [(Ghc.Name, [Ghc.Name])])+ extract (Ghc.L loc bind) =+ let (updated, (newBinds, newNames)) = W.runWriter $+ everywhereCtx+ (\w ->+ let newDeclNames = fst <$> snd w+ in Syb.mkM (rewriteAndExtract newDeclNames) `Syb.extM` addFVs newDeclNames+ )+ bind+ rewriteAndExtract+ :: [Ghc.Name]+ -> Ghc.HsExpr Ghc.GhcRn+ -> W.Writer ([Ghc.HsBind Ghc.GhcRn], [(Ghc.Name, [Ghc.Name])]) (Ghc.HsExpr Ghc.GhcRn)+ rewriteAndExtract newDeclNames = \case+ ExtractionLetExpr freeVars bndName grhss+ | Just occNameBS <- BS.stripSuffix "_EXTRACT" $ nameToBS bndName+ -> let args = Ghc.nameSetElemsStable+ . Ghc.delFVs newDeclNames+ $ freeVars `Ghc.minusNameSet` topLevelNames+ topLvlName = Ghc.tidyNameOcc bndName (Ghc.mkVarOccFS $ Ghc.mkFastStringByteString occNameBS)+ newBind = mkExtractionBind freeVars topLvlName args grhss+ newExpr =+ foldl'+ (\acc arg ->+ Ghc.HsApp+#if MIN_VERSION_ghc(9,10,0)+ Ghc.noExtField+#else+ Ghc.noComments+#endif+ (Ghc.noLocA acc)+ (Ghc.noLocA $ Ghc.HsVar Ghc.noExtField (Ghc.noLocA arg)))+ (Ghc.HsVar Ghc.noExtField (Ghc.noLocA topLvlName))+ args+ in W.writer (newExpr, ([newBind], [(topLvlName, args)]))++ x -> pure x++ addFVs :: Monad m+ => [Ghc.Name]+ -> Ghc.HsBind Ghc.GhcRn+ -> m (Ghc.HsBind Ghc.GhcRn)+ addFVs newDeclNames = \case+ Ghc.FunBind fvs a b ->+ pure $ Ghc.FunBind (Ghc.extendNameSetList fvs newDeclNames) a b+#if MIN_VERSION_ghc(9,10,0)+ Ghc.PatBind fvs a b c ->+ pure $ Ghc.PatBind (Ghc.extendNameSetList fvs newDeclNames) a b c+#else+ Ghc.PatBind fvs a b ->+ pure $ Ghc.PatBind (Ghc.extendNameSetList fvs newDeclNames) a b+#endif+ x -> pure x++ in (Ghc.L loc updated : (Ghc.noLocA <$> reverse newBinds), newNames)++ topLevelNames :: Ghc.NameSet+ topLevelNames = foldMap (fold . fst) $ Ghc.tcg_dus gblEnv++-- | Custom scheme that allows a transformation to inspect the context within+-- a bottom up traversal.+everywhereCtx+ :: forall w. Monoid w+ => (w -> Syb.GenericM (W.Writer w))+ -> Syb.GenericM (W.Writer w)+everywhereCtx f = go where+ go :: Syb.GenericM (W.Writer w)+ go x = do+ (x', w) <- W.listen $ Syb.gmapM go x+ f w x'
+ test/Main.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Control.Monad+import Test.Tasty+import Test.Tasty.HUnit+import qualified System.Directory as Dir+import qualified System.Process as Proc++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ testGroup "case"+ [ testCase "1" $ runTest "Case1.hs"+ , testCase "2" $ runTest "Case2.hs"+ , testCase "3" $ runTest "Case3.hs"+ , testCase "4" $ runTest "Case4.hs"+ , testCase "5" $ runTest "Case5.hs"+ , testCase "6" $ runTest "Case6.hs"+ , testCase "7" $ runTest "Case7.hs"+ , testCase "8" $ runTest "Case8.hs"+ , testCase "9" $ runTest "Case9.hs"+#if MIN_VERSION_ghc(9,12,0) || !MIN_VERSION_ghc(9,10,0)+ , testCase "10a" $ runTest "Case10a.hs"+#else+ , testCase "10b" $ runTest "Case10b.hs" -- 9.10 indentation issue+#endif+ , testCase "11" $ runTest "Case11.hs"+ , testCase "12" $ runTest "Case12.hs"+ ]+ ]++testModulePath :: String -> FilePath+testModulePath name = "test-modules/" <> name++-- copy the input file contents to the module file to be compiled+prepTest :: FilePath -> IO ()+prepTest modFile = do+ inp <- readFile (modFile ++ ".input")+ writeFile modFile inp++runTest :: FilePath -> Assertion+runTest name = do+ let modFile = testModulePath name+ prepTest modFile+ (_, _, _, h) <- Proc.createProcess $+ Proc.proc "cabal" ["build", "test-modules:" ++ takeWhile (/= '.') name]+ void $ Proc.waitForProcess h+ updatedMod <- readFile modFile+ expectedMod <- readFile $ modFile ++ ".expected"+ assertEqual "Expected update" expectedMod updatedMod+ Dir.removeFile modFile