diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for auto-export + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,71 @@ +# auto-export :outbox_tray: + +This is a GHC plugin that edits the file being compiled by adding a target +top-level definition to the explicit export list of the module. + +### 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-export` plugin enabled (you may need to add `auto-export` to your +`extra-deps` first): + +``` +stack repl my-project --package auto-export --ghci-options='-fplugin AutoExport' +``` + +likewise for a cabal project (you may need to run `cabal update` first): + +``` +cabal repl my-project --build-depends auto-export --repl-options='-fplugin AutoExport' +``` + +With the plugin enabled, mark the expression to be exported by placing +`!EXPORT` on a line above it then compile the module. If the module has an +explicit export list, the definition will be automatically added to it. +Compilation is aborted after the code is updated. + +For example, given this program: + +```haskell +module M () where + +data Colors = Red | Green | Blue + deriving (Enum, Bounded) + +allColors :: [Colors] +allColors = [minBound .. maxBound] +``` + +Insert the export targets: + +```haskell +module M () where + +!EXPORT +data Colors = Red | Green | Blue + deriving (Enum, Bounded) + +!EXPORT +allColors :: [Colors] +allColors = [minBound .. maxBound] +``` + +Compiling the module will result in the source code being updated to: + +```haskell +module M (Colors(..), allColors) where + +data Colors = Red | Green | Blue + deriving (Enum, Bounded) + +allColors :: [Colors] +allColors = [minBound .. maxBound] +``` + +Data declarations and type classes are always exported in full using `(..)`. + +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. diff --git a/auto-export.cabal b/auto-export.cabal new file mode 100644 --- /dev/null +++ b/auto-export.cabal @@ -0,0 +1,55 @@ +cabal-version: 3.0 +name: auto-export +version: 0.1.0.0 +synopsis: Automatically add things to module export list +description: Automatically add things to module export list using a GHC plugin +license: BSD-3-Clause +license-file: LICENSE +author: Aaron Allen +maintainer: aaronallen8455@gmail.com +copyright: 2025 Aaron Allen +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-export + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: AutoExport + AutoExport.GhcFacade + -- other-modules: + default-extensions: LambdaCase + build-depends: base < 5, + ghc >= 9.6 && < 9.13, + bytestring < 0.13, + mtl >= 2.3, + ghc-exactprint, + ghc-paths, + containers + hs-source-dirs: src + default-language: GHC2021 + +test-suite auto-export-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 diff --git a/src/AutoExport.hs b/src/AutoExport.hs new file mode 100644 --- /dev/null +++ b/src/AutoExport.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module AutoExport + ( plugin + ) where + +import Control.Exception +import Control.Monad.IO.Class (liftIO) +import qualified Control.Monad.Writer.CPS as W +import qualified Data.ByteString as BS hiding (uncons) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Internal as BS +import qualified Data.Char as Char +import Data.Maybe +import Data.Monoid +import qualified Data.Set as Set +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 qualified AutoExport.GhcFacade as Ghc + +plugin :: Ghc.Plugin +plugin = Ghc.defaultPlugin + { Ghc.driverPlugin = const modifyHscEnv + , Ghc.pluginRecompile = mempty + } + +modifyHscEnv :: Ghc.HscEnv -> IO Ghc.HscEnv +modifyHscEnv hscEnv = + pure hscEnv { Ghc.hsc_hooks = modifyHooks (Ghc.hsc_hooks hscEnv) } + where + isExportError msgEnv = + case Ghc.errMsgDiagnostic msgEnv of + Ghc.GhcPsMessage (Ghc.PsErrBangPatWithoutSpace (Ghc.L _ (Ghc.HsVar _ (Ghc.L _ rdr)))) + | "EXPORT" <- rdrNameFS rdr -> True + _ -> False + + modifyHooks hooks = + let runPhaseOrExistingHook :: Ghc.TPhase res -> IO res + runPhaseOrExistingHook = maybe Ghc.runPhase (\(Ghc.PhaseHook h) -> h) + $ Ghc.runPhaseHook hooks + phaseHook :: Ghc.PhaseHook + phaseHook = Ghc.PhaseHook $ \phase -> case phase of + Ghc.T_Hsc env modSum -> catch (runPhaseOrExistingHook phase) $ + \ (Ghc.SourceError msgs) -> + case any isExportError $ Ghc.getMessages msgs of + True | Just updatedBuffer <- modifyBuffer =<< Ghc.ms_hspp_buf modSum + -> do + let innerPlugin = mkInnerPlugin hscEnv + 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 + in hooks + { Ghc.runPhaseHook = Just phaseHook } + +rdrNameFS :: Ghc.RdrName -> Ghc.FastString +rdrNameFS = Ghc.occNameFS . Ghc.rdrNameOcc + +modifyBuffer :: Ghc.StringBuffer -> Maybe Ghc.StringBuffer +modifyBuffer = fmap Ghc.stringBufferFromByteString . rewriteRawExtract . stringBufferToBS + +stringBufferToBS :: Ghc.StringBuffer -> BS.ByteString +stringBufferToBS Ghc.StringBuffer {Ghc.buf = buf, Ghc.len = len} = + BS.BS buf len + +rewriteRawExtract :: BS.ByteString -> Maybe BS.ByteString +rewriteRawExtract = toMaybe . W.runWriter . traverse update . BS.lines + where + update x | isExportCmd x = W.writer ("{-# ANN EXPORT () #-}", Any True) + | otherwise = pure x + toMaybe (x, Any True) = Just $ BS.unlines x + toMaybe _ = Nothing + +removeExportCmds :: BS.ByteString -> BS.ByteString +removeExportCmds = BS.unlines . filter (not . isExportCmd) . BS.lines + +isExportCmd :: BS.ByteString -> Bool +isExportCmd = (== "!EXPORT") . BS.strip + +mkInnerPlugin :: Ghc.HscEnv -> Ghc.Plugin +mkInnerPlugin hscEnv = Ghc.defaultPlugin + { Ghc.parsedResultAction = \_ modSum result -> do + let newExportItems = + getExports . Ghc.hsmodDecls . Ghc.unLoc . Ghc.hpm_module + $ Ghc.parsedResultModule result + case Ghc.ml_hs_file (Ghc.ms_location modSum) of + Nothing -> pure result + Just filePath -> do + liftIO $ prepareSourceForParsing filePath + let dynFlags = Ghc.ms_hspp_opts modSum `Ghc.gopt_set` Ghc.Opt_KeepRawTokenStream + parseResult <- liftIO $ parseModule hscEnv dynFlags filePath + case parseResult of + (Right parsedMod, usesCpp) -> + liftIO $ modifyModule parsedMod usesCpp newExportItems filePath + (Left _, _) -> pure () + + let exportErr = + let fn = fromMaybe "" $ Ghc.ml_hs_file (Ghc.ms_location modSum) + in Ghc.mkPlainErrorMsgEnvelope + (Ghc.mkGeneralSrcSpan $ fromString fn) + (Ghc.ghcUnknownMessage ExportDiag) + Ghc.throwOneError exportErr + } + +modifyModule + :: Ghc.ParsedSource + -> Bool + -> [Ghc.IE Ghc.GhcPs] + -> FilePath + -> IO () +modifyModule parsedMod usesCpp newIEs filePath = do + putStrLn . Ghc.showSDocUnsafe $ Ghc.ppr newIEs + let ast = EP.makeDeltaAst parsedMod + addIEs m = m + { Ghc.hsmodExports = fmap (addExports newIEs) <$> Ghc.hsmodExports m } + updatedMod = addIEs <$> ast + -- 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 + +addExports :: [Ghc.IE Ghc.GhcPs] -> [Ghc.LIE Ghc.GhcPs] -> [Ghc.LIE Ghc.GhcPs] +addExports [] lies = lies +addExports newIEs lies = liesWithComma ++ newIEsWithCommas + where + existingNames = Set.fromList $ Ghc.ieName . Ghc.unLoc <$> lies + iesToAdd = filter ((`Set.notMember` existingNames) . Ghc.ieName) newIEs + addComma (Ghc.L l ie) = Ghc.L (EP.addComma l) ie + liesWithComma = case reverse lies of + l : ls -> reverse $ addComma l : ls + [] -> [] + newIEsWithCommas = case reverse (Ghc.L Ghc.anchorD1 <$> iesToAdd) of + l : ls -> reverse $ l : (addComma <$> ls) + [] -> [] + +getExports :: [Ghc.LHsDecl Ghc.GhcPs] -> [Ghc.IE Ghc.GhcPs] +getExports (Ghc.L _ a : Ghc.L locB b : rest) + | Ghc.AnnD _ (Ghc.HsAnnotation _ prov _) <- a + , Ghc.ValueAnnProvenance (Ghc.L _ rdrName) <- prov + , "EXPORT" <- rdrNameFS rdrName + , ies <- mkIE b + = ies ++ getExports (Ghc.L locB b : rest) + | otherwise = getExports (Ghc.L locB b : rest) +getExports _ = [] + +mkIE :: Ghc.HsDecl Ghc.GhcPs -> [Ghc.IE Ghc.GhcPs] +mkIE = \case + Ghc.TyClD _ tyCl -> + let getTyName = Ghc.unLoc . Ghc.tyClDeclLName + in case tyCl of + _ | Ghc.isTypeFamilyDecl tyCl -> [mkThingAbsIE (getTyName tyCl)] + _ | Ghc.isDataFamilyDecl tyCl -> [mkThingAllIE False (getTyName tyCl)] + Ghc.SynDecl{} -> [mkThingAbsIE (getTyName tyCl)] + _ -> [mkThingAllIE (isTypeData tyCl) (getTyName tyCl)] + Ghc.ValD _ (Ghc.FunBind _ (Ghc.L _ name) _) -> [mkVarIE name] + Ghc.ValD _ (Ghc.PatSynBind _ psb) -> [mkPatternIE (Ghc.unLoc $ Ghc.psb_id psb)] + Ghc.SigD _ sig -> case sig of + Ghc.TypeSig _ names _ -> mkVarIE . Ghc.unLoc <$> names + Ghc.PatSynSig _ names _ -> mkPatternIE . Ghc.unLoc <$> names + _ -> [] + Ghc.KindSigD _ (Ghc.StandaloneKindSig _ (Ghc.L _ name) _) -> [mkThingAbsIE name] + Ghc.ForD _ for -> [mkVarIE . Ghc.unLoc $ Ghc.fd_name for] + Ghc.InstD _ Ghc.DataFamInstD{Ghc.dfid_inst = inst} -> + [mkThingAllIE False . Ghc.unLoc . Ghc.feqn_tycon $ Ghc.dfid_eqn inst] + _ -> [] + where + mkThingAllIE :: Bool -> Ghc.RdrName -> Ghc.IE Ghc.GhcPs + mkThingAllIE isTyData name = + Ghc.IEThingAll Ghc.ieThingAllAnn + (Ghc.L Ghc.noSrcSpanA + (if isOperator name || isTyData + then + Ghc.IEType Ghc.ieTypeAnn + (addOpParens $ Ghc.L Ghc.anchorD1 name) + else + Ghc.IEName Ghc.noExtField + (addOpParens $ Ghc.L Ghc.anchorD0 name) + ) + ) +#if MIN_VERSION_ghc(9,10,0) + Nothing +#endif + mkVarIE :: Ghc.RdrName -> Ghc.IE Ghc.GhcPs + mkVarIE name = Ghc.ieVar + (Ghc.L Ghc.noSrcSpanA + (Ghc.IEName Ghc.noExtField . addOpParens $ Ghc.L Ghc.anchorD0 name) + ) + mkPatternIE :: Ghc.RdrName -> Ghc.IE Ghc.GhcPs + mkPatternIE name = Ghc.ieThingAbs + (Ghc.L Ghc.noSrcSpanA + (Ghc.IEPattern Ghc.iePatternAnn + (addOpParens $ Ghc.L Ghc.anchorD1 name) + ) + ) + mkThingAbsIE :: Ghc.RdrName -> Ghc.IE Ghc.GhcPs + mkThingAbsIE name = Ghc.ieThingAbs + (Ghc.L Ghc.noSrcSpanA + (if isOperator name + then + Ghc.IEType Ghc.ieTypeAnn + (addOpParens $ Ghc.L Ghc.anchorD1 name) + else + Ghc.IEName + Ghc.noExtField + (addOpParens $ Ghc.L Ghc.anchorD0 name) + ) + ) + -- Adds parens for operators + addOpParens :: Ghc.LIdP Ghc.GhcPs -> Ghc.LIdP Ghc.GhcPs + addOpParens (Ghc.L loc name) + | isOperator name = + Ghc.L +#if MIN_VERSION_ghc(9,10,0) + (loc { Ghc.anns = Ghc.nameAnnParens }) +#else + (loc { Ghc.ann = case Ghc.ann loc of + Ghc.EpAnnNotUsed -> Ghc.noAnn -- doesn't happen + a -> a { Ghc.anns = Ghc.nameAnnParens } + }) +#endif + name + | otherwise = Ghc.L loc name + + isTypeData = \case + Ghc.DataDecl { Ghc.tcdDataDefn = defn } -> + Ghc.isTypeDataDefnCons $ Ghc.dd_cons defn + _ -> False + +isOperator :: Ghc.RdrName -> Bool +isOperator name = + case BS.uncons (Ghc.bytesFS $ rdrNameFS name) of + Nothing -> False + Just (c, _) -> + c /= '_' && not (Char.isAlpha c) + +-- | 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 + ) + +-- | Diagnostic thrown when extraction occurs +data ExportDiag = ExportDiag + +instance Ghc.Diagnostic ExportDiag where + type DiagnosticOpts ExportDiag = Ghc.NoDiagnosticOpts + diagnosticMessage _ _ = Ghc.mkSimpleDecorated $ + Ghc.text "Module updated by auto-export, compilation aborted" + diagnosticReason _ = Ghc.ErrorWithoutFlag + diagnosticHints _ = [] + diagnosticCode _ = Nothing +#if !MIN_VERSION_ghc(9,8,0) + defaultDiagnosticOpts = Ghc.NoDiagnosticOpts +#endif + + +prepareSourceForParsing + :: FilePath + -> IO () +prepareSourceForParsing filePath = do + content <- BS.readFile filePath + BS.writeFile filePath (removeExportCmds content) diff --git a/src/AutoExport/GhcFacade.hs b/src/AutoExport/GhcFacade.hs new file mode 100644 --- /dev/null +++ b/src/AutoExport/GhcFacade.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module AutoExport.GhcFacade + ( module Ghc + , ieThingAllAnn + , ieTypeAnn + , iePatternAnn + , nameAnnParens + , anchorD1 + , anchorD0 + , ieVar + , ieThingAbs + ) where + +import GHC.Driver.Plugins as Ghc +import GHC.Driver.Env.Types as Ghc +import GHC.Driver.Hooks as Ghc +import GHC.Driver.Pipeline.Phases as Ghc +import GHC.Driver.Pipeline.Execute as Ghc +import GHC.Types.SourceError as Ghc +import GHC.Types.Error as Ghc +import GHC.Unit.Module.ModSummary as Ghc +import Language.Haskell.Syntax.Expr as Ghc +import GHC.Driver.Errors.Types as Ghc +import GHC.Parser.Errors.Types as Ghc +import GHC.Types.SrcLoc as Ghc +import GHC.Types.Name.Reader as Ghc +import GHC.Types.Name.Occurrence as Ghc +import GHC.Data.FastString as Ghc +import GHC.Data.StringBuffer as Ghc +import Language.Haskell.Syntax.Decls as Ghc +import GHC.Hs.Extension as Ghc +import Language.Haskell.Syntax.ImpExp as Ghc +import GHC.Hs as Ghc +import GHC.Driver.Monad as Ghc +import GHC as Ghc +import GHC.Utils.Outputable as Ghc +import GHC.Utils.Error as Ghc +#if MIN_VERSION_ghc(9,8,0) +import GHC.Driver.DynFlags as Ghc +#else +import GHC.Driver.Session as Ghc +#endif + +import qualified Language.Haskell.GHC.ExactPrint as EP + +ieThingAllAnn :: Ghc.XIEThingAll Ghc.GhcPs +ieThingAllAnn = +#if MIN_VERSION_ghc(9,12,0) + (Nothing, (Ghc.EpTok EP.d0, Ghc.EpTok EP.d0, Ghc.EpTok EP.d0)) +#elif MIN_VERSION_ghc(9,10,0) + (Nothing, [ Ghc.AddEpAnn Ghc.AnnOpenP EP.d0 + , Ghc.AddEpAnn Ghc.AnnDotdot EP.d0 + , Ghc.AddEpAnn Ghc.AnnCloseP EP.d0 + ] + ) +#elif MIN_VERSION_ghc(9,8,0) + ( Nothing + , Ghc.EpAnn + (Ghc.Anchor Ghc.placeholderRealSpan EP.m0) + [ Ghc.AddEpAnn Ghc.AnnOpenP EP.d0 + , Ghc.AddEpAnn Ghc.AnnDotdot EP.d0 + , Ghc.AddEpAnn Ghc.AnnCloseP EP.d0 ] + Ghc.emptyComments + ) +#else + Ghc.EpAnn + (Ghc.Anchor Ghc.placeholderRealSpan EP.m0) + [ Ghc.AddEpAnn Ghc.AnnOpenP EP.d0 + , Ghc.AddEpAnn Ghc.AnnDotdot EP.d0 + , Ghc.AddEpAnn Ghc.AnnCloseP EP.d0 ] + Ghc.emptyComments +#endif + +ieTypeAnn :: Ghc.XIEType Ghc.GhcPs +ieTypeAnn = +#if MIN_VERSION_ghc(9,12,0) + (Ghc.EpTok EP.d0) +#else + EP.d0 +#endif + +iePatternAnn :: Ghc.XIEPattern Ghc.GhcPs +iePatternAnn = +#if MIN_VERSION_ghc(9,12,0) + (Ghc.EpTok EP.d0) +#else + EP.d0 +#endif + +nameAnnParens :: Ghc.NameAnn +nameAnnParens = +#if MIN_VERSION_ghc(9,12,0) + Ghc.NameAnn + { Ghc.nann_adornment = Ghc.NameParens (Ghc.EpTok EP.d0) (Ghc.EpTok EP.d0) + , Ghc.nann_name = EP.d0 + , Ghc.nann_trailing = [] + } +#else + Ghc.NameAnn + { Ghc.nann_adornment = Ghc.NameParens + , Ghc.nann_open = EP.d0 + , Ghc.nann_name = EP.d0 + , Ghc.nann_close = EP.d0 + , Ghc.nann_trailing = [] + } +#endif + +anchorD1, anchorD0 +#if MIN_VERSION_ghc(9,10,0) + :: Ghc.NoAnn ann => Ghc.EpAnn ann +anchorD1 = EP.noAnnSrcSpanDP1 +anchorD0 = EP.noAnnSrcSpanDP0 +#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 +anchorD0 = + Ghc.SrcSpanAnn + (Ghc.EpAnn + (Ghc.Anchor Ghc.placeholderRealSpan Ghc.UnchangedAnchor) + mempty + Ghc.emptyComments + ) + Ghc.generatedSrcSpan +#endif + +ieVar :: Ghc.LIEWrappedName Ghc.GhcPs -> Ghc.IE Ghc.GhcPs +ieVar name = + Ghc.IEVar +#if MIN_VERSION_ghc(9,10,0) + Ghc.noAnn +#elif MIN_VERSION_ghc(9,8,0) + Nothing +#else + Ghc.noExtField +#endif + name +#if MIN_VERSION_ghc(9,10,0) + Nothing +#endif + +ieThingAbs :: Ghc.LIEWrappedName Ghc.GhcPs -> Ghc.IE Ghc.GhcPs +ieThingAbs name = + Ghc.IEThingAbs +#if MIN_VERSION_ghc(9,10,0) + Ghc.noAnn +#elif MIN_VERSION_ghc(9,8,0) + (Nothing, Ghc.noAnn) +#else + Ghc.noAnn +#endif + name +#if MIN_VERSION_ghc(9,10,0) + Nothing +#endif diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,51 @@ +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" + [ testCase "Class1" $ runTest "Class1.hs" + , testCase "Data1" $ runTest "Data1.hs" + , testCase "Data2" $ runTest "Data2.hs" + , testCase "Data3" $ runTest "Data3.hs" + , testCase "Data4" $ runTest "Data4.hs" + , testCase "KindSig1" $ runTest "KindSig1.hs" + , testCase "Pat1" $ runTest "Pat1.hs" + , testCase "Pat2" $ runTest "Pat2.hs" + , testCase "Ty1" $ runTest "Ty1.hs" + , testCase "Ty2" $ runTest "Ty2.hs" + , testCase "Ty3" $ runTest "Ty3.hs" + , testCase "Ty4" $ runTest "Ty4.hs" + , testCase "Ty5" $ runTest "Ty5.hs" + , testCase "Ty6" $ runTest "Ty6.hs" + , testCase "Var1" $ runTest "Var1.hs" + , testCase "Var2" $ runTest "Var2.hs" + , testCase "Var3" $ runTest "Var3.hs" + , testCase "Var4" $ runTest "Var4.hs" + , testCase "Var5" $ runTest "Var5.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