diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +### 2.5.0 + +- update to ghc-lib-parser 9.6, should support at least ghc 9.4 and 9.6 + +- add --package-cache flag, to read from a specific package cache. Should be +faster than ghc-pkg. + ### 2.4.0 - Support cabal v2, look for .ghc.environment.* and get pkgs from there. diff --git a/fix-imports.cabal b/fix-imports.cabal --- a/fix-imports.cabal +++ b/fix-imports.cabal @@ -1,5 +1,5 @@ name: fix-imports -version: 2.4.0 +version: 2.5.0 cabal-version: >= 1.10 build-type: Simple synopsis: Program to manage the imports of a haskell module @@ -26,7 +26,7 @@ author: Evan Laforge maintainer: Evan Laforge stability: stable -tested-with: GHC == 8.4.2 +tested-with: GHC == 9.2 extra-source-files: README.md changelog.md @@ -59,8 +59,9 @@ , deepseq , directory , filepath - , ghc-lib-parser == 9.2.5.20221107 - , ghc-lib-parser-ex == 9.2.1.1 + -- actually the latest is 9.12, but I guess ghc9.2 can't compile it? + , ghc-lib-parser >= 9.6 && < 9.8 + , ghc-lib-parser-ex >= 9.6 && < 9.8 , ghc-paths , mtl , pretty @@ -90,8 +91,8 @@ , deepseq , directory , filepath - , ghc-lib-parser == 9.2.5.20221107 - , ghc-lib-parser-ex == 9.2.1.1 + , ghc-lib-parser >= 9.6 && < 9.8 + , ghc-lib-parser-ex >= 9.6 && < 9.8 , ghc-paths , mtl , pretty diff --git a/src/FixImports/FixImports.hs b/src/FixImports/FixImports.hs --- a/src/FixImports/FixImports.hs +++ b/src/FixImports/FixImports.hs @@ -95,9 +95,9 @@ addMetrics :: [Metric] -> Result -> Result addMetrics ms result = result { resultMetrics = ms ++ resultMetrics result } -fixModule :: Config.Config -> FilePath -> String +fixModule :: Config.Config -> Maybe FilePath -> FilePath -> String -> IO (Either String Result, [Text]) -fixModule config modulePath source = do +fixModule config mbPkgCache modulePath source = do mStart <- metric () "start" processedSource <- cppModule modulePath source mCpp <- metric () "cpp" @@ -106,7 +106,7 @@ Left err -> return (Left err, []) Right (mod, cmts) -> do mParse <- metric (mod `seq` (), cmts) "parse" - (index, indexFrom) <- Index.load + (index, indexFrom) <- Index.load mbPkgCache when (Config._debug config) $ Text.IO.putStr $ "index from " <> indexFrom <> ":\n" <> Index.showIndex index mLoad <- metric () "load-index" diff --git a/src/FixImports/Index.hs b/src/FixImports/Index.hs --- a/src/FixImports/Index.hs +++ b/src/FixImports/Index.hs @@ -42,11 +42,17 @@ empty :: Index empty = Map.empty -load :: IO (Index, Text) -load = fromGhcEnvironment >>= \case +load :: Maybe FilePath -> IO (Index, Text) +load (Just pkgCache) = do + unitNameModules <- PkgCache.loadCache pkgCache + return + ( makeIndex $ map (fmap (map Types.ModuleName)) $ + map snd unitNameModules + , "--package-cache flag" + ) +load Nothing = fromGhcEnvironment >>= \case Just index -> return (index, ".ghc.environment") Nothing -> (, "global ghc-pkg") <$> fromGhcPkg - -- TODO ghc pkg could also use PkgCache to load the global db showIndex :: Index -> Text showIndex index = Text.unlines diff --git a/src/FixImports/Main.hs b/src/FixImports/Main.hs --- a/src/FixImports/Main.hs +++ b/src/FixImports/Main.hs @@ -5,9 +5,9 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module FixImports.Main where +module FixImports.Main (main) where import qualified Control.Exception as Exception -import Control.Monad (when) +import Control.Monad (unless, when) import qualified Data.List as List import Data.Maybe (fromMaybe) import qualified Data.Set as Set @@ -63,13 +63,13 @@ mainConfig :: Config.Config -> [Flag] -> FilePath -> IO () mainConfig config flags modulePath = do - let (verbose, debug, includes) = extractFlags flags + let (verbose, debug, includes, mbPkgCache) = extractFlags flags source <- IO.getContents config <- return $ config { Config._includes = includes ++ Config._includes config , Config._debug = debug } - (result, logs) <- FixImports.fixModule config modulePath source + (result, logs) <- FixImports.fixModule config mbPkgCache modulePath source `Exception.catch` \(exc :: Exception.SomeException) -> return (Left $ "exception: " ++ show exc, []) case result of @@ -97,7 +97,10 @@ ] Exit.exitSuccess -data Flag = Config FilePath | Debug | Edit | Include String | Verbose +data Flag = + Config FilePath | Debug | Edit | Help | Include String + | PackageCache String + | Verbose deriving (Eq, Show) options :: [FilePath] -> [GetOpt.OptDescr Flag] @@ -105,12 +108,15 @@ [ GetOpt.Option ['c'] ["config"] (GetOpt.ReqArg Config "path") $ "path to config file, otherwise will look in " <> List.intercalate ", " configLocations - , GetOpt.Option [] ["edit"] (GetOpt.NoArg Edit) - "print delete range and new import block, rather than the whole file" , GetOpt.Option [] ["debug"] (GetOpt.NoArg Debug) "print debugging info on stderr" + , GetOpt.Option [] ["edit"] (GetOpt.NoArg Edit) + "print delete range and new import block, rather than the whole file" + , GetOpt.Option [] ["help"] (GetOpt.NoArg Help) "show usage" , GetOpt.Option ['i'] [] (GetOpt.ReqArg Include "path") "add to module include path" + , GetOpt.Option [] ["package-cache"] (GetOpt.ReqArg PackageCache "path") $ + "path to package.cache file, use instead of .ghc.environment or ghc-pkg" , GetOpt.Option ['v'] [] (GetOpt.NoArg Verbose) "print added and removed modules on stderr" ] @@ -119,15 +125,18 @@ parseArgs args = do configLocations <- getConfigLocations case GetOpt.getOpt GetOpt.Permute (options configLocations) args of + (flags, _, _) | Help `elem` flags -> usage "" (flags, [modulePath], []) -> return (modulePath, flags) - (_, [], errs) -> usage $ concat errs - _ -> usage "too many args" + (_, _, errs@(_:_)) -> Exit.die $ List.intercalate "\n" errs + (_, args@(_:_), []) -> Exit.die $ "too many args: " <> show args + (_, [], []) -> Exit.die "got zero args" -extractFlags :: [Flag] -> (Bool, Bool, [FilePath]) +extractFlags :: [Flag] -> (Bool, Bool, [FilePath], Maybe FilePath) extractFlags flags = ( Verbose `elem` flags , Debug `elem` flags , "." : [p | Include p <- flags] + , Util.head [p | PackageCache p <- flags] ) -- Includes always have the current directory first. @@ -135,9 +144,10 @@ usage msg = do name <- Environment.getProgName configLocations <- getConfigLocations - IO.hPutStr IO.stderr $ - GetOpt.usageInfo (msg ++ "\n" ++ name ++ " Module.hs FilePath -> Src - -> IO (Either String (Hs.HsModule, [Comment])) + -> IO (Either String (Module, [Comment])) parse extensions filename src = makeDynFlags extensions filename src >>= \case Left err -> return $ Left $ "parsing pragmas: " <> err - Right dynFlags -> return $ - extractParseResult dynFlags $ Parser.parseFile filename dynFlags src + Right dynFlags -> return $ parseFile filename dynFlags src data Comment = Comment { _span :: !Types.SrcSpan, _comment :: !String } deriving (Eq, Ord, Show) @@ -83,46 +89,58 @@ where defaultExtensions = Session.languageExtensions Nothing defaultDynFlags :: Session.DynFlags -defaultDynFlags = - Session.defaultDynFlags Config.fakeSettings Config.fakeLlvmConfig +defaultDynFlags = Session.defaultDynFlags Config.fakeSettings -extractParseResult :: Session.DynFlags - -> Lexer.ParseResult (SrcLoc.GenLocated l Module) +-- | Parser.parseFile seems to return an unlifted type, even though I can't +-- tell from the :t or the source. But it means you can't pass its result +-- to a toplevel function. Weird. +parseFile :: FilePath -> Session.DynFlags -> String -> Either String (Module, [Comment]) -extractParseResult _dynFlags = \case +parseFile filename dynFlags src = case Parser.parseFile filename dynFlags src of Lexer.POk state val -> Right ( SrcLoc.unLoc val + -- , [] , List.sort $ map extractComment (Lexer.comment_q state) - ++ maybe [] (map extractComment) (Lexer.header_comments state) + ++ case Lexer.header_comments state of + Strict.Nothing -> [] + Strict.Just cs -> map extractComment cs ++ importComments (SrcLoc.unLoc val) -- Lexer.annotations_comments I think is supposed to have comments -- associated with their "attached" SrcSpan, whatever that is. -- In any case, it's empty for comments in the import block at least. ) Lexer.PFailed state -> Left $ unlines $ concat - [ map (("warn: "<>) . show . Errors.Ppr.pprWarning) $ - Bag.bagToList warns - , map (("error: "<>) . show . Errors.Ppr.pprError) $ - Bag.bagToList errors + [ map ("warn: "<>) (extract warns) + -- Looks like errors already start with "error: ". Dunno about warns. + , extract errors ] - where (warns, errors) = Lexer.getMessages state + where + (warns, errors) = Lexer.getPsMessages state + extract = + map (Ppr.showSDoc dynFlags . Utils.Error.pprLocMsgEnvelopeDefault) + . Bag.bagToList . Error.getMessages +-- | Simplify a comment, this means I lose all the docstring details, but +-- I think it's ok. extractComment :: Hs.LEpaComment -> Comment extractComment cmt = Comment (extractRealSrcSpan (Annotation.anchor (SrcLoc.getLoc cmt))) $ case Annotation.ac_tok (SrcLoc.unLoc cmt) of - Annotation.EpaDocCommentNext s -> s - Annotation.EpaDocCommentPrev s -> s - Annotation.EpaDocCommentNamed s -> s - Annotation.EpaDocSection _depth s -> s - Annotation.EpaDocOptions s -> s + Annotation.EpaDocComment doc -> case doc of + DocString.MultiLineDocString _decorator cs -> + mconcat $ map (DocString.unpackHDSC . SrcLoc.unLoc) $ + NonEmpty.toList cs + DocString.NestedDocString _decorator c -> + DocString.unpackHDSC (SrcLoc.unLoc c) + DocString.GeneratedDocString c -> DocString.unpackHDSC c Annotation.EpaLineComment s -> s Annotation.EpaBlockComment s -> s + Annotation.EpaDocOptions s -> s Annotation.EpaEofComment -> "" -- * extract -importComments :: Hs.HsModule -> [Comment] +importComments :: Module -> [Comment] importComments = map extractComment . concatMap (extract . extractAnn . Annotation.ann . SrcLoc.getLoc) @@ -203,17 +221,23 @@ extractImport locDecl = Types.Import { _importName = Types.ModuleName $ Name.moduleNameString $ SrcLoc.unLoc $ Hs.ideclName decl - , _importPkgQualifier = FastString.unpackFS . SourceText.sl_fs <$> - Hs.ideclPkgQual decl + , _importPkgQualifier = case Hs.ideclPkgQual decl of + PkgQual.NoRawPkgQual -> Nothing + PkgQual.RawPkgQual stringLit -> + Just $ FastString.unpackFS $ SourceText.sl_fs stringLit , _importIsBoot = Hs.ideclSource decl == Unit.Types.IsBoot , _importSafe = Hs.ideclSafe decl -- I don't distinguish Hs.QualifiedPost , _importQualified = Hs.ideclQualified decl /= Hs.NotQualified , _importAs = Types.Qualification . Name.moduleNameString . SrcLoc.unLoc <$> Hs.ideclAs decl - , _importHiding = maybe False fst $ Hs.ideclHiding decl - , _importEntities = map (extractEntity . SrcLoc.unLoc) . SrcLoc.unLoc - . snd <$> Hs.ideclHiding decl + , _importHiding = case Hs.ideclImportList decl of + Just (Hs.EverythingBut, _) -> True + _ -> False + , _importEntities = case Hs.ideclImportList decl of + Just (_, things) -> + Just $ map (extractEntity . SrcLoc.unLoc) $ SrcLoc.unLoc things + _ -> Nothing , _importSpan = extractSrcSpan $ Annotation.locA $ SrcLoc.getLoc locDecl } @@ -257,9 +281,11 @@ where entity ((qual, var), list) = Types.Entity qual var list unvar var = case SrcLoc.unLoc var of - Hs.IEName n -> (Nothing, toName n) + Hs.IEName _ n -> (Nothing, toName n) Hs.IEPattern _ n -> (Just "pattern", toName n) Hs.IEType _ n -> (Just "type", toName n) + -- It's a DataConCantHappen, so I think supposed to not happen? + Hs.XIEWrappedName _ -> (Just "??", Types.Name "XIEWrappedName") varStr (Just qual, name) = qual <> " " <> Types.showName name varStr (Nothing, name) = Types.showName name toName = inferName . unRdrName . SrcLoc.unLoc diff --git a/src/FixImports/PkgCache.hs b/src/FixImports/PkgCache.hs --- a/src/FixImports/PkgCache.hs +++ b/src/FixImports/PkgCache.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module FixImports.PkgCache ( - load, UnitId, PkgName, ModuleName + UnitId, PkgName, ModuleName + , load, loadCache ) where import Data.Maybe (mapMaybe) import Data.Set (Set) diff --git a/vimrc b/vimrc --- a/vimrc +++ b/vimrc @@ -5,7 +5,7 @@ " Parse --edit output and splice in the imports. function s:ReplaceImports(lines) let [start, end] = split(a:lines[0], ',') - " Otherwise vim does string comparison. + " +0 or vim does string comparison. if end+0 > start+0 " This stupidity is necessary because vim apparently has no way to " delete lines. @@ -13,13 +13,22 @@ let old_col = col('.') let old_total = line('$') silent execute (start+1) . ',' . end . 'delete _' - " If the import fix added or removed lines I need to take that - " into account. This will be wrong if the cursor was in the - " import block. let new_total = line('$') - call cursor(old_line + (new_total - old_total), old_col) + " Try to retain the cursor position. + " If <0, then I'm inside the import block and I can just keep the line. + " Otherwise, I have to move down for added lines or up for removed. + let dest_line = old_line + (new_total - old_total) + if dest_line >= 0 + call cursor(dest_line, old_col) + call append(start, a:lines[1:]) + else + call append(start, a:lines[1:]) + call cursor(old_line, old_col) + endif + else + " This means no existing import block, just add it. + call append(start, a:lines[1:]) endif - call append(start, a:lines[1:]) endfunction