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-import + +## 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,94 @@ +# auto-import :inbox_tray: + +A GHC plugin that automatically adds import statements to the module being compiled. + +### 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. + +You must first define a config file that specifies which modules are eligible +to be automatically imported. By default this file is named `.autoimport` and +can be placed in the home directory and/or in the root directory of your +Haskell project. If the file is found in both locations, the configs will be +merged with the local file taking precedence. The local file path can be overriden +by passing this plugin option to GHC: `fplugin-opt=AutoImport:--import-cfg=path/to/file`. + +Here is an example `.autoimport` file: + +``` +Data.Text as T +Data.Text.IO as TIO +Data.Map (Map) +Data.Map as Map +Data.Maybe (fromMaybe, isJust, isNothing) +Data.Functor.Identity (Identity(runIdentity)) +UnliftIO +``` + +There are two ways of specifying modules that should be automatically imported: +with a qualifier or with a list of identifiers. + +Modules are identified by a qualifier if there is no list of identifiers +following the module name, along with an optional explicit qualifier using +`as`. If no explicit qualifier is given then the full module name is used as +the qualifier (such as `UnliftIO` in the example). Qualified imports will be +added for these modules whenever the qualifier is used in a module where it +does not correspond to an existing import. + +If a list of identifiers is given then that module will be imported unqualified +with an explicit import list (or added to an existing import if the module is +already imported) when one of the given identifiers is used in a context where +it does not have a definition in scope. Note: wildcards for type and class +subterms is not supported, i.e. `Identity(..)` is not allowed in the config. + +With the plugin enabled and the example config in scope, compiling the +following module: + +```haskell +tryReadFile :: FilePath -> IO (Either UnliftIO.IOException T.Text) +tryReadFile = UnliftIO.catchIO . TIO.readFile + +defaultToZero :: Maybe Int -> Int +defaultToZero = fromMaybe 0 +``` + +Results in the module file being automatically updated to: + +```haskell +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified UnliftIO +import Data.Maybe (fromMaybe) + +tryReadFile :: FilePath -> IO (Either UnliftIO.IOException T.Text) +tryReadFile = UnliftIO.tryIO . TIO.readFile + +defaultToZero :: Maybe Int -> Int +defaultToZero = fromMaybe 0 +``` + +(Note: the above would actually need to be compiled twice because GHC does not +emit the 'missing qualifier' and 'out of scope variable' errors together. The +missing qualifier errors occur first.) + +The plugin works by intercepting GHC errors indicating that a qualifier or +identifier is not defined, and if it matches a line from the config, then the +corresponding import statement is inserted. Compilation is aborted when this +occurs. + +Here is an example command for starting a REPL for a stack project with the +`auto-import` plugin enabled (you may need to add `auto-import` to your +`extra-deps` first): + +``` +stack repl my-project --package auto-import --ghci-options='-fplugin AutoSplit' +``` + +likewise for a cabal project (you may need to run `cabal update` first): + +``` +cabal repl my-project --build-depends auto-import --repl-options='-fplugin AutoSplit' +``` + +This plugin aims to support the four most recent major GHC releases. diff --git a/auto-import.cabal b/auto-import.cabal new file mode 100644 --- /dev/null +++ b/auto-import.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.0 +name: auto-import +version: 0.1.0.0 +synopsis: Automatically add import statements +description: Automatically add import statements based on configuration +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-import + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: AutoImport + AutoImport.GhcFacade + AutoImport.Config + -- other-modules: + default-extensions: LambdaCase, OverloadedStrings + build-depends: base < 5, + ghc >= 9.6 && < 9.13, + ghc-boot, + ghc-exactprint, + ghc-paths, + bytestring < 0.13, + megaparsec >= 9 && < 10, + text, + containers, + directory, + time + hs-source-dirs: src + default-language: GHC2021 + +test-suite auto-import-test + import: warnings + default-language: GHC2021 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + auto-import, + directory, + process, + tasty, + tasty-hunit diff --git a/src/AutoImport.hs b/src/AutoImport.hs new file mode 100644 --- /dev/null +++ b/src/AutoImport.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +module AutoImport + ( plugin + ) where + +import Control.Exception (try, throw) +import Data.Containers.ListUtils (nubOrd) +import Data.Either (partitionEithers) +import Data.Foldable +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified GHC.LanguageExtensions as LangExt +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 AutoImport.Config +import qualified AutoImport.GhcFacade as Ghc + +-------------------------------------------------------------------------------- +-- Plugin +-------------------------------------------------------------------------------- + +plugin :: Ghc.Plugin +plugin = Ghc.defaultPlugin + { Ghc.driverPlugin = \args hscEnv -> pure $ addHscHook args hscEnv + , Ghc.pluginRecompile = Ghc.purePlugin + } + +addHscHook :: [Ghc.CommandLineOption] -> Ghc.HscEnv -> Ghc.HscEnv +addHscHook args hscEnv = hscEnv + { Ghc.hsc_hooks = + let hooks = Ghc.hsc_hooks hscEnv + in hooks + { Ghc.runPhaseHook = Just $ phaseHook (Ghc.runPhaseHook hooks) } + } + where + phaseHook mExistingHook = Ghc.PhaseHook $ \phase -> case phase of + Ghc.T_Hsc env modSum -> do + let modFile = Ghc.ms_hspp_file modSum + importsAddedErr = + Ghc.mkPlainErrorMsgEnvelope + (Ghc.mkGeneralSrcSpan $ Ghc.mkFastString modFile) + (Ghc.ghcUnknownMessage ImportsAddedDiag) + eTcRes <- try $ runPhaseOrExistingHook phase + autoImportCfg <- resolveConfig (asum $ parseConfigPathArg <$> args) + let msgs = case eTcRes of + Left (Ghc.SourceError m) -> m + Right (_, m) -> m + missingThings = + foldMap (missingThingFromMsg autoImportCfg) (Ghc.getMessages msgs) + case NE.nonEmpty (nubOrd $ toList missingThings) of + Just neMissing -> do + -- Parse from file because the parse result from GHC lacks comments + let dynFlags = Ghc.ms_hspp_opts modSum `Ghc.gopt_set` Ghc.Opt_KeepRawTokenStream + (eParseResult, usesCpp) <- parseModule env dynFlags modFile + case eParseResult of + Left errs -> throw $ Ghc.mkSrcErr errs + Right parseResult -> do + modifyModule parseResult usesCpp neMissing modFile + throw . Ghc.mkSrcErr . Ghc.mkMessages $ Ghc.unitBag importsAddedErr + _ -> either throw pure eTcRes + _ -> runPhaseOrExistingHook phase + where + runPhaseOrExistingHook :: Ghc.TPhase res -> IO res + runPhaseOrExistingHook = maybe Ghc.runPhase (\(Ghc.PhaseHook h) -> h) mExistingHook + +parseConfigPathArg :: Ghc.CommandLineOption -> Maybe FilePath +parseConfigPathArg ('-':'-':'i':'m':'p':'o':'r':'t':'-':'c':'f':'g':'=':path) = Just path +parseConfigPathArg _ = Nothing + +moduleNameToText :: Ghc.ModuleName -> T.Text +moduleNameToText = TE.decodeUtf8 . Ghc.bytesFS . Ghc.moduleNameFS + +data MissingThing + = MissingModule QualMod + | MissingId UnqualIdentifier + deriving (Eq, Ord) + +missingThingFromMsg :: Config -> Ghc.MsgEnvelope Ghc.GhcMessage -> [MissingThing] +missingThingFromMsg autoImportCfg msgEnv = + case Ghc.errMsgDiagnostic msgEnv of + Ghc.GhcTcRnMessage + (Ghc.TcRnMessageWithInfo _ + (Ghc.TcRnMessageDetailed _ + (Ghc.TcRnNotInScope Ghc.NotInScope _ [Ghc.MissingModule missingMod] _)) + ) + | let modTxt = moduleNameToText missingMod + , Just qualMods <- M.lookup modTxt (unMonoidMap $ qualModules autoImportCfg) + -> MissingModule <$> qualMods + Ghc.GhcTcRnMessage + (Ghc.TcRnMessageWithInfo _ + (Ghc.TcRnMessageDetailed _ + (Ghc.TcRnNotInScope Ghc.NotInScope rdrName [] hints)) + ) + | Just unqualId <- M.lookup (T.pack $ EP.rdrName2String rdrName) (unqualIdentifiers autoImportCfg) + , let isDataKindExtHint = \case + Ghc.SuggestExtension (Ghc.SuggestSingleExtension _ LangExt.DataKinds) -> True + _ -> False + -- If -XDataKinds is suggested, that means the import already exists + -- and should not be added again. + , not (any isDataKindExtHint hints) + -> [MissingId unqualId] + Ghc.GhcTcRnMessage + (Ghc.TcRnMessageWithInfo _ + (Ghc.TcRnMessageDetailed _ + (Ghc.TcRnSolverReport' report ) + )) + | Ghc.ReportHoleError hole _ + <- Ghc.reportContent report + , Just unqualId <- M.lookup (T.pack . EP.rdrName2String $ Ghc.hole_occ hole) (unqualIdentifiers autoImportCfg) + -> [MissingId unqualId] + _ -> [] + +-- | Diagnostic thrown when import statements are inserted +data ImportsAddedDiag = ImportsAddedDiag + +instance Ghc.Diagnostic ImportsAddedDiag where + type DiagnosticOpts ImportsAddedDiag = Ghc.NoDiagnosticOpts + diagnosticMessage _ _ = Ghc.mkSimpleDecorated $ + Ghc.text "Module updated by auto-import, compilation aborted" + diagnosticReason _ = Ghc.ErrorWithoutFlag + diagnosticHints _ = [] + diagnosticCode _ = Nothing +#if !MIN_VERSION_ghc(9,8,0) + defaultDiagnosticOpts = Ghc.NoDiagnosticOpts +#endif + +-------------------------------------------------------------------------------- +-- Modify source +-------------------------------------------------------------------------------- + +-- | Parse the given module file. Accounts for CPP comments +parseModule + :: Ghc.HscEnv + -> Ghc.DynFlags + -> String + -> 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 + ) + +modifyModule + :: Ghc.ParsedSource + -> Bool + -> NE.NonEmpty MissingThing + -> FilePath + -> IO () +modifyModule parsedMod usesCpp neMissing filePath = do + let updatedAst = modifyAST neMissing parsedMod + -- 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. + removeTrailingNewlines + | usesCpp = + reverse . ('\n' :) . dropWhile (== '\n') . reverse + | otherwise = id + printed = removeTrailingNewlines $ EP.exactPrint updatedAst + writeFile filePath printed + +modifyAST :: NE.NonEmpty MissingThing -> Ghc.ParsedSource -> Ghc.ParsedSource +modifyAST missingThings parsedSource = + let + Ghc.L modLoc hsMod = EP.makeDeltaAst parsedSource + (qualMods, unqualIds) = partitionEithers $ + NE.toList missingThings >>= \case + MissingModule m -> [Left m] + MissingId i -> [Right (importByMod i, [i])] + newQualImports = mkQualImport <$> + zip (null updatedImports : repeat False) + qualMods + (newUnqualIds, updatedImports) = + addIdsToExistingImports + (M.fromListWith (<>) unqualIds) + (Ghc.hsmodImports hsMod) + newUnqualImports = mkUnqualImport <$> + zip ((null updatedImports && null newQualImports) : repeat False) + (M.toList newUnqualIds) + importSrcSpan isFirst = + let lineDelta = if isFirst then 2 else 1 + in Ghc.noAnnSrcSpanDP' $ Ghc.DifferentLine lineDelta 0 + mkQualImport (isFirst, qualMod) = + let mn = Ghc.mkModuleName $ T.unpack (modName qualMod) + in Ghc.L (importSrcSpan isFirst) + (Ghc.simpleImportDecl mn) + { Ghc.ideclQualified = Ghc.QualifiedPre + , Ghc.ideclAs = Ghc.L (Ghc.noAnnSrcSpanDP' $ Ghc.SameLine 1) + . Ghc.mkModuleName . T.unpack <$> modQual qualMod + , Ghc.ideclName = Ghc.L (Ghc.noAnnSrcSpanDP' $ Ghc.SameLine 1) mn + , Ghc.ideclExt = Ghc.XImportDeclPass importEpAnnQual Ghc.NoSourceText False + } + mkUnqualImport :: (Bool, (T.Text, [UnqualIdentifier])) -> Ghc.LImportDecl Ghc.GhcPs + mkUnqualImport (isFirst, (moName, ids)) = + let mn = Ghc.mkModuleName $ T.unpack moName + impList = addCommas $ uncurry mkIE <$> + zip + (True : repeat False) + (associateUnqualIds ids) + in Ghc.L (importSrcSpan isFirst) + (Ghc.simpleImportDecl mn) + { Ghc.ideclName = Ghc.L (Ghc.noAnnSrcSpanDP' $ Ghc.SameLine 1) mn + , Ghc.ideclExt = Ghc.XImportDeclPass Ghc.importEpAnn Ghc.NoSourceText False + , Ghc.ideclImportList = Just (Ghc.Exactly, Ghc.L Ghc.importListAnn impList) + } + importEpAnnQual = (Ghc.noAnn :: Ghc.EpAnn Ghc.EpAnnImportDecl) +#if MIN_VERSION_ghc(9,12,0) + { Ghc.anns = Ghc.noAnn + { Ghc.importDeclAnnImport = Ghc.EpTok Ghc.noAnn + , Ghc.importDeclAnnQualified = Just (Ghc.EpTok EP.d1) + , Ghc.importDeclAnnAs = Just (Ghc.EpTok EP.d1) + } + } +#endif + in Ghc.L modLoc hsMod + { Ghc.hsmodImports = updatedImports ++ newQualImports ++ newUnqualImports + } + +addIdsToExistingImports + :: M.Map T.Text [UnqualIdentifier] + -> [Ghc.LImportDecl Ghc.GhcPs] + -> (M.Map T.Text [UnqualIdentifier], [Ghc.LImportDecl Ghc.GhcPs]) +addIdsToExistingImports = List.mapAccumR go + where + go iMap (Ghc.L iLoc idec) + | Ghc.NotQualified <- Ghc.ideclQualified idec + , let hsModName = moduleNameToText . Ghc.unLoc $ Ghc.ideclName idec + , Just ids <- M.lookup hsModName iMap + , Just (Ghc.Exactly, Ghc.L idsLoc existingIEs) <- Ghc.ideclImportList idec + = let (idsWithParent, idsWithoutParent) = partitionEithers $ do + i <- ids + case parentTy i of + Nothing -> [Right i] + Just parent -> [Left (idLabel parent, [i])] + idsWithParentMap = M.fromListWith (<>) idsWithParent + (idsWithParentToAdd, updatedExistingIEs) = + addIdsToExistingIEs idsWithParentMap existingIEs + idsWithoutParentDeduped = + filter (\x -> M.notMember (identifier x) idsWithParentMap) idsWithoutParent + newIEs = uncurry mkIE <$> + zip + (null updatedExistingIEs : repeat False) + (associateUnqualIds (idsWithoutParentDeduped ++ fold idsWithParentToAdd)) + updatedImportList = (Ghc.Exactly, Ghc.L idsLoc . addCommas $ updatedExistingIEs ++ newIEs) + newDecl = idec { Ghc.ideclImportList = Just updatedImportList } + in (M.delete hsModName iMap, Ghc.L iLoc newDecl) + go iMap idecl = (iMap, idecl) + +associateUnqualIds :: [UnqualIdentifier] -> [(IdInfo, [IdInfo])] +associateUnqualIds ids = M.toList . M.fromListWith (<>) $ do + i <- ids + case parentTy i of + Nothing -> [(toIdInfo i, [])] + Just pt -> [(pt, [toIdInfo i])] + +mkIE :: Bool -> (IdInfo, [IdInfo]) -> Ghc.LIE Ghc.GhcPs +mkIE isFirstItem (parentId, children) = Ghc.L (ieLoc isFirstItem) $ + case children of + [] -> Ghc.IEVar' (mkIEWrappedName True parentId) + _ -> Ghc.IEThingWith' Ghc.ieThingWithAnn + (mkIEWrappedName True parentId) + Ghc.NoIEWildcard + (addCommas $ uncurry mkIEWrappedName <$> zip (True : repeat False) children) + where + ieLoc isFirst = Ghc.noAnnSrcSpanDP' $ Ghc.SameLine (if isFirst then 0 else 1) + +mkIEWrappedName :: Bool -> IdInfo -> Ghc.LIEWrappedName Ghc.GhcPs +mkIEWrappedName isFirst i = + Ghc.L ieLoc . ieCon . txtToRdrName $ idLabel i + where + ieLoc = Ghc.noAnnSrcSpanDP' $ Ghc.SameLine (if isFirst then 0 else 1) + ieCon = case idNamespace i of + Just PatternNS -> Ghc.IEPattern Ghc.epTokD0 . Ghc.L (Ghc.nameAnn (idIsOp i) True) + Just TypeNS -> Ghc.IEType Ghc.epTokD0 . Ghc.L (Ghc.nameAnn (idIsOp i) True) + Nothing -> Ghc.IEName Ghc.noExtField . Ghc.L (Ghc.nameAnn (idIsOp i) False) + +addCommas :: [Ghc.GenLocated Ghc.SrcSpanAnnA e] -> [Ghc.GenLocated Ghc.SrcSpanAnnA e] +addCommas [] = [] +addCommas [x] = [x] +addCommas (Ghc.L ann x : xs) = + Ghc.L (if Ghc.hasTrailingComma ann then ann else EP.addComma ann) x + : addCommas xs + +addIdsToExistingIEs + :: M.Map T.Text [UnqualIdentifier] -- keyed by parent ty name + -> [Ghc.LIE Ghc.GhcPs] + -> (M.Map T.Text [UnqualIdentifier], [Ghc.LIE Ghc.GhcPs]) +addIdsToExistingIEs = List.mapAccumR go + where + go idMap (Ghc.L ieLoc (Ghc.IEThingAbs' name)) + | Ghc.IEName _ (Ghc.L _ rdrName) <- Ghc.unLoc name + , let nameTxt = T.pack $ EP.rdrName2String rdrName + , Just ids <- M.lookup nameTxt idMap + , let newChildren = + uncurry mkIEWrappedName . fmap toIdInfo <$> + zip (True : repeat False) ids + newLie = Ghc.L ieLoc + (Ghc.IEThingWith' Ghc.ieThingWithAnn name Ghc.NoIEWildcard (addCommas newChildren)) + = (M.delete nameTxt idMap, newLie) + go idMap (Ghc.L ieLoc (Ghc.IEThingWith' x name wc children)) + | Ghc.IEName _ (Ghc.L _ rdrName) <- Ghc.unLoc name + , let nameTxt = T.pack $ EP.rdrName2String rdrName + , Just ids <- M.lookup nameTxt idMap + , let newChildren = + uncurry mkIEWrappedName . fmap toIdInfo <$> + zip (null children : repeat False) ids + newLie = Ghc.L ieLoc (Ghc.IEThingWith' x name wc (addCommas $ children ++ newChildren)) + = (M.delete nameTxt idMap, newLie) + go idMap lie = (idMap, lie) + +txtToRdrName :: T.Text -> Ghc.RdrName +txtToRdrName = Ghc.mkRdrUnqual . Ghc.mkVarOcc . T.unpack + +toIdInfo :: UnqualIdentifier -> IdInfo +toIdInfo i = IdInfo + { idLabel = identifier i + , idIsOp = isOperator i + , idNamespace = namespace i + } diff --git a/src/AutoImport/Config.hs b/src/AutoImport/Config.hs new file mode 100644 --- /dev/null +++ b/src/AutoImport/Config.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeFamilies #-} +module AutoImport.Config + ( ConfigCache(..) + , Config(..) + , QualMods + , QualMod(..) + , UnqualIdentifiers + , UnqualIdentifier(..) + , IdInfo(..) + , Namespace(..) + , MonoidMap(..) + , resolveConfig + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (guard) +import Control.Exception (throw) +import Data.Bifunctor (first) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Char as Char +import Data.Functor (void) +import Data.IORef +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time (UTCTime) +import Data.Void +import GHC.Generics (Generic, Generically(..)) +import qualified System.Directory as Dir +import System.IO.Unsafe (unsafePerformIO) +import qualified Text.Megaparsec as Parse +import qualified Text.Megaparsec.Char as Parse +import qualified Text.Megaparsec.Char.Lexer as Parse (skipLineComment) + +import qualified AutoImport.GhcFacade as Ghc + +-- | A global ref used to cache the config and the mod time of the config file +configCacheRef :: IORef (Maybe ConfigCache) +configCacheRef = unsafePerformIO $ newIORef Nothing +{-# NOINLINE configCacheRef #-} + +data ConfigCache = ConfigCache + { cachedConfig :: !Config + , localModTime :: !(Maybe UTCTime) + , homeModTime :: !(Maybe UTCTime) + } + +data Config = Config + { qualModules :: QualMods + , unqualIdentifiers :: UnqualIdentifiers + } deriving (Generic, Show) + deriving (Semigroup, Monoid) via Generically Config + +newtype MonoidMap k a = MonoidMap {unMonoidMap :: M.Map k a} + deriving (Show) +instance (Ord k, Semigroup a) => Semigroup (MonoidMap k a) where + MonoidMap a <> MonoidMap b = MonoidMap $ M.unionWith (<>) a b +instance (Ord k, Monoid a) => Monoid (MonoidMap k a) where + mempty = MonoidMap mempty + +type QualMods = MonoidMap T.Text [QualMod] +data QualMod = QualMod + { modName :: T.Text + , modQual :: Maybe T.Text + } deriving (Show, Eq, Ord) + +type UnqualIdentifiers = M.Map T.Text UnqualIdentifier +data UnqualIdentifier = UnqualIdentifier + { importByMod :: T.Text + , identifier :: T.Text + , parentTy :: Maybe IdInfo + , isOperator :: Bool + , namespace :: Maybe Namespace + } deriving (Show, Eq, Ord) + +data Namespace + = PatternNS + | TypeNS + deriving (Show, Eq, Ord) + +data IdInfo = IdInfo + { idLabel :: T.Text + , idIsOp :: Bool + , idNamespace :: Maybe Namespace + } deriving (Show, Eq, Ord) + +localConfigFile, homeConfigFile :: FilePath +localConfigFile = "./.autoimport" +homeConfigFile = "~/.autoimport" + +resolveConfig :: Maybe FilePath -> IO Config +resolveConfig mLocalConfigFileOverride = do + mCached <- readIORef configCacheRef + let localFile = fromMaybe localConfigFile mLocalConfigFileOverride + case mCached of + Just configCache -> do + mLocalModTime <- + Dir.doesFileExist localFile >>= \case + True -> Just <$> Dir.getModificationTime localFile + False -> pure Nothing + mHomeModTime <- + Dir.doesFileExist homeConfigFile >>= \case + True -> Just <$> Dir.getModificationTime homeConfigFile + False -> pure Nothing + if mLocalModTime /= localModTime configCache + || mHomeModTime /= homeModTime configCache + then readAndCacheConfig localFile + else pure $ cachedConfig configCache + Nothing -> readAndCacheConfig localFile + +readAndCacheConfig :: FilePath -> IO Config +readAndCacheConfig localFile = do + mHomeCfg <- readConfigFile homeConfigFile + mLocalCfg <- readConfigFile localFile + case (fst <$> mLocalCfg) <> (fst <$> mHomeCfg) of + Nothing -> do + BS8.putStrLn "'.autoimport' file not found by auto-import plugin" + writeIORef configCacheRef Nothing + pure mempty + Just cfg -> do + let cache = ConfigCache + { cachedConfig = cfg + , localModTime = snd <$> mLocalCfg + , homeModTime = snd <$> mHomeCfg + } + writeIORef configCacheRef (Just cache) + pure cfg + +readConfigFile :: FilePath -> IO (Maybe (Config, UTCTime)) +readConfigFile file = do + exists <- Dir.doesFileExist file + if exists + then do + content <- T.readFile file + modTime <- Dir.getModificationTime file + case parseConfig file content of + Left err -> do + let diag = ConfigParseFailDiag err + msgEnv = + Ghc.mkPlainErrorMsgEnvelope + Ghc.noSrcSpan + (Ghc.ghcUnknownMessage diag) + throw $ Ghc.mkSrcErr (Ghc.mkMessages $ Ghc.unitBag msgEnv) + Right cfg -> pure $ Just (cfg, modTime) + else pure Nothing + +parseConfig :: String -> T.Text -> Either String Config +parseConfig fileName content = + first Parse.errorBundlePretty $ Parse.runParser parser fileName content + where + parser = do + _ <- Parse.optional skipSpaceNoIndent + mconcat + <$> (Parse.many p <* Parse.space <* Parse.eof) + p = ((parseConfigEntry <* Parse.optional parseLineComment) + <|> (mempty <$ parseLineComment)) + <* skipSpaceNoIndent + +parseConfigEntry :: Parse.Parsec Void T.Text Config +parseConfigEntry = do + moName <- parseModName + + let parseUnqualIdsEntry = + (\ids -> mempty + {unqualIdentifiers = M.fromList $ (\i -> (identifier i, i)) <$> ids} + ) <$> parseUnqualIds moName + parseQualModEntry = + (\qualMod -> mempty + {qualModules = MonoidMap $ + M.singleton (fromMaybe (modName qualMod) (modQual qualMod)) [qualMod] + }) <$> parseModQual moName + selfQualMod = pure mempty + {qualModules = MonoidMap $ + M.singleton moName [QualMod moName Nothing] + } + + ( do + Parse.try hspaceOrIndent + parseUnqualIdsEntry <|> parseQualModEntry + ) <|> selfQualMod + +parseModQual :: T.Text -> Parse.Parsec Void T.Text QualMod +parseModQual moName = do + qual <- do + Parse.string "as" *> Parse.hspace1 + parseModName + pure $ QualMod moName (Just qual) + +parseModName :: Parse.Parsec Void T.Text T.Text +parseModName = T.intercalate "." <$> Parse.sepBy1 parseSegment (Parse.char '.') + where + parseSegment = do + h <- Parse.upperChar + rest <- Parse.many (Parse.satisfy (\c -> Char.isAlphaNum c || c == '_')) + Parse. "module name chars" + pure . T.pack $ h : rest + +parseUnqualIds :: T.Text -> Parse.Parsec Void T.Text [UnqualIdentifier] +parseUnqualIds moName = concat <$> + Parse.between (Parse.char '(' <* hspaceOrIndent) (Parse.char ')') + (Parse.sepBy1 (parseIdentifier moName <* hspaceOrIndent) (Parse.char ',' <* hspaceOrIndent)) + +parseIdentifier :: T.Text -> Parse.Parsec Void T.Text [UnqualIdentifier] +parseIdentifier moName = do + mNamespace <- Parse.try . Parse.optional $ + (patternP <|> typeP) <* Parse.hspace1 + (parent, parentIsOp) <- identP <|> operatorP + let parentId = + UnqualIdentifier + { importByMod = moName + , identifier = parent + , parentTy = Nothing + , isOperator = parentIsOp + , namespace = mNamespace + } + if parentIsOp || T.all Char.isUpper (T.take 1 parent) + then do + hspaceOrIndent + mChildIds <- Parse.optional childIdsP + case mChildIds of + Nothing -> pure [ parentId ] + Just childIds -> pure . (parentId :) $ + (\(cid, isOp) -> UnqualIdentifier + { importByMod = moName + , identifier = cid + , parentTy = Just (IdInfo parent parentIsOp mNamespace) + , isOperator = isOp + , namespace = Nothing + }) <$> childIds + else pure [ parentId ] + + where + identP = do + fc <- Parse.char '_' <|> Parse.letterChar + rest <- Parse.many (Parse.satisfy (\c -> Char.isAlphaNum c || c `elem` ['_', '\'', '#'])) + Parse. "identifier chars" + pure (T.pack $ fc : rest, False) + operatorP = (, True) . T.pack <$> + Parse.between (Parse.char '(' <* Parse.hspace) (Parse.hspace *> Parse.char ')') + (Parse.some (Parse.oneOf (":!#$%&*+./<=>?@\\^|-~" :: String) Parse. "operator char")) + childIdsP = + Parse.between (Parse.char '(' <* hspaceOrIndent) (Parse.char ')') $ + Parse.sepBy1 (identP <|> operatorP <* hspaceOrIndent) + (Parse.char ',' <* hspaceOrIndent) + patternP = PatternNS <$ Parse.string "pattern" + typeP = TypeNS <$ Parse.string "type" + +parseLineComment :: Parse.Parsec Void T.Text () +parseLineComment = do + Parse.hspace + Parse.skipLineComment "--" + +-- Skip horizontal and vertical space until unindented text is found +skipSpaceNoIndent :: Parse.Parsec Void T.Text () +skipSpaceNoIndent = + void (Parse.some (Parse.hspace *> Parse.eol)) + <|> Parse.eof + +-- | Parse any amount of whitespace not ending in a newline +hspaceOrIndent :: Parse.Parsec Void T.Text () +hspaceOrIndent = do + Parse.hspace + (do void Parse.eol + s : _ <- reverse <$> Parse.some Parse.spaceChar + guard (s /= '\n') + ) <|> pure () + +-- | Diagnostic thrown when config parsing fails +newtype ConfigParseFailDiag = ConfigParseFailDiag String + +instance Ghc.Diagnostic ConfigParseFailDiag where + type DiagnosticOpts ConfigParseFailDiag = Ghc.NoDiagnosticOpts + diagnosticMessage _ (ConfigParseFailDiag err) = Ghc.mkSimpleDecorated $ + Ghc.text err + diagnosticReason _ = Ghc.ErrorWithoutFlag + diagnosticHints _ = [] + diagnosticCode _ = Nothing +#if !MIN_VERSION_ghc(9,8,0) + defaultDiagnosticOpts = Ghc.NoDiagnosticOpts +#endif diff --git a/src/AutoImport/GhcFacade.hs b/src/AutoImport/GhcFacade.hs new file mode 100644 --- /dev/null +++ b/src/AutoImport/GhcFacade.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PatternSynonyms #-} +module AutoImport.GhcFacade + ( module Ghc + , ann' + , noAnnSrcSpanDP' + , nameParensAdornment + , ieThingWithAnn + , importListAnn + , nameAnn + , importEpAnn + , hasTrailingComma + , epTokD0 + , pattern IEThingWith' + , pattern IEVar' + , pattern TcRnSolverReport' + , pattern IEThingAbs' + ) where + +import GHC as Ghc +import GHC.Data.Bag as Ghc +import GHC.Data.FastString as Ghc +import GHC.Driver.Env as Ghc +import GHC.Driver.Errors.Types as Ghc +import GHC.Driver.Hooks as Ghc +import GHC.Driver.Pipeline.Execute as Ghc +import GHC.Driver.Pipeline.Phases as Ghc +import GHC.Driver.Plugins as Ghc +import GHC.Driver.Monad as Ghc +import GHC.Tc.Errors.Types as Ghc +import GHC.Tc.Types.Constraint as Ghc +import GHC.Types.Error as Ghc +import GHC.Types.Name.Occurrence as Ghc +import GHC.Types.Name.Reader as Ghc +import GHC.Types.SourceError as Ghc +import GHC.Types.SourceText as Ghc +import GHC.Types.SrcLoc as Ghc +import GHC.Unit.Module.ModSummary as Ghc +import GHC.Utils.Error as Ghc +import GHC.Utils.Outputable as Ghc +import GHC.Utils.Misc as Ghc +#if MIN_VERSION_ghc(9,8,0) +import GHC.Driver.DynFlags as Ghc +#else +import GHC.Driver.Flags as Ghc +import GHC.Driver.Session as Ghc +#endif + +import qualified Language.Haskell.GHC.ExactPrint as EP + +#if MIN_VERSION_ghc(9,10,0) +ann' :: Ghc.EpAnn ann -> Ghc.EpAnn ann +ann' = id +#else +ann' :: Ghc.SrcSpanAnnA -> Ghc.EpAnn Ghc.AnnListItem +ann' = Ghc.ann +#endif + +noAnnSrcSpanDP' +#if MIN_VERSION_ghc(9,10,0) + :: Ghc.NoAnn ann + => Ghc.DeltaPos -> Ghc.EpAnn ann +#else + :: Monoid ann + => Ghc.DeltaPos -> Ghc.SrcSpanAnn' (Ghc.EpAnn ann) +#endif +noAnnSrcSpanDP' +#if MIN_VERSION_ghc(9,10,0) + = EP.noAnnSrcSpanDP +#else + = EP.noAnnSrcSpanDP Ghc.noSrcSpan +#endif + +nameParensAdornment :: Ghc.NameAdornment +nameParensAdornment = +#if MIN_VERSION_ghc(9,12,0) + Ghc.NameParens (Ghc.EpTok EP.d0) (Ghc.EpTok EP.d0) +#else + Ghc.NameParens +#endif + +ieThingWithAnn :: Ghc.XIEThingWith Ghc.GhcPs +ieThingWithAnn = +#if MIN_VERSION_ghc(9,12,0) + (Nothing, (Ghc.EpTok EP.d0, Ghc.noAnn, Ghc.noAnn, Ghc.EpTok EP.d0)) +#elif MIN_VERSION_ghc(9,10,0) + (Nothing, [Ghc.AddEpAnn Ghc.AnnOpenP 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.AnnCloseP EP.d0] + Ghc.emptyComments + ) +#else + Ghc.EpAnn (Ghc.Anchor Ghc.placeholderRealSpan EP.m0) + [Ghc.AddEpAnn Ghc.AnnOpenP EP.d0, Ghc.AddEpAnn Ghc.AnnCloseP EP.d0] + Ghc.emptyComments +#endif + +#if MIN_VERSION_ghc(9,12,0) +importListAnn :: Ghc.EpAnn (Ghc.AnnList (Ghc.EpToken "hiding", [Ghc.EpToken ","])) +#elif MIN_VERSION_ghc(9,10,0) +importListAnn :: Ghc.EpAnn Ghc.AnnList +#else +importListAnn :: Ghc.SrcSpanAnn' (Ghc.EpAnn Ghc.AnnList) +#endif +importListAnn = +#if MIN_VERSION_ghc(9,12,0) + (noAnnSrcSpanDP' @(Ghc.AnnList (Ghc.EpToken "hiding", [Ghc.EpToken ","])) $ Ghc.SameLine 0) + { Ghc.anns = (Ghc.noAnn :: Ghc.AnnList (Ghc.EpToken "hiding", [Ghc.EpToken ","])) + { Ghc.al_brackets = Ghc.ListParens (Ghc.EpTok EP.d1) (Ghc.EpTok EP.d0) + , Ghc.al_rest = (Ghc.noAnn, []) + } + } +#elif MIN_VERSION_ghc(9,10,0) + (noAnnSrcSpanDP' @Ghc.AnnList $ Ghc.SameLine 0) + { Ghc.anns = (Ghc.noAnn :: Ghc.AnnList) + { Ghc.al_open = Just $ Ghc.AddEpAnn Ghc.AnnOpenP EP.d1 + , Ghc.al_close = Just $ Ghc.AddEpAnn Ghc.AnnCloseP EP.d0 + } + } +#else + (noAnnSrcSpanDP' @Ghc.AnnList $ Ghc.SameLine 0) + { Ghc.ann = Ghc.EpAnn + { Ghc.anns = mempty + { Ghc.al_open = Just $ Ghc.AddEpAnn Ghc.AnnOpenP EP.d0 + , Ghc.al_close = Just $ Ghc.AddEpAnn Ghc.AnnCloseP EP.d0 + } + , Ghc.entry = Ghc.Anchor Ghc.placeholderRealSpan EP.m1 + , Ghc.comments = Ghc.emptyComments + } + } +#endif + +nameAnn + :: Bool + -> Bool +#if MIN_VERSION_ghc(9,10,0) + -> Ghc.EpAnn Ghc.NameAnn +#else + -> Ghc.SrcSpanAnn' (Ghc.EpAnn Ghc.NameAnn) +#endif +nameAnn needsParens addLeftSpace = +#if MIN_VERSION_ghc(9,12,0) + (Ghc.noAnn :: Ghc.EpAnn Ghc.NameAnn) + { Ghc.anns = Ghc.NameAnn + { Ghc.nann_adornment = if needsParens then nameParensAdornment else Ghc.NameNoAdornment + , Ghc.nann_name = EP.d0 + , Ghc.nann_trailing = [] + } + , Ghc.entry = if addLeftSpace then EP.d1 else EP.d0 + } +#elif MIN_VERSION_ghc(9,10,0) + (Ghc.noAnn :: Ghc.EpAnn Ghc.NameAnn) + { Ghc.anns = if needsParens + then Ghc.NameAnn + { Ghc.nann_adornment = nameParensAdornment + , Ghc.nann_name = EP.d0 + , Ghc.nann_trailing = [] + , Ghc.nann_open = Ghc.noAnn + , Ghc.nann_close = Ghc.noAnn + } + else Ghc.noAnn + , Ghc.entry = if addLeftSpace then EP.d1 else EP.d0 + } +#else + Ghc.SrcSpanAnn + { Ghc.ann = Ghc.EpAnn + { Ghc.anns = if needsParens + then Ghc.NameAnn + { Ghc.nann_adornment = nameParensAdornment + , Ghc.nann_name = EP.d0 + , Ghc.nann_trailing = [] + , Ghc.nann_open = EP.d0 + , Ghc.nann_close = EP.d0 + } + else mempty + , Ghc.entry = Ghc.Anchor Ghc.placeholderRealSpan $ + if addLeftSpace then EP.m1 else EP.m0 + , Ghc.comments = Ghc.emptyComments + } + , Ghc.locA = Ghc.noSrcSpan + } +#endif + +importEpAnn :: Ghc.EpAnn Ghc.EpAnnImportDecl +#if MIN_VERSION_ghc(9,12,0) +importEpAnn = (Ghc.noAnn :: Ghc.EpAnn Ghc.EpAnnImportDecl) + { Ghc.anns = Ghc.noAnn + { Ghc.importDeclAnnImport = Ghc.EpTok Ghc.noAnn } + } +#elif MIN_VERSION_ghc(9,10,0) +importEpAnn = Ghc.noAnn +#else +importEpAnn = + Ghc.EpAnn + { Ghc.entry = Ghc.Anchor Ghc.placeholderRealSpan EP.m0 + , Ghc.anns = Ghc.EpAnnImportDecl + { Ghc.importDeclAnnImport = EP.d0 + , Ghc.importDeclAnnPragma = Nothing + , Ghc.importDeclAnnSafe = Nothing + , Ghc.importDeclAnnQualified = Nothing + , Ghc.importDeclAnnPackage = Nothing + , Ghc.importDeclAnnAs = Nothing + } + , Ghc.comments = Ghc.emptyComments + } +#endif + +#if MIN_VERSION_ghc(9,12,0) +epTokD0 :: Ghc.EpToken tok +epTokD0 = Ghc.EpTok EP.d0 +#else +epTokD0 :: Ghc.EpaLocation +epTokD0 = EP.d0 +#endif + +hasTrailingComma :: SrcSpanAnnA -> Bool +#if MIN_VERSION_ghc(9,10,0) +hasTrailingComma = any (\case Ghc.AddCommaAnn{} -> True; _ -> False) + . Ghc.lann_trailing . Ghc.anns +#else +hasTrailingComma x = + case Ghc.ann x of + Ghc.EpAnnNotUsed -> False + ann -> any (\case Ghc.AddCommaAnn{} -> True; _ -> False) + . Ghc.lann_trailing $ Ghc.anns ann +#endif + +pattern IEThingWith' :: XIEThingWith Ghc.GhcPs -> LIEWrappedName Ghc.GhcPs -> IEWildcard -> [LIEWrappedName Ghc.GhcPs] -> Ghc.IE Ghc.GhcPs +#if MIN_VERSION_ghc(9,10,0) +pattern IEThingWith' x name wc children = Ghc.IEThingWith x name wc children Nothing +#else +pattern IEThingWith' x name wc children = Ghc.IEThingWith x name wc children +#endif + +pattern IEThingAbs' :: LIEWrappedName Ghc.GhcPs -> Ghc.IE Ghc.GhcPs +#if MIN_VERSION_ghc(9,10,0) +pattern IEThingAbs' name <- Ghc.IEThingAbs _ name _ +#else +pattern IEThingAbs' name <- Ghc.IEThingAbs _ name +#endif + +pattern IEVar' :: LIEWrappedName Ghc.GhcPs -> Ghc.IE Ghc.GhcPs +#if MIN_VERSION_ghc(9,10,0) +pattern IEVar' name = Ghc.IEVar Nothing name Nothing +#elif MIN_VERSION_ghc(9,8,0) +pattern IEVar' name = Ghc.IEVar Nothing name +#else +pattern IEVar' name = Ghc.IEVar Ghc.NoExtField name +#endif + +pattern TcRnSolverReport' :: Ghc.SolverReportWithCtxt -> Ghc.TcRnMessage +#if MIN_VERSION_ghc(9,10,0) +pattern TcRnSolverReport' report <- Ghc.TcRnSolverReport report _ +#else +pattern TcRnSolverReport' report <- Ghc.TcRnSolverReport report _ _ +#endif diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,62 @@ +{-# 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 "qualified" + [ 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 "25" $ runTest "Case25.hs" + ] + , testGroup "unqualified" + [ testCase "9" $ runTest "Case9.hs" + , testCase "10" $ runTest "Case10.hs" + , testCase "11" $ runTest "Case11.hs" + , testCase "12" $ runTest "Case12.hs" + , testCase "13" $ runTest "Case13.hs" + , testCase "14" $ runTest "Case14.hs" + , testCase "15" $ runTest "Case15.hs" + , testCase "16" $ runTest "Case16.hs" + , testCase "17" $ runTest "Case17.hs" + , testCase "18" $ runTest "Case18.hs" + , testCase "19" $ runTest "Case19.hs" + , testCase "20" $ runTest "Case20.hs" + , testCase "21" $ runTest "Case21.hs" + , testCase "22" $ runTest "Case22.hs" + , testCase "23" $ runTest "Case23.hs" + , testCase "24" $ runTest "Case24.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