fix-imports 2.4.0 → 2.5.0
raw patch · 8 files changed
+121/−61 lines, 8 filesdep ~ghc-lib-parserdep ~ghc-lib-parser-ex
Dependency ranges changed: ghc-lib-parser, ghc-lib-parser-ex
Files
- changelog.md +7/−0
- fix-imports.cabal +7/−6
- src/FixImports/FixImports.hs +3/−3
- src/FixImports/Index.hs +9/−3
- src/FixImports/Main.hs +23/−13
- src/FixImports/Parse.hs +55/−29
- src/FixImports/PkgCache.hs +2/−1
- vimrc +15/−6
changelog.md view
@@ -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.
fix-imports.cabal view
@@ -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 <qdunkan@gmail.com> 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
src/FixImports/FixImports.hs view
@@ -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"
src/FixImports/Index.hs view
@@ -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
src/FixImports/Main.hs view
@@ -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 <Module.hs")- (options configLocations)+ unless (null msg) $+ IO.hPutStr IO.stderr msg+ IO.hPutStr IO.stderr $ GetOpt.usageInfo (name ++ " Module.hs <Module.hs")+ (options configLocations) IO.hPutStrLn IO.stderr $ "version: " ++ Version.showVersion Paths_fix_imports.version Exit.exitFailure
src/FixImports/Parse.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-} -- without it extractEntity unvar unhappy module FixImports.Parse ( -- * types Module@@ -27,6 +28,7 @@ import qualified Control.Monad as Monad import qualified Data.Char as Char import qualified Data.List as List+import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Maybe as Maybe import Data.Maybe (fromMaybe) import qualified Data.Set as Set@@ -36,18 +38,23 @@ import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as ExSession import qualified GHC.Data.FastString as FastString+import qualified GHC.Data.Strict as Strict import qualified GHC.Driver.Session as Session+import qualified GHC.Driver.Ppr as Ppr import qualified GHC.Hs as Hs+import qualified GHC.Hs.DocString as DocString import qualified GHC.Parser.Annotation as Annotation import qualified GHC.Parser.Lexer as Lexer+import qualified GHC.Types.Error as Error import qualified GHC.Types.Name.Occurrence as Occurrence import qualified GHC.Types.Name.Reader as Reader import qualified GHC.Types.SourceText as SourceText import qualified GHC.Types.SrcLoc as SrcLoc+import qualified GHC.Types.PkgQual as PkgQual import qualified GHC.Data.Bag as Bag-import qualified GHC.Unit.Module.Name as Name import qualified GHC.Unit.Types as Unit.Types-import qualified GHC.Parser.Errors.Ppr as Errors.Ppr+import qualified GHC.Utils.Error as Utils.Error+import qualified Language.Haskell.Syntax.Module.Name as Name import qualified Data.Generics.Uniplate.Data as Uniplate @@ -57,18 +64,17 @@ -- * parse -type Module = Hs.HsModule+type Module = Hs.HsModule Hs.GhcPs type Src = String -- | makeDynFlags forces parse into IO. The reason seems to be that GHC -- puts dyn flags in a global variable. parse :: [Types.Extension] -> 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
src/FixImports/PkgCache.hs view
@@ -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)
vimrc view
@@ -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