diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,21 +24,18 @@ The `-i` flag is like ghc's `-i` flag, it will add an aditional root to the module search path. The example will find modules in both `test/*` and -`src/*`, in addition to the global package db. +`src/*`, in addition to the package db. -About the global package db, `fix-imports` uses the `ghc-pkg` command to find -packages, so it will see whatever you see if you do `ghc-pkg list`. If it -doesn't see the right things for your package, say for the new nix-style -builds, you'll have to figure out how to fix that. As is usual for cabal and -ghc integration, ghc has several overlapping but documented configuration -methods, and cabal is completely undocumented. The relevant bits for ghc are -GHC_PACKAGE_PATH and perhaps package environments: -https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/packages.html#the-ghc-package-path-environment-variable -Cabal doesn't seem to document how to get the appropriate package path for a -nix-style build. I don't use cabal so I haven't figured this out yet, but -let me know if you know or figure it out. +`fix-imports` will look for `.ghc.environment.*` in the current directory +and use it for pkgs to search. This is created by cabal v2, but only if +you have `write-ghc-environment-files: always` in `cabal.project`. +Otherwise, it assumes cabal v1 and will use the `ghc-pkg` command to use +the global package db. -I don't use stack either, but my understanding is this is enough to get -`ghc-pkg` working: +If it doesn't seem to see packages you think it should, run with `--debug` +to see what it sees. + +I don't use stack, but my understanding is this is enough to get `ghc-pkg` +working: export GHC_PACKAGE_PATH=$(stack path --ghc-package-path) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,15 @@ +### 2.4.0 + +- Support cabal v2, look for .ghc.environment.* and get pkgs from there. + +- Look for config in ~/.config/fix-imports in addition to ./.fix-imports. + +- Switch from haskell-src-exts to ghc-lib-parser. This fixes a bunch of +parsing bugs. Along the way I fixed a bug where locally bound names were +misinterpreted as unqualified names. + +- Detect and abort on CPP in the import block, instead of silently deleting it. + ### 2.3.0 - add --edit flag, so I can just replace imports, instead of the whole file diff --git a/dot-fix-imports b/dot-fix-imports --- a/dot-fix-imports +++ b/dot-fix-imports @@ -1,5 +1,6 @@ -- fix-imports looks for a .fix-imports file in the current directory for --- per-project configuration. You can set the file explicitly with --config. +-- per-project configuration, otherwise in ~/.config/fix-imports. +-- You can set the file explicitly with --config. -- -- The syntax is like ghc-pkg or cabal: word, colon, and a list of words. -- A line with leading space is a continuation of the previous line. 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.3.0 +version: 2.4.0 cabal-version: >= 1.10 build-type: Simple synopsis: Program to manage the imports of a haskell module @@ -38,28 +38,43 @@ location: git://github.com/elaforge/fix-imports.git executable fix-imports - main-is: Main.hs + main-is: FixImports/Main.hs other-modules: - Config FixImports Index Types Util + FixImports.Config + FixImports.FixImports + FixImports.Format + FixImports.Index + FixImports.Parse + FixImports.PkgCache + FixImports.Types + FixImports.Util Paths_fix_imports hs-source-dirs: src default-language: Haskell2010 build-depends: base >= 3 && < 5 + , Cabal , containers , cpphs , deepseq , directory , filepath - , haskell-src-exts >= 1.16.0 + , ghc-lib-parser == 9.2.5.20221107 + , ghc-lib-parser-ex == 9.2.1.1 + , ghc-paths , mtl + , pretty , process , split , text , time - , pretty , uniplate - ghc-options: -Wall -fno-warn-name-shadowing + -- , test-karya + -- , el-debug + ghc-options: + -main-is FixImports.Main + -Wall + -fno-warn-name-shadowing test-suite test type: exitcode-stdio-1.0 @@ -67,27 +82,36 @@ main-is: RunTests.hs default-language: Haskell2010 build-depends: + -- copy paste of executable, TODO is there a way to deduplicate? base >= 3 && < 5 + , Cabal , containers , cpphs , deepseq , directory , filepath - , haskell-src-exts >= 1.16.0 + , ghc-lib-parser == 9.2.5.20221107 + , ghc-lib-parser-ex == 9.2.1.1 + , ghc-paths , mtl + , pretty , process , split , text , time - , pretty , uniplate , test-karya other-modules: - Config - Config_test - FixImports - FixImports_test - Index - Types - Util + FixImports.Config + FixImports.Config_test + FixImports.FixImports + FixImports.FixImports_test + FixImports.Format + FixImports.Format_test + FixImports.Index + FixImports.Parse + FixImports.Parse_test + FixImports.PkgCache + FixImports.Types + FixImports.Util diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,514 +0,0 @@ --- | Per-project 'Config' and functions to interpret it. -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -- sort keys only care about Ord -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -module Config where -import Control.Monad (foldM, unless) -import Data.Bifunctor (second) -import qualified Data.Char as Char -import qualified Data.Either as Either -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Text.IO as Text.IO -import qualified Data.Tuple as Tuple - -import qualified Language.Haskell.Exts as Haskell -import qualified Language.Haskell.Exts.Extension as Extension -import qualified System.FilePath as FilePath -import qualified System.IO as IO -import qualified Text.PrettyPrint as PP -import Text.PrettyPrint ((<+>)) -import qualified Text.Read as Read - -import qualified Index -import qualified Types -import qualified Util - - -data Config = Config { - -- | Additional directories to search for local modules. Taken from the - -- -i flag and 'include' config line. - _includes :: [FilePath] - -- | These language extensions are enabled by default. - , _language :: [Extension.Extension] - -- | Import sort order. Used by 'formatGroups'. - , _order :: Order - -- | Heuristics to pick the right module. Used by 'pickModule'. - , _modulePriority :: Priorities - -- | Map unqualified names to the module to import for them. - , _unqualified :: Map.Map (Haskell.Name ()) Types.ModuleName - -- import-as: Data.Text.Lazy as DTL -> Map DTL Data.Text.Lazy - , _qualifyAs :: Map.Map Types.Qualification Types.Qualification - , _format :: Format - , _debug :: Bool - } deriving (Eq, Show) - -data Order = Order { - _importOrder :: Priority ModulePattern - -- | Put unqualified import-all imports last. - , _sortUnqualifiedLast :: Bool - } deriving (Eq, Show) - -data Priorities = Priorities { - -- | Place these packages either first or last in priority. - prioPackage :: Priority Index.Package - -- | Place these modules either first or last in priority. - , prioModule :: Priority Types.ModuleName - } deriving (Eq, Show) - -instance Semigroup Priorities where - Priorities a1 b1 <> Priorities a2 b2 = Priorities (a1<>a2) (b1<>b2) -instance Monoid Priorities where - mempty = Priorities mempty mempty - -data Priority a = Priority { high :: [a], low :: [a] } - deriving (Eq, Show) - -instance Semigroup (Priority a) where - Priority a1 b1 <> Priority a2 b2 = Priority (a1<>a2) (b1<>b2) -instance Monoid (Priority a) where - mempty = Priority mempty mempty - -data Format = Format { - -- | If true, group imports by their first component. - _groupImports :: Bool - -- | Insert space for unqualified imports to make the modules line up. - , _leaveSpaceForQualified :: Bool - -- | Number of columns to wrap to. - , _columns :: Int - } deriving (Eq, Show) - --- | A simple pattern: @M.@ matches M and M.*. Anything else matches exactly. -type ModulePattern = String - -matchModule :: ModulePattern -> Types.ModuleName -> Bool -matchModule pattern (Types.ModuleName mod) = case Util.unsnoc pattern of - Nothing -> False - Just (parent, '.') -> parent == mod || pattern `List.isPrefixOf` mod - _ -> pattern == mod - -empty :: Config -empty = Config - { _includes = [] - , _language = [] - , _order = Order - { _importOrder = Priority { high = [], low = [] } - , _sortUnqualifiedLast = False - } - , _modulePriority = mempty - , _unqualified = mempty - , _qualifyAs = mempty - , _format = defaultFormat - , _debug = False - } - -defaultFormat :: Format -defaultFormat = Format - { _groupImports = True - , _leaveSpaceForQualified = False - , _columns = 80 - } - --- | Parse .fix-imports file. -parse :: Text -> (Config, [Text]) -parse text = (config, errors) - where - commas = Text.intercalate ", " - errors = map (".fix-imports: "<>) $ concat - [ [ "duplicate fields: " <> commas duplicates | not (null duplicates) ] - , [ "unrecognized fields: " <> commas unknownFields - | not (null unknownFields) - ] - , [ "unknown language extensions: " <> commas unknownLanguage - | not (null unknownLanguage) - ] - , [ "unqualified: " <> commas unknownUnqualified - | not (null unknownUnqualified) - ] - , [ "qualify-as: " <> commas unknownQualifyAs - | not (null unknownQualifyAs) - ] - , maybe [] ((:[]) . ("format: "<>)) formatError - ] - config = empty - { _includes = getStrings "include" - , _language = language - , _order = Order - { _importOrder = Priority - { high = getStrings "import-order-first" - , low = getStrings "import-order-last" - } - , _sortUnqualifiedLast = getBool "sort-unqualified-last" - } - , _modulePriority = Priorities - { prioPackage = Priority - { high = getStrings "prio-package-high" - , low = getStrings "prio-package-low" - } - , prioModule = Priority - { high = getModules "prio-module-high" - , low = getModules "prio-module-low" - } - } - , _unqualified = Map.fromList $ map Tuple.swap unqualified - , _format = format - , _qualifyAs = qualifyAs - } - (unknownUnqualified, unqualified) = Either.partitionEithers $ - parseUnqualified (Text.unwords (get "unqualified")) - (unknownLanguage, language) = parseLanguage (get "language") - (unknownQualifyAs, qualifyAs) = - parseQualifyAs $ Text.unwords $ get "qualify-as" - (format, formatError) = case parseFormat (get "format") of - Right format -> (format, Nothing) - Left err -> (defaultFormat, Just err) - unknownFields = Map.keys fields List.\\ valid - valid = - [ "format" - , "import-order-first", "import-order-last" - , "include" - , "language" - , "prio-module-high", "prio-module-low" - , "prio-package-high", "prio-package-low" - , "qualify-as" - , "sort-unqualified-last" - , "unqualified" - ] - fields = Map.fromList sections - sections = Index.parseSections text - duplicates = map head $ filter ((>1) . length) $ List.group $ List.sort $ - map fst sections - - getModules = map (Types.ModuleName . Text.unpack) . get - get k = Map.findWithDefault [] k fields - getStrings = map Text.unpack . get - getBool k = k `Map.member` fields - -parseFormat :: [Text] -> Either Text Format -parseFormat = foldM set defaultFormat - where - set fmt "leave-space-for-qualified" = Right $ - fmt { _leaveSpaceForQualified = True } - set fmt "no-group" = Right $ fmt { _groupImports = False } - set fmt w | Just cols <- Text.stripPrefix "columns=" w = - case Read.readMaybe (Text.unpack cols) of - Nothing -> Left $ "non-numeric: " <> w - Just cols -> Right $ fmt { _columns = cols } - set _ w = Left $ "unrecognized word: " <> showt w - --- | --- "A.B(c); Q(r)" -> [Right ("A.B", "c"), Right ("Q", "r")] -parseUnqualified :: Text - -> [Either Text (Types.ModuleName, Haskell.Name ())] -parseUnqualified = concatMap (parse . Text.break (=='(')) . Text.splitOn ";" - where - parse (pre, post) - | Text.null pre && Text.null post = [] - | Text.null pre = [Left $ "no module name before " <> showt post] - | Text.null post = [Left $ "no import after " <> showt pre] - | Just imports <- hasParens post = - map (parseUnqualifiedImport (Text.strip pre)) - (map Text.strip (Text.splitOn "," imports)) - | otherwise = [Left $ "expected parens: " <> showt post] - --- | --- "A.B" "(c)" -> (Haskell.Ident () "c", "A.B") --- "A.B" "((+))" -> (Haskell.Symbol () "+", "A.B") -parseUnqualifiedImport :: Text -> Text - -> Either Text (Types.ModuleName, Haskell.Name ()) -parseUnqualifiedImport pre post = do - unless (Text.all isModuleChar pre) $ - Left $ "this doesn't look like a module name: " <> showt pre - let module_ = Types.ModuleName (Text.unpack pre) - case hasParens post of - Just op - | Text.all Util.haskellOpChar op -> - Right (module_, Haskell.Symbol () (Text.unpack op)) - | otherwise -> Left $ "non-symbols in operator: " <> showt post - Nothing - | Text.all (not . Util.haskellOpChar) post -> - Right (module_, Haskell.Ident () (Text.unpack post)) - | otherwise -> - Left $ "symbol char in id, use parens: " <> showt post - where - isModuleChar c = Char.isLetter c || Char.isDigit c || c == '.' - --- | --- "A.B as AB; C as E" -> [("AB", "A.B"), ("E", "C")] -parseQualifyAs :: Text - -> ([Text], Map.Map Types.Qualification Types.Qualification) -parseQualifyAs field - | Text.null field = ([], mempty) - | otherwise = second Map.fromList . Either.partitionEithers - . map (parse . Text.words) . Text.splitOn ";" $ field - where - parse [module_, "as", alias] = Right - ( Types.Qualification (Text.unpack alias) - , Types.Qualification (Text.unpack module_) - ) - parse ws = Left $ "stanza should look like 'ModuleName as X':" - <> Text.unwords ws - -hasParens :: Text -> Maybe Text -hasParens s - | "(" `Text.isPrefixOf` s && ")" `Text.isSuffixOf` s = - Just $ Text.drop 1 $ Text.dropEnd 1 s - | otherwise = Nothing - -parseLanguage :: [Text] -> ([Text], [Extension.Extension]) -parseLanguage = Either.partitionEithers . map parse - where - parse w = case Extension.parseExtension (Text.unpack w) of - Extension.UnknownExtension _ -> Left w - ext -> Right ext - --- * pick candidates - -pickModule :: Priorities -> FilePath - -> [(Maybe Index.Package, Types.ModuleName)] - -> Maybe (Maybe Index.Package, Types.ModuleName) -pickModule prios modulePath candidates = - Util.minimumOn (uncurry (prioritize prios modulePath)) $ - -- Don't pick myself! - filter ((/= Types.pathToModule modulePath) . snd) candidates - --- | The order of priority is: --- --- - high or low in 'prioModule' --- - local modules that share prefix with the module path --- - local modules to ones from packages --- - package modules high or low in 'prioPackage' --- - prefer with fewer dots, so System.IO over Data.Text.IO --- - If all else is equal alphabetize so at least the order is predictable. -prioritize :: Priorities -> FilePath -> Maybe String -> Types.ModuleName -> _ -prioritize prios modulePath mbPackage mod = - ( modulePrio (prioModule prios) mod - , localPrio mbPackage - , packagePrio (prioPackage prios) mbPackage - , length $ filter (=='.') $ Types.moduleName mod - , Types.moduleName mod - ) - where - localPrio Nothing = Before $ localOrder modulePath mod - localPrio (Just _) = After - - packagePrio _ Nothing = Nothing - packagePrio (Priority {high, low}) (Just pkg) = - Just $ searchPrio high low pkg - modulePrio (Priority {high, low}) = - searchPrio (map Types.moduleName high) (map Types.moduleName low) - . Types.moduleName - --- | This is like Maybe, except that a present value will always sort before an --- absent one. -data Before a = Before a | After deriving (Eq, Show) -instance Ord a => Ord (Before a) where - compare After After = EQ - compare (Before _) After = LT - compare After (Before _) = GT - compare (Before a) (Before b) = compare a b - --- | Lower numbers for modules that share more prefix with the module's path. --- A/B/Z.hs vs A.B.C -> -2 --- A/Z.hs vs B -> 0 -localOrder :: FilePath -> Types.ModuleName -> Int -localOrder modulePath mod = negate $ length $ takeWhile id $ zipWith (==) - (Util.split "/" (Types.moduleToPath mod)) - (Util.split "/" (FilePath.takeDirectory modulePath)) - -searchPrio :: [String] -> [String] -> String -> Int -searchPrio high low mod = case List.findIndex (== mod) high of - Just n -> - length high + n - Nothing -> maybe 0 (+1) (List.findIndex (== mod) low) - - --- * format imports - --- | Format import list. Imports are alphabetized and grouped into sections --- based on the top level module name (before the first dot). Sections that --- are too small are grouped with the section below them. --- --- The local imports are sorted and grouped separately from the package --- imports. Rather than being alphabetical, they are sorted in a per-project --- order that should be general-to-specific. --- --- An unqualified import will follow a qualified one. The Prelude, if --- imported, always goes first. -formatGroups :: Format -> Order -> [Types.ImportLine] -> String -formatGroups format order imports = - unlines $ joinGroups - [ showGroups (group (Util.sortOn packagePrio package)) - , showGroups (group (Util.sortOn localPrio local)) - , showGroups [Util.sortOn name unqualified] - ] - where - packagePrio import_ = - ( name import_ /= prelude - , name import_ - , qualifiedPrio import_ - ) - localPrio import_ = - ( localPriority (_importOrder order) (Types.importModule import_) - , name import_ - , qualifiedPrio import_ - ) - qualifiedPrio = not . qualifiedImport - name = Types.importModule - (unqualified, local, package) = Util.partition2 - ((_sortUnqualifiedLast order &&) . isUnqualified . Types.importDecl) - ((==Types.Local) . Types.importSource) - imports - group - | _groupImports format = collapse . Util.groupOn topModule - | otherwise = (:[]) - topModule = takeWhile (/='.') . Types.moduleName . Types.importModule - collapse [] = [] - collapse (x:xs) - | length x <= 2 = case collapse xs of - [] -> [x] - y : ys -> (x ++ y) : ys - | otherwise = x : collapse xs - showGroups = List.intercalate [""] . map (map (showImport format)) - joinGroups = List.intercalate [""] . filter (not . null) - prelude = Types.ModuleName "Prelude" - -isUnqualified :: Haskell.ImportDecl a -> Bool -isUnqualified imp = not (Haskell.importQualified imp) - && Maybe.isNothing (Haskell.importSpecs imp) - --- | Modules whose top level element is in 'importFirst' go first, ones in --- 'importLast' go last, and the rest go in the middle. --- --- Like 'searchPrio' but for order. -localPriority :: Priority ModulePattern -> Types.ModuleName - -> (Int, Maybe Int) -localPriority prio import_ = - case List.findIndex (`matchModule` import_) firsts of - Just k -> (-1, Just k) - Nothing -> case List.findIndex (`matchModule` import_) lasts of - Nothing -> (0, Nothing) - Just k -> (1, Just k) - where - firsts = high prio - lasts = low prio - -qualifiedImport :: Types.ImportLine -> Bool -qualifiedImport = Haskell.importQualified . Types.importDecl - -showImport :: Format -> Types.ImportLine -> String -showImport format (Types.ImportLine decl cmts _) = - above ++ showImportDecl format decl - ++ (if null right then "" else ' ' : right) - where - above = concat [cmt ++ "\n" | Types.Comment Types.CmtAbove cmt <- cmts] - right = Util.join "\n" [cmt | Types.Comment Types.CmtRight cmt <- cmts] - -showImportDecl :: Format -> Types.ImportDecl -> String -showImportDecl format = PP.renderStyle style . prettyImportDecl format - where - style = Haskell.style - { Haskell.lineLength = _columns format - , Haskell.ribbonsPerLine = 1 - } - --- showImportDecl format = case _ppConfig format of --- Nothing -> Haskell.prettyPrintStyleMode style Haskell.defaultMode --- Just config -> PP.renderStyle style . prettyImportDecl config --- where --- style = Haskell.style --- { Haskell.lineLength = _columns format --- , Haskell.ribbonsPerLine = 1 --- } - -prettyImportDecl :: Format -> Haskell.ImportDecl a -> PP.Doc -prettyImportDecl format - (Haskell.ImportDecl _ m qual src safe mbPkg mbName mbSpecs) = do - mySep - [ "import" - , if qual || not (_leaveSpaceForQualified format) then mempty - else PP.text (replicate (length ("qualified" :: String)) ' ') - , if src then "{-# SOURCE #-}" else mempty - , if safe then "safe" else mempty - , if qual then "qualified" else mempty - , maybe mempty (\s -> PP.text (show s)) mbPkg - , nameOf m - , maybe mempty (\m -> "as" <+> nameOf m) mbName - , maybe mempty prettyImportSpecList mbSpecs - ] - where - nameOf (Haskell.ModuleName _ s) = PP.text s - --- ** Language.Haskell.Exts.Pretty copy-paste - --- Language.Haskell.Exts.Pretty doesn't export the pretty method. --- --- Ironically the haskell-src-exts complains about having to copy paste --- PP.punctuate, which is no longer necessary, while forcing me to copy paste --- much more, by committing the same mistake. - -prettyImportSpecList :: Haskell.ImportSpecList a -> PP.Doc -prettyImportSpecList (Haskell.ImportSpecList _ b ispecs) = - (if b then "hiding" else mempty) <+> parenList (map prettyISpec ispecs) - -prettyISpec :: Haskell.ImportSpec a -> PP.Doc -prettyISpec = \case - Haskell.IVar _ name -> prettyName name - Haskell.IAbs _ ns name -> prettyNamespace ns <+> prettyName name - Haskell.IThingAll _ name -> prettyName name <> PP.text "(..)" - Haskell.IThingWith _ name nameList -> - prettyName name <> (parenList . map prettyCName $ nameList) - -prettyName :: Haskell.Name l -> PP.Doc -prettyName name = case name of - Haskell.Symbol _ ('#':_) -> PP.char '(' <+> ppName name <+> PP.char ')' - _ -> parensIf (isSymbolName name) (ppName name) - -prettyCName :: Haskell.CName l -> PP.Doc -prettyCName = \case - Haskell.VarName _ n -> prettyName n - Haskell.ConName _ n -> prettyName n - -prettyNamespace :: Haskell.Namespace l -> PP.Doc -prettyNamespace = \case - Haskell.NoNamespace {} -> mempty - Haskell.TypeNamespace {} -> "type" - Haskell.PatternNamespace {} -> "pattern" - -parensIf :: Bool -> PP.Doc -> PP.Doc -parensIf True = PP.parens -parensIf False = id - -isSymbolName :: Haskell.Name l -> Bool -isSymbolName (Haskell.Symbol {}) = True -isSymbolName _ = False - - -ppName :: Haskell.Name l -> PP.Doc -ppName (Haskell.Ident _ s) = PP.text s -ppName (Haskell.Symbol _ s) = PP.text s - -parenList :: [PP.Doc] -> PP.Doc -parenList = PP.parens . PP.fsep . PP.punctuate PP.comma - -pretty :: Haskell.Pretty a => a -> PP.Doc -pretty _ = "?" - -mySep :: [PP.Doc] -> PP.Doc -mySep [] = error "mySep got empty" -mySep [x] = x -mySep (x:xs) = x <+> PP.fsep xs - --- * log - -debug :: Config -> Text -> IO () -debug config msg - | _debug config = Text.IO.hPutStrLn IO.stderr msg - | otherwise = return () - -showt :: Show a => a -> Text -showt = Text.pack . show diff --git a/src/Config_test.hs b/src/Config_test.hs deleted file mode 100644 --- a/src/Config_test.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -module Config_test where -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified EL.Test.Testing as Testing -import qualified Language.Haskell.Exts as Haskell - -import qualified Config -import qualified FixImports -import qualified Types - -import EL.Test.Global - - -test_parse = do - let f = check . Config.parse . Text.unlines - check (config, errs) - | null errs = Right config - | otherwise = Left $ Text.unlines errs - equal (f []) $ Right Config.empty - leftLike (f ["include: a", "include: b"]) "duplicate fields" - equal (Config._order <$> - f ["import-order-first: A", "import-order-last: B"]) $ - Right $ Config.Order - { _importOrder = Config.Priority ["A"] ["B"] - , _sortUnqualifiedLast = False - } - -test_parseUnqualified = do - let f = Config._unqualified . parseConfig - equal (f ["unqualified: A.B (c); D.E ((+))"]) $ Map.fromList - [ (Haskell.Ident () "c", "A.B") - , (Haskell.Symbol () "+", "D.E") - ] - equal (f ["unqualified: A.B(c, d)"]) $ Map.fromList - [ (Haskell.Ident () "c", "A.B") - , (Haskell.Ident () "d", "A.B") - ] - equal (f ["unqualified: A.B (c,(+))"]) $ Map.fromList - [ (Haskell.Ident () "c", "A.B") - , (Haskell.Symbol () "+", "A.B") - ] - -test_parseQualifyAs = do - let f = Config._qualifyAs . parseConfig - equal (f ["qualify-as: A.B as AB; E as F"]) $ Map.fromList - [ ("AB", "A.B") - , ("F", "E") - ] - stringsLike (snd $ Config.parse "qualify-as: gibble gabble") - ["stanza should look like"] - -test_pickModule = do - let f config modulePath candidates = Config.pickModule - (Config._modulePriority (parseConfig config)) - modulePath candidates - equal (f [] "X.hs" []) Nothing - let localAB = [(Nothing, "A.M"), (Nothing, "B.M")] - equal (f [] "X.hs" localAB) $ - Just (Nothing, "A.M") - equal (f ["prio-module-high: B.M"] "X.hs" localAB) $ - Just (Nothing, "B.M") - -- Has to be an exact match. - equal (f ["prio-module-high: B"] "X.hs" localAB) $ - Just (Nothing, "A.M") - - -- Local modules take precedence. - equal (f [] "A/B.hs" [(Nothing, "B.M"), (Just "pkg", "B.M")]) $ - Just (Nothing, "B.M") - equal (f [] "A/B/C.hs" [(Nothing, "A.B.M"), (Just "pkg", "B.M")]) $ - Just (Nothing, "A.B.M") - -- Closer local modules precede further ones. - equal (f [] "A/B/C.hs" [(Nothing, "A.B.M"), (Nothing, "A.M")]) $ - Just (Nothing, "A.B.M") - -- Prefer fewer dots. - equal (f [] "X.hs" [(Just "p1", "A.B.M"), (Just "p2", "Z.M")]) $ - Just (Just "p2", "Z.M") - -test_formatGroups = do - let f config imports = lines $ Config.formatGroups Config.defaultFormat - (Config._order (parseConfig config)) - (Testing.expectRight (parse (unlines imports))) - equal (f [] []) [] - -- Unqualified import-all goes last. - equal (f ["sort-unqualified-last: t"] - [ "import Z", "import A" - , "import qualified C", "import qualified B" - , "import C (a)" - ]) - [ "import qualified B" - , "import qualified C" - , "import C (a)" - , "" - , "import A" - , "import Z" - ] - - equal (f [] ["import qualified Z", "import qualified A"]) - [ "import qualified A" - , "import qualified Z" - ] - equal (f ["import-order-first: Z"] - ["import qualified Z", "import qualified A"]) - [ "import qualified Z" - , "import qualified A" - ] - equal (f ["import-order-last: A"] - ["import qualified Z", "import qualified A"]) - [ "import qualified Z" - , "import qualified A" - ] - - -- Exact match. - equal (f ["import-order-first: Z"] - ["import qualified Z.A", "import qualified A"]) - [ "import qualified A" - , "import qualified Z.A" - ] - -- Unless it's a prefix match. - equal (f ["import-order-first: Z."] - ["import qualified Z.A", "import qualified A"]) - [ "import qualified Z.A" - , "import qualified A" - ] - -test_showImportLine = do - let f = fmap (Config.showImportDecl style . Types.importDecl . head) . parse - style = Config.defaultFormat { Config._leaveSpaceForQualified = True } - -- pprint $ fmap (Types.importDecl . head) . parse $ "import A.B as C (x)" - equal (f "import A.B as C (x)") $ Right "import A.B as C (x)" - -test_leaveSpaceForQualified = do - let f columns leaveSpace = - fmap (Config.showImportDecl (fmt columns leaveSpace) . head - . map Types.importDecl) - . parse - fmt columns leaveSpace = Config.defaultFormat - { Config._columns = columns - , Config._leaveSpaceForQualified = leaveSpace - } - equal (f 80 False "import Foo.Bar (a, b, c)") $ - Right "import Foo.Bar (a, b, c)" - equal (f 80 True "import Foo.Bar (a, b, c)") $ - Right "import Foo.Bar (a, b, c)" - - equal (f 20 False "import Foo.Bar (a, b, c)") $ - Right "import Foo.Bar\n (a, b, c)" - equal (f 30 True "import Foo.Bar (a, b, c)") $ - Right "import Foo.Bar\n (a, b, c)" - - equal (f 30 True "import Foo.Bar (tweetle, beetle, paddle, battle)") $ Right - "import Foo.Bar\n\ - \ (tweetle, beetle,\n\ - \ paddle, battle)" - --- * util - -importLine :: Types.ImportDecl -> Types.ImportLine -importLine decl = Types.ImportLine - { importDecl = decl - , importComments = [] - , importSource = Types.Local - } - -parse :: String -> Either String [Types.ImportLine] -parse source = case FixImports.parse [] "" source of - Haskell.ParseFailed srcloc err -> - Left $ Haskell.prettyPrint srcloc ++ ": " ++ err - Haskell.ParseOk (mod, _cmts) -> - Right $ map importLine $ FixImports.moduleImportDecls mod - -parseConfig :: [Text.Text] -> Config.Config -parseConfig lines - | null errs = config - | otherwise = error $ "parsing " <> show lines <> ": " - <> Text.unpack (Text.unlines errs) - where (config, errs) = Config.parse (Text.unlines lines) diff --git a/src/FixImports.hs b/src/FixImports.hs deleted file mode 100644 --- a/src/FixImports.hs +++ /dev/null @@ -1,650 +0,0 @@ -{- | Automatically fix the import list in a haskell module. - - The process is as follows: - - - Parse the entire file and extract the Qualification of qualified names - like @A.b@, which is simple @A@. - - - Combine this with the modules imported to decide which imports can be - removed and which ones must be added. - - - For added imports, guess the complete import path implied by the - Qualification. This requires some heuristics: - - - Check local modules first. Start in the current module's directory - and then try from the current directory, descending recursively. - - - If no local modules are found, check the package database. There is - a system of package priorities so that @List@ will yield @Data.List@ - from @base@ rather than @List@ from @haskell98@. After that, shorter - matches are prioritized so @System.Process@ is chosen over - @System.Posix.Process@. - - - If the module is not found at all, an error is printed on stderr and - the unchanged file on stdout. - - - Of course the heuristics may get the wrong module, but existing - imports are left alone so you can edit them by hand. - - - Then imports are sorted, grouped, and a new module is written to stdout - with the new import block replacing the old one. - - - The default import formatting separates package imports from local - imports, and groups them by their toplevel module name (before the - first dot). Small groups are combined. They go in alphabetical order - by default, but a per-project order may be defined. --} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -module FixImports where -import Prelude hiding (mod) -import Control.Applicative ((<$>)) -import qualified Control.Monad.State.Strict as State -import qualified Control.DeepSeq as DeepSeq -import Control.Monad.Trans (lift) -import Data.Bifunctor (first) -import qualified Data.Char as Char -import qualified Data.Either as Either -import qualified Data.Generics.Uniplate.Data as Uniplate -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Time.Clock as Clock -import qualified Data.Tuple as Tuple - -import qualified Language.Haskell.Exts as Haskell -import qualified Language.Haskell.Exts.Extension as Extension -import qualified Language.Preprocessor.Cpphs as Cpphs - -import qualified Numeric -import qualified System.Directory as Directory -import qualified System.FilePath as FilePath -import System.FilePath (()) - -import qualified Config -import qualified Index -import qualified Types -import qualified Util - -import Control.Monad - - --- | Look only this deep for local modules. -searchDepth :: Int -searchDepth = 12 - -data Result = Result { - resultRange :: (Row, Row) - , resultImports :: String - , resultAdded :: Set.Set Types.ModuleName - , resultRemoved :: Set.Set Types.ModuleName - , resultMetrics :: [Metric] - } deriving (Show) - --- | Line number in the input file. -type Row = Int - -type Metric = (Clock.UTCTime, Text) - -addMetrics :: [Metric] -> Result -> Result -addMetrics ms result = result { resultMetrics = ms ++ resultMetrics result } - -fixModule :: Config.Config -> FilePath -> String - -> IO (Either String Result, [Text]) -fixModule config modulePath source = do - mStart <- metric () "start" - processedSource <- cppModule modulePath source - mCpp <- metric () "cpp" - case parse (Config._language config) modulePath processedSource of - Haskell.ParseFailed srcloc err -> - return (Left $ Haskell.prettyPrint srcloc ++ ": " ++ err, []) - Haskell.ParseOk (mod, cmts) -> do - mParse <- metric (mod `seq` (), cmts) "parse" - index <- Index.load - mLoad <- metric () "load-index" - fmap (fmap List.reverse) $ flip State.runStateT [] $ - fmap (addMetrics [mStart, mCpp, mParse, mLoad]) <$> - fixImports ioFilesystem config index modulePath mod cmts - -parse :: [Extension.Extension] -> FilePath -> String - -> Haskell.ParseResult - (Haskell.Module Haskell.SrcSpanInfo, [Haskell.Comment]) -parse extensions modulePath = - Haskell.parseFileContentsWithComments $ Haskell.defaultParseMode - { Haskell.parseFilename = modulePath - , Haskell.extensions = extensions ++ defaultExtensions - -- The meaning of Nothing is undocumented, but I think it means - -- to not check for fixity ambiguity at all, which is what I want. - , Haskell.fixities = Nothing - } - where - defaultExtensions = map Extension.EnableExtension $ - Extension.toExtensionList Extension.Haskell2010 [] - -- GHC has this extension enabled by default, and it's easy - -- to wind up with code that relies on it: - -- http://www.haskell.org/ghc/docs/7.6.3/html/users_guide/bugs-and-infelicities.html#infelicities-syntax - ++ [Extension.NondecreasingIndentation] - --- | The parse function takes a CPP extension, but doesn't actually pay any --- attention to it, so I have to run CPP myself. The imports are fixed --- post-CPP so if you put CPP in the imports block it will be stripped out. --- It seems hard to fix imports inside CPP. -cppModule :: FilePath -> String -> IO String -cppModule filename = Cpphs.runCpphs options filename - where - options = Cpphs.defaultCpphsOptions { Cpphs.boolopts = boolOpts } - boolOpts = Cpphs.defaultBoolOptions - { Cpphs.macros = True - , Cpphs.locations = False - , Cpphs.hashline = False - , Cpphs.pragma = False - , Cpphs.stripEol = True - , Cpphs.stripC89 = True - , Cpphs.lang = True -- lex input as haskell code - , Cpphs.ansi = True - , Cpphs.layout = True - , Cpphs.literate = False -- untested with literate code - , Cpphs.warnings = False - } - --- | Capture all the IO operations needed by fixImports, so I can test without --- IO. I could have used Free, but the operations are few, so it seemed --- simpler to factor them out. -data Filesystem m = Filesystem { - _listDir :: FilePath -> m ([FilePath], [FilePath]) -- ^ (dirs, files) - , _doesFileExist :: FilePath -> m Bool - , _metric :: forall a. DeepSeq.NFData a => a -> Text -> m Metric - } - -ioFilesystem :: Filesystem IO -ioFilesystem = Filesystem - { _listDir = \ dir -> do - fns <- Maybe.fromMaybe [] <$> Util.catchENOENT (Util.listDir dir) - Util.partitionM Directory.doesDirectoryExist fns - , _doesFileExist = Directory.doesFileExist - , _metric = metric - } - -type LogT m a = State.StateT [Text] m a - -debug :: Monad m => Config.Config -> Text -> LogT m () -debug config msg = when (Config._debug config) $ State.modify' (msg:) - -- The check is unnecessary since I check debug before printing them, but - -- it'll save a thunk at least. - --- | Take a parsed module along with its unparsed text. Generate a new import --- block with proper spacing, formatting, and comments. Then snip out the --- import block on the import file, and replace it. -fixImports :: Monad m => Filesystem m -> Config.Config -> Index.Index - -> FilePath -> Types.Module -> [Haskell.Comment] - -> LogT m (Either String Result) -fixImports fs config index modulePath mod cmts = do - let (newImports, unusedImports, imports, range) = importInfo mod cmts - mProcess <- lift $ _metric fs - (length newImports, length unusedImports, length imports, range) - "process" - mbNew <- mapM (findNewImport fs config modulePath index) - (Set.toList newImports) - mNewImports <- lift $ _metric fs mbNew "find-new-imports" - (imports, newUnqualImports, unusedUnqual) <- return $ - fixUnqualified config mod imports - newUnqualImports <- lift $ mapM (locateImport fs) newUnqualImports - mUnqual <- lift $ _metric fs newUnqualImports "unqualified-imports" - mbExisting <- mapM (findImport fs index (Config._includes config)) imports - mExistingImports <- lift $ _metric fs mbExisting "find-existing-imports" - let existing = map (Types.importDeclModule . fst) imports - let (notFound, importLines) = Either.partitionEithers $ - zipWith mkError - (map toModule (Set.toList newImports) ++ existing) - (mbNew ++ mbExisting) - mkError _ (Just imp) = Right imp - mkError mod Nothing = Left mod - let formattedImports = - Config.formatGroups (Config._format config) (Config._order config) - (importLines ++ newUnqualImports) - return $ case notFound of - _ : _ -> Left $ "not found: " - ++ Util.join ", " (map Types.moduleName notFound) - [] -> Right $ Result - { resultRange = range - , resultImports = formattedImports - , resultAdded = Set.fromList $ - map (Types.importDeclModule . Types.importDecl) $ - Maybe.catMaybes mbNew ++ newUnqualImports - , resultRemoved = unusedImports <> Set.fromList unusedUnqual - , resultMetrics = - [mProcess, mNewImports, mExistingImports, mUnqual] - } - where - toModule (Types.Qualification name) = Types.ModuleName name - -locateImport :: Monad m => Filesystem m -> ImportLine -> m Types.ImportLine -locateImport fs (decl, cmts) = do - isLocal <- _doesFileExist fs $ - Types.moduleToPath $ Types.importDeclModule decl - return $ Types.ImportLine - { importDecl = decl - , importComments = cmts - , importSource = if isLocal then Types.Local else Types.Package - } - --- | This is like 'Types.ImportLine', except without Local/Package info. -type ImportLine = (Types.ImportDecl, [Types.Comment]) - - --- | Add unqualified imports. --- --- - Get unqualifieds. --- - If _unqualified non-empty, filter them to the ones in _unqualified. --- - Add or modify import lines for them. --- - Remove imports that don't appear in unqualifiedImports -fixUnqualified :: Config.Config -> Types.Module -> [ImportLine] - -> ([ImportLine], [ImportLine], [Types.ModuleName]) - -- ^ (modified, new, removed) -fixUnqualified config mod imports = - -- Add new references. - -- Then filter out managed symbols which are no longer present. - -- Then delete empty imports which are now empty. - removeEmptyImports . first (map stripReferences) - . foldr addReferences (imports, []) . Map.toList $ references - where - removeEmptyImports (modified, new) = - (kept, new, map (Types.importDeclModule . fst) removed) - where - (kept, removed) = List.partition (not . emptyImport . fst) modified - references = unqualifiedImports config mod - emptyImport decl = and - [ Map.member moduleName moduleToNames - -- Can delete if it has an import list, but it's empty. - , hasEmptyImportList decl - ] - where moduleName = Types.importDeclModule decl - - stripReferences (decl, cmts) = - ( modifyImportSpecs (filter (keep (Types.importDeclModule decl))) decl - , cmts - ) - where - -- Keep if it's not managed, or it is managed and referenced. - keep moduleName name = not (isManaged moduleName name) - || maybe False (name `elem`) (Map.lookup moduleName references) - addReferences (moduleName, names) (existing, new) = - case Util.modifyAt (matches moduleName . fst) add existing of - Nothing -> (existing, (newImport, []) : new) - Just modified -> (modified, new) - where - add = first $ modifyImportSpecs (names++) - newImport = modifyImportSpecs (names++) $ - mkImportDecl moduleName Nothing True - matches name decl = isUnqualifiedImport decl - && Types.importDeclModule decl == name - isUnqualifiedImport decl = not (Haskell.importQualified decl) - && maybe True (not . importSpecsHiding) (Haskell.importSpecs decl) - - isManaged moduleName name = maybe False (name `elem`) $ - Map.lookup moduleName moduleToNames - moduleToNames :: Map.Map Types.ModuleName [Haskell.Name ()] - moduleToNames = Util.multimap . map Tuple.swap . Map.toList - . Config._unqualified $ config - --- | This field seems to be undocumented. -importSpecsHiding :: Haskell.ImportSpecList a -> Bool -importSpecsHiding (Haskell.ImportSpecList _ hiding _) = hiding - -hasEmptyImportList :: Haskell.ImportDecl a -> Bool -hasEmptyImportList decl = case Haskell.importSpecs decl of - Just (Haskell.ImportSpecList _ _ specs) -> null specs - Nothing -> False - --- | If this import has a import list, modify its contents. --- --- I strip SrcSpanInfo from the Names because otherwise sorting and unique'ing --- is too finicky. -modifyImportSpecs :: ([Haskell.Name ()] -> [Haskell.Name ()]) - -> Types.ImportDecl -> Types.ImportDecl -modifyImportSpecs modify decl = case Haskell.importSpecs decl of - Just specs | not (importSpecsHiding specs) -> decl - { Haskell.importSpecs = Just $ modifySpecs specs - } - _ -> decl - where - -- hiding should be False due to the match above. - modifySpecs (Haskell.ImportSpecList span _hiding specs) = - Haskell.ImportSpecList span False $ Set.toList $ Set.fromList $ - map makeVar (doModify vars) ++ others - where - (vars, others) = Util.partitionOn varOf specs - varOf (Haskell.IVar _ name) = Just name - varOf (Haskell.IAbs _ (Haskell.NoNamespace _) name) = Just name - varOf _ = Nothing - doModify = map addSpan . modify . map stripSpan - -- IAbs is constructors and classes, but I can disambiguate just by seeing - -- if it's capitalized. - makeVar name - | isCaps name = Haskell.IAbs noSpan (Haskell.NoNamespace noSpan) name - | otherwise = Haskell.IVar noSpan name - isCaps (Haskell.Ident _ name) = all Char.isUpper (take 1 name) - isCaps _ = False - -stripSpan :: Functor f => f Haskell.SrcSpanInfo -> f () -stripSpan = fmap (const ()) - -addSpan :: Functor f => f () -> f Haskell.SrcSpanInfo -addSpan = fmap (const noSpan) - -unqualifiedImports :: Config.Config -> Types.Module - -> Map.Map Types.ModuleName [Haskell.Name ()] -unqualifiedImports config mod - | unqual == mempty = mempty - | otherwise = Util.multimap $ - Maybe.mapMaybe (\k -> (, k) <$> Map.lookup k unqual) $ - map stripSpan $ moduleUnqualifieds mod - where unqual = Config._unqualified config - --- | Clip out the range from the given text and replace it with the given --- lines. -substituteImports :: String -> (Int, Int) -> String -> String -substituteImports imports (start, end) source = - unlines pre ++ imports ++ unlines post - where - (pre, within) = splitAt start (lines source) - (_, post) = splitAt (end-start) within - --- * find new imports - --- | Make a new ImportLine from a ModuleName. -findNewImport :: Monad m => Filesystem m -> Config.Config -> FilePath - -> Index.Index -> Types.Qualification - -> LogT m (Maybe Types.ImportLine) - -- ^ Nothing if the module wasn't found -findNewImport fs config modulePath index qual = - fmap make <$> findModule fs config index modulePath qual - where - make (mod, source) = Types.ImportLine - { importDecl = mkImportDecl mod (Just qual) False - , importComments = [] - , importSource = source - } - -mkImportDecl :: Types.ModuleName -> Maybe Types.Qualification -> Bool - -> Types.ImportDecl -mkImportDecl (Types.ModuleName name) qualification withImportList = - Haskell.ImportDecl - { Haskell.importAnn = noSpan - , Haskell.importModule = Haskell.ModuleName noSpan name - , Haskell.importQualified = Maybe.isJust qualification - , Haskell.importSrc = False - , Haskell.importSafe = False - , Haskell.importPkg = Nothing - , Haskell.importAs = Haskell.ModuleName noSpan <$> importAs - , Haskell.importSpecs = if withImportList - then Just $ Haskell.ImportSpecList noSpan False [] - else Nothing - } - where - importAs - -- | Just (Types.Qualification importAs) <- mbImportAs = Just importAs - | Just (Types.Qualification q) <- qualification, q /= name = Just q - | otherwise = Nothing - -noSpan :: Haskell.SrcSpanInfo -noSpan = Haskell.noInfoSpan (Haskell.SrcSpan "" 0 0 0 0) - --- | Find the qualification and its ModuleName and whether it was a Types.Local --- or Types.Package module. Nothing if it wasn't found at all. -findModule :: Monad m => Filesystem m -> Config.Config -> Index.Index - -> FilePath -- ^ Path to the module being fixed. - -> Types.Qualification -> LogT m (Maybe (Types.ModuleName, Types.Source)) -findModule fs config index modulePath qual = do - local <- map fnameToModule <$> ((++) - <$> findLocalModules fs (Config._includes config) qual - <*> maybe (pure []) (findLocalModules fs (Config._includes config)) - qualifyAs) - let package = map (first Just) $ - findPackageModules qual ++ maybe [] findPackageModules qualifyAs - debug config $ "findModule " <> showt qual <> " from " - <> showt modulePath <> ": local " <> showt local - <> "\npackage: " <> showt package - let prio = Config._modulePriority config - return $ case Config.pickModule prio modulePath (local++package) of - Just (package, mod) -> Just - (mod, if package == Nothing then Types.Local else Types.Package) - Nothing -> Nothing - where - findPackageModules q = Map.findWithDefault [] q index - fnameToModule fn = (Nothing, Types.pathToModule fn) - qualifyAs = Map.lookup qual (Config._qualifyAs config) - --- If it's in Config._qualifyAs, then I also search for exactly that module --- name. - --- | Given A.B, look for A/B.hs, */A/B.hs, */*/A/B.hs, etc. in each of the --- include paths. -findLocalModules :: Monad m => Filesystem m -> [FilePath] - -> Types.Qualification -> LogT m [FilePath] -findLocalModules fs includes (Types.Qualification name) = - fmap concat . forM includes $ \dir -> map (stripDir dir) <$> - findFiles fs searchDepth (Types.moduleToPath (Types.ModuleName name)) - dir - -stripDir :: FilePath -> FilePath -> FilePath -stripDir dir path - | dir == "." = path - | otherwise = dropWhile (=='/') $ drop (length dir) path - -findFiles :: Monad m => Filesystem m - -> Int -- ^ Descend into subdirectories this many times. - -> FilePath -- ^ Find files with this suffix. Can contain slashes. - -> FilePath -- ^ Start from this directory. Return [] if it doesn't exist. - -> LogT m [FilePath] -findFiles fs depth file dir = do - (subdirs, fns) <- lift $ _listDir fs dir - subfns <- if depth > 0 - then concat <$> mapM (findFiles fs (depth-1) file) - (filter isModuleDir subdirs) - else return [] - return $ filter sameSuffix fns ++ subfns - where - isModuleDir = all Char.isUpper . take 1 . FilePath.takeFileName - sameSuffix fn = fn == file || ('/' : file) `List.isSuffixOf` fn - - --- * figure out existing imports - --- | Make an existing import into an ImportLine by finding out if it's a local --- module or a package module. -findImport :: Monad m => Filesystem m -> Index.Index -> [FilePath] -> ImportLine - -> LogT m (Maybe Types.ImportLine) -findImport fs index includes (imp, cmts) = do - found <- findModuleName fs index includes (Types.importDeclModule imp) - return $ case found of - Nothing -> Nothing - Just source -> Just $ Types.ImportLine - { importDecl = imp - , importComments = cmts - , importSource = source - } - --- | True if it was found in a local directory, False if it was found in the --- ghc package db, and Nothing if it wasn't found at all. -findModuleName :: Monad m => Filesystem m -> Index.Index -> [FilePath] - -> Types.ModuleName -> LogT m (Maybe Types.Source) -findModuleName fs index includes mod = do - isLocal <- lift $ isLocalModule fs mod ("" : includes) - return $ - if isLocal then Just Types.Local - else if isPackageModule index mod then Just Types.Package - else Nothing - -isLocalModule :: Monad m => Filesystem m -> Types.ModuleName -> [FilePath] - -> m Bool -isLocalModule fs mod = - Util.anyM (_doesFileExist fs . ( Types.moduleToPath mod)) - -isPackageModule :: Index.Index -> Types.ModuleName -> Bool -isPackageModule index (Types.ModuleName name) = - Map.member (Types.Qualification name) index - --- * util - -importInfo :: Types.Module -> [Haskell.Comment] - -> ( Set.Set Types.Qualification - , Set.Set Types.ModuleName - , [ImportLine] - , (Int, Int) - ) - -- ^ (missingImports, unusedImports, unchangedImports, rangeOfImportBlock) -importInfo mod cmts = (missing, unused, declCmts, range) - where - unused = Set.difference (Set.fromList modules) - (Set.fromList (map (Types.importDeclModule . fst) declCmts)) - missing = Set.difference used imported - -- If the Prelude isn't explicitly imported, it's implicitly imported, so - -- if I see Prelude.x it doesn't mean to add an import. - imported = Set.fromList $ prelude : qualifiedImports - - -- Get from the qualified import name back to the actual module name so - -- I can return that. - modules = map Types.importDeclModule imports - qualifiedImports = map Types.importDeclQualification imports - used = Set.fromList (moduleQNames mod) - imports = moduleImportDecls mod - declCmts = - [ imp - | imp@(decl, _) <- associateComments imports - (filterImportCmts range cmts) - , keepImport decl - ] - -- Keep unqualified imports, but only keep qualified ones if they are used. - -- Prelude is considered always used if it appears, because removing it - -- changes import behavour. - keepImport decl = - Set.member (Types.importDeclQualification decl) - (Set.insert prelude used) - || not (Haskell.importQualified decl) - prelude = Types.Qualification "Prelude" - range = importRange mod - -filterImportCmts :: (Int, Int) -> [Haskell.Comment] -> [Haskell.Comment] -filterImportCmts (start, end) = filter inRange - where - inRange (Haskell.Comment _ src _) = start <= s && s < end - where s = Haskell.srcSpanStartLine src - 1 -- spans are 1-based - - --- | Pair ImportDecls up with the comments that apply to them. Comments --- below the last import are dropped, but there shouldn't be any of those --- because they should have been omitted from the comment block. --- --- Spaces between comments above an import will be lost, and multiple comments --- to the right of an import (e.g. commenting a complicated import list) will --- probably be messed up. TODO Fix it if it becomes a problem. -associateComments :: [Types.ImportDecl] -> [Haskell.Comment] -> [ImportLine] -associateComments imports cmts = snd $ List.mapAccumL associate cmts imports - where - associate cmts imp = (after, (imp, associated)) - where - associated = map (Types.Comment Types.CmtAbove . cmtText) above - ++ map (Types.Comment Types.CmtRight . cmtText) right - -- cmts that end before the import beginning are above it - (above, rest) = List.span ((< start impSpan) . end . cmtSpan) cmts - -- remaining cmts that start before or at the import's end are right - -- of it - (right, after) = List.span ((<= end impSpan) . start . cmtSpan) rest - impSpan = Haskell.srcInfoSpan (Haskell.importAnn imp) - cmtSpan (Haskell.Comment _ span _) = span - cmtText (Haskell.Comment True _ s) = "{-" ++ s ++ "-}" - cmtText (Haskell.Comment False _ s) = "--" ++ s - start = Haskell.srcSpanStartLine - end = Haskell.srcSpanEndLine - -moduleImportDecls :: Types.Module -> [Types.ImportDecl] -moduleImportDecls (Haskell.Module _ _ _ imports _) = imports -moduleImportDecls _ = [] - --- | Return half-open line range of import block, starting from (0 based) line --- of first import to the line after the last one. -importRange :: Types.Module -> (Int, Int) -importRange mod = case mod of - -- Haskell.Module _ mb_head _ imports _ -> - -- let start = headEnd mb_head - -- in (start, max start (importsEnd imports)) - Haskell.Module _ Nothing _ imports _ -> - (importsStart imports, importsEnd imports) - Haskell.Module _ (Just modHead) _ imports _ -> - let start = headEnd modHead - in (start, max start (importsEnd imports)) - _ -> (0, 0) - where - -- The parser counts lies from 1, but I return a half-open range from 0. - -- So I don't need to +1 the last line of the head, and since the range - -- is half-open I don't need to -1 the last line of the imports. - headEnd (Haskell.ModuleHead src _ _ _) = endOf src - importsStart [] = 0 - importsStart (importDecl : _) = - startOf (Haskell.importAnn importDecl) - 1 - importsEnd [] = 0 - importsEnd imports = (endOf . Haskell.importAnn . last) imports - - startOf = Haskell.srcSpanStartLine . Haskell.srcInfoSpan - endOf = Haskell.srcSpanEndLine . Haskell.srcInfoSpan - --- | Uniplate is rad. -moduleQNames :: Types.Module -> [Types.Qualification] -moduleQNames mod = - [ Types.moduleToQualification m - | Haskell.Qual _ m _ <- Uniplate.universeBi mod - ] - -moduleUnqualifieds :: Types.Module -> [Types.Name] -moduleUnqualifieds mod = - [name | Haskell.UnQual _ name <- Uniplate.universeBi mod] - --- * metrics - -metric :: DeepSeq.NFData a => a -> Text -> IO Metric -metric val name = do - force val - flip (,) name <$> Clock.getCurrentTime - -showMetrics :: [Metric] -> Text -showMetrics = Text.unlines . format . map diff . Util.zipPrev . Util.sortOn fst - where - format metricDurs = - map (format1 total) (metricDurs ++ [("total", total)]) - where total = sum (map snd metricDurs) - format1 total (metric, dur) = Text.unwords - [ justifyR 8 (showDuration dur) - , justifyR 3 (percent (realToFrac dur / realToFrac total)) - , "-", metric - ] - diff ((prev, _), (cur, metric)) = - (metric, cur `Clock.diffUTCTime` prev) - -force :: DeepSeq.NFData a => a -> IO () -force x = DeepSeq.rnf x `seq` return () - -percent :: Double -> Text -percent = (<>"%") . showt . isInt . round . (*100) - where - isInt :: Int -> Int - isInt = id - -showDuration :: Clock.NominalDiffTime -> Text -showDuration = - Text.pack . ($"s") . Numeric.showFFloat (Just 2) . isDouble . realToFrac - where - isDouble :: Double -> Double - isDouble = id - -justifyR :: Int -> Text -> Text -justifyR width = Text.justifyRight width ' ' - -showt :: Show a => a -> Text -showt = Text.pack . show diff --git a/src/FixImports/Config.hs b/src/FixImports/Config.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Config.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} -- sort keys only care about Ord +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +-- | Parse the config file. +module FixImports.Config where +import Control.Monad (foldM, unless) +import Data.Bifunctor (second) +import qualified Data.Char as Char +import qualified Data.Either as Either +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.IO as Text.IO +import qualified Data.Tuple as Tuple + +import qualified System.FilePath as FilePath +import qualified System.IO as IO +import qualified Text.Read as Read + +import qualified FixImports.Index as Index +import qualified FixImports.Types as Types +import qualified FixImports.Util as Util + + +data Config = Config { + -- | Additional directories to search for local modules. Taken from the + -- -i flag and 'include' config line. + _includes :: [FilePath] + -- | These language extensions are enabled by default. + , _language :: [Types.Extension] + -- | Import sort order. Used by 'formatGroups'. + , _order :: Order + -- | Heuristics to pick the right module. Used by 'pickModule'. + , _modulePriority :: Priorities + -- | Map unqualified names to the module to import for them. + , _unqualified :: Map.Map Types.Name Types.ModuleName + -- | Map abbreviation to the complete qualification: + -- > import-as: Data.Text.Lazy as DTL -> [("DTL", "Data.Text.Lazy")] + , _qualifyAs :: Map.Map Types.Qualification Types.Qualification + , _format :: Format + , _debug :: Bool + } deriving (Eq, Show) + +data Order = Order { + _importOrder :: Priority ModulePattern + -- | Put unqualified import-all imports last. + , _sortUnqualifiedLast :: Bool + } deriving (Eq, Show) + +data Priorities = Priorities { + -- | Place these packages either first or last in priority. + prioPackage :: Priority Index.Package + -- | Place these modules either first or last in priority. + , prioModule :: Priority Types.ModuleName + } deriving (Eq, Show) + +instance Semigroup Priorities where + Priorities a1 b1 <> Priorities a2 b2 = Priorities (a1<>a2) (b1<>b2) +instance Monoid Priorities where + mempty = Priorities mempty mempty + +data Priority a = Priority { high :: [a], low :: [a] } + deriving (Eq, Show) + +instance Semigroup (Priority a) where + Priority a1 b1 <> Priority a2 b2 = Priority (a1<>a2) (b1<>b2) +instance Monoid (Priority a) where + mempty = Priority mempty mempty + +data Format = Format { + -- | If true, group imports by their first component. + _groupImports :: Bool + -- | Insert space for unqualified imports to make the modules line up. + , _leaveSpaceForQualified :: Bool + -- | Number of columns to wrap to. + , _columns :: Int + -- | How many spaces to indent a wrapped line. + , _wrapIndent :: Int + } deriving (Eq, Show) + +-- | A simple pattern: @M.@ matches M and M.*. Anything else matches exactly. +type ModulePattern = String + +matchModule :: ModulePattern -> Types.ModuleName -> Bool +matchModule pattern (Types.ModuleName mod) = case Util.unsnoc pattern of + Nothing -> False + Just (parent, '.') -> parent == mod || pattern `List.isPrefixOf` mod + _ -> pattern == mod + +empty :: Config +empty = Config + { _includes = [] + , _language = [] + , _order = Order + { _importOrder = Priority { high = [], low = [] } + , _sortUnqualifiedLast = False + } + , _modulePriority = mempty + , _unqualified = mempty + , _qualifyAs = mempty + , _format = defaultFormat + , _debug = False + } + +defaultFormat :: Format +defaultFormat = Format + { _groupImports = True + , _leaveSpaceForQualified = False + , _columns = 80 + , _wrapIndent = 4 + } + +-- | Parse .fix-imports file. +parse :: Text -> (Config, [Text]) +parse text = (config, errors) + where + commas = Text.intercalate ", " + errors = map (".fix-imports: "<>) $ concat + [ [ "duplicate fields: " <> commas duplicates | not (null duplicates) ] + , [ "unrecognized fields: " <> commas unknownFields + | not (null unknownFields) + ] + , [ "unknown language extensions: " <> commas unknownLanguage + | not (null unknownLanguage) + ] + , [ "unqualified: " <> commas unknownUnqualified + | not (null unknownUnqualified) + ] + , [ "qualify-as: " <> commas unknownQualifyAs + | not (null unknownQualifyAs) + ] + , maybe [] ((:[]) . ("format: "<>)) formatError + ] + config = empty + { _includes = getStrings "include" + , _language = language + , _order = Order + { _importOrder = Priority + { high = getStrings "import-order-first" + , low = getStrings "import-order-last" + } + , _sortUnqualifiedLast = getBool "sort-unqualified-last" + } + , _modulePriority = Priorities + { prioPackage = Priority + { high = getStrings "prio-package-high" + , low = getStrings "prio-package-low" + } + , prioModule = Priority + { high = getModules "prio-module-high" + , low = getModules "prio-module-low" + } + } + , _unqualified = Map.fromList $ map Tuple.swap unqualified + , _format = format + , _qualifyAs = qualifyAs + } + (unknownUnqualified, unqualified) = Either.partitionEithers $ + parseUnqualified (Text.unwords (get "unqualified")) + (unknownLanguage, language) = parseLanguage (get "language") + (unknownQualifyAs, qualifyAs) = + parseQualifyAs $ Text.unwords $ get "qualify-as" + (format, formatError) = case parseFormat (get "format") of + Right format -> (format, Nothing) + Left err -> (defaultFormat, Just err) + unknownFields = Map.keys fields List.\\ valid + valid = + [ "format" + , "import-order-first", "import-order-last" + , "include" + , "language" + , "prio-module-high", "prio-module-low" + , "prio-package-high", "prio-package-low" + , "qualify-as" + , "sort-unqualified-last" + , "unqualified" + ] + fields = fmap (concatMap Text.words) $ Map.fromList sections + sections = Index.parseSections text + duplicates = map head $ filter ((>1) . length) $ List.group $ List.sort $ + map fst sections + + getModules = map (Types.ModuleName . Text.unpack) . get + get k = Map.findWithDefault [] k fields + getStrings = map Text.unpack . get + getBool k = k `Map.member` fields + +parseFormat :: [Text] -> Either Text Format +parseFormat = foldM set defaultFormat + where + set fmt "leave-space-for-qualified" = Right $ + fmt { _leaveSpaceForQualified = True } + set fmt "no-group" = Right $ fmt { _groupImports = False } + set fmt w | Just cols <- Text.stripPrefix "columns=" w = + case Read.readMaybe (Text.unpack cols) of + Nothing -> Left $ "non-numeric: " <> w + Just cols -> Right $ fmt { _columns = cols } + set _ w = Left $ "unrecognized word: " <> showt w + +-- | +-- "A.B(c); Q(r)" -> [Right ("A.B", "c"), Right ("Q", "r")] +parseUnqualified :: Text -> [Either Text (Types.ModuleName, Types.Name)] +parseUnqualified = concatMap (parse . Text.break (=='(')) . Text.splitOn ";" + where + parse (pre, post) + | Text.null pre && Text.null post = [] + | Text.null pre = [Left $ "no module name before " <> showt post] + | Text.null post = [Left $ "no import after " <> showt pre] + | Just imports <- hasParens post = + map (parseUnqualifiedImport (Text.strip pre)) + (map Text.strip (Text.splitOn "," imports)) + | otherwise = [Left $ "expected parens: " <> showt post] + +-- | +-- "A.B" "(c)" -> (Types.Name "c", "A.B") +-- "A.B" "((+))" -> (Types.Operator "+", "A.B") +parseUnqualifiedImport :: Text -> Text + -> Either Text (Types.ModuleName, Types.Name) +parseUnqualifiedImport pre post = do + unless (Text.all isModuleChar pre) $ + Left $ "this doesn't look like a module name: " <> showt pre + let module_ = Types.ModuleName (Text.unpack pre) + case hasParens post of + Just op + | Text.all Util.haskellOpChar op -> + Right (module_, Types.Operator (Text.unpack op)) + | otherwise -> Left $ "non-symbols in operator: " <> showt post + Nothing + | Text.all (not . Util.haskellOpChar) post -> + Right (module_, Types.Name (Text.unpack post)) + | otherwise -> + Left $ "symbol char in id, use parens: " <> showt post + where + isModuleChar c = Char.isLetter c || Char.isDigit c || c == '.' + +-- | +-- "A.B as AB; C as E" -> [("AB", "A.B"), ("E", "C")] +parseQualifyAs :: Text + -> ([Text], Map.Map Types.Qualification Types.Qualification) +parseQualifyAs field + | Text.null field = ([], mempty) + | otherwise = second Map.fromList . Either.partitionEithers + . map (parse . Text.words) . Text.splitOn ";" $ field + where + parse [module_, "as", alias] = Right + ( Types.Qualification (Text.unpack alias) + , Types.Qualification (Text.unpack module_) + ) + parse ws = Left $ "stanza should look like 'ModuleName as X':" + <> Text.unwords ws + +hasParens :: Text -> Maybe Text +hasParens s + | "(" `Text.isPrefixOf` s && ")" `Text.isSuffixOf` s = + Just $ Text.drop 1 $ Text.dropEnd 1 s + | otherwise = Nothing + +parseLanguage :: [Text] -> ([Text], [Types.Extension]) +parseLanguage = Either.partitionEithers . map parse + where parse w = maybe (Left w) Right $ Types.parseExtension $ Text.unpack w + +-- * pick candidates + +pickModule :: Priorities -> FilePath + -> [(Maybe Index.Package, Types.ModuleName)] + -> Maybe (Maybe Index.Package, Types.ModuleName) +pickModule prios modulePath candidates = + Util.minimumOn (uncurry (prioritize prios modulePath)) $ + -- Don't pick myself! + filter ((/= Types.pathToModule modulePath) . snd) candidates + +-- | The order of priority is: +-- +-- - high or low in 'prioModule' +-- - local modules that share prefix with the module path +-- - local modules to ones from packages +-- - package modules high or low in 'prioPackage' +-- - prefer with fewer dots, so System.IO over Data.Text.IO +-- - If all else is equal alphabetize so at least the order is predictable. +prioritize :: Priorities -> FilePath -> Maybe String -> Types.ModuleName -> _ +prioritize prios modulePath mbPackage mod = + ( modulePrio (prioModule prios) mod + , localPrio mbPackage + , packagePrio (prioPackage prios) mbPackage + , length $ filter (=='.') $ Types.moduleName mod + , Types.moduleName mod + ) + where + localPrio Nothing = Before $ localOrder modulePath mod + localPrio (Just _) = After + + packagePrio _ Nothing = Nothing + packagePrio (Priority {high, low}) (Just pkg) = + Just $ searchPrio high low pkg + modulePrio (Priority {high, low}) = + searchPrio (map Types.moduleName high) (map Types.moduleName low) + . Types.moduleName + +-- | This is like Maybe, except that a present value will always sort before an +-- absent one. +data Before a = Before a | After deriving (Eq, Show) +instance Ord a => Ord (Before a) where + compare After After = EQ + compare (Before _) After = LT + compare After (Before _) = GT + compare (Before a) (Before b) = compare a b + +-- | Lower numbers for modules that share more prefix with the module's path. +-- A/B/Z.hs vs A.B.C -> -2 +-- A/Z.hs vs B -> 0 +localOrder :: FilePath -> Types.ModuleName -> Int +localOrder modulePath mod = negate $ length $ takeWhile id $ zipWith (==) + (Util.split "/" (Types.moduleToPath mod)) + (Util.split "/" (FilePath.takeDirectory modulePath)) + +searchPrio :: [String] -> [String] -> String -> Int +searchPrio high low mod = case List.findIndex (== mod) high of + Just n -> - length high + n + Nothing -> maybe 0 (+1) (List.findIndex (== mod) low) + + +-- * log + +debug :: Config -> Text -> IO () +debug config msg + | _debug config = Text.IO.hPutStrLn IO.stderr msg + | otherwise = return () + +showt :: Show a => a -> Text +showt = Text.pack . show diff --git a/src/FixImports/Config_test.hs b/src/FixImports/Config_test.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Config_test.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module FixImports.Config_test where +import qualified Data.Map as Map +import qualified Data.Text as Text + +import qualified FixImports.Config as Config +import qualified FixImports.FixImports as FixImports +import qualified FixImports.Types as Types + +import EL.Test.Global + + +test_parse = do + let f = check . Config.parse . Text.unlines + check (config, errs) + | null errs = Right config + | otherwise = Left $ Text.unlines errs + equal (f []) $ Right Config.empty + leftLike (f ["include: a", "include: b"]) "duplicate fields" + equal (Config._order <$> + f ["import-order-first: A", "import-order-last: B"]) $ + Right $ Config.Order + { _importOrder = Config.Priority ["A"] ["B"] + , _sortUnqualifiedLast = False + } + rightEqual + (Config._leaveSpaceForQualified . Config._format <$> + f ["format:", " leave-space-for-qualified"]) + True + +test_parseUnqualified = do + let f = Config._unqualified . parseConfig + equal (f ["unqualified: A.B (c); D.E ((+))"]) $ Map.fromList + [ (Types.Name "c", "A.B") + , (Types.Operator "+", "D.E") + ] + equal (f ["unqualified: A.B(c, d)"]) $ Map.fromList + [ (Types.Name "c", "A.B") + , (Types.Name "d", "A.B") + ] + equal (f ["unqualified: A.B (c,(+))"]) $ Map.fromList + [ (Types.Name "c", "A.B") + , (Types.Operator "+", "A.B") + ] + +test_parseQualifyAs = do + let f = Config._qualifyAs . parseConfig + equal (f ["qualify-as: A.B as AB; E as F"]) $ Map.fromList + [ ("AB", "A.B") + , ("F", "E") + ] + stringsLike (snd $ Config.parse "qualify-as: gibble gabble") + ["stanza should look like"] + +test_pickModule = do + let f config modulePath candidates = Config.pickModule + (Config._modulePriority (parseConfig config)) + modulePath candidates + equal (f [] "X.hs" []) Nothing + let localAB = [(Nothing, "A.M"), (Nothing, "B.M")] + equal (f [] "X.hs" localAB) $ + Just (Nothing, "A.M") + equal (f ["prio-module-high: B.M"] "X.hs" localAB) $ + Just (Nothing, "B.M") + -- Has to be an exact match. + equal (f ["prio-module-high: B"] "X.hs" localAB) $ + Just (Nothing, "A.M") + + -- Local modules take precedence. + equal (f [] "A/B.hs" [(Nothing, "B.M"), (Just "pkg", "B.M")]) $ + Just (Nothing, "B.M") + equal (f [] "A/B/C.hs" [(Nothing, "A.B.M"), (Just "pkg", "B.M")]) $ + Just (Nothing, "A.B.M") + -- Closer local modules precede further ones. + equal (f [] "A/B/C.hs" [(Nothing, "A.B.M"), (Nothing, "A.M")]) $ + Just (Nothing, "A.B.M") + -- Prefer fewer dots. + equal (f [] "X.hs" [(Just "p1", "A.B.M"), (Just "p2", "Z.M")]) $ + Just (Just "p2", "Z.M") + +parseConfig :: [Text.Text] -> Config.Config +parseConfig lines + | null errs = config + | otherwise = error $ "parsing " <> show lines <> ": " + <> Text.unpack (Text.unlines errs) + where (config, errs) = Config.parse (Text.unlines lines) diff --git a/src/FixImports/FixImports.hs b/src/FixImports/FixImports.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/FixImports.hs @@ -0,0 +1,590 @@ +{- | Automatically fix the import list in a haskell module. + + The process is as follows: + + - Parse the entire file and extract the Qualification of qualified names + like @A.b@, which is simple @A@. + + - Combine this with the modules imported to decide which imports can be + removed and which ones must be added. + + - For added imports, guess the complete import path implied by the + Qualification. This requires some heuristics: + + - Check local modules first. Start in the current module's directory + and then try from the current directory, descending recursively. + + - If no local modules are found, check the package database. There is + a system of package priorities so that @List@ will yield @Data.List@ + from @base@ rather than @List@ from @haskell98@. After that, shorter + matches are prioritized so @System.Process@ is chosen over + @System.Posix.Process@. + + - If the module is not found at all, an error is printed on stderr and + the unchanged file on stdout. + + - Of course the heuristics may get the wrong module, but existing + imports are left alone so you can edit them by hand. + + - Then imports are sorted, grouped, and a new module is written to stdout + with the new import block replacing the old one. + + - The default import formatting separates package imports from local + imports, and groups them by their toplevel module name (before the + first dot). Small groups are combined. They go in alphabetical order + by default, but a per-project order may be defined. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +module FixImports.FixImports where +import Prelude hiding (mod) +import qualified Control.Monad.State.Strict as State +import qualified Control.DeepSeq as DeepSeq +import Control.Monad.Trans (lift) +import Data.Bifunctor (first, second) +import qualified Data.Char as Char +import qualified Data.Either as Either +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import Data.Text (Text) +import qualified Data.Time.Clock as Clock +import qualified Data.Tuple as Tuple +import qualified Numeric +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import System.FilePath (()) + +import qualified Language.Preprocessor.Cpphs as Cpphs + +import qualified FixImports.Config as Config +import qualified FixImports.Format as Format +import qualified FixImports.Index as Index +import qualified FixImports.Parse as Parse +import qualified FixImports.Types as Types +import qualified FixImports.Util as Util + +import Control.Monad + + +-- | Look only this deep in the directory hierarchy for local modules. +searchDepth :: Int +searchDepth = 12 + +data Result = Result { + resultRange :: (Row, Row) + , resultImports :: String + , resultAdded :: Set Types.ModuleName + , resultRemoved :: Set Types.ModuleName + , resultMetrics :: [Metric] + } deriving (Show) + +-- | Line number in the input file. +type Row = Int + +type Metric = (Clock.UTCTime, Text) + +addMetrics :: [Metric] -> Result -> Result +addMetrics ms result = result { resultMetrics = ms ++ resultMetrics result } + +fixModule :: Config.Config -> FilePath -> String + -> IO (Either String Result, [Text]) +fixModule config modulePath source = do + mStart <- metric () "start" + processedSource <- cppModule modulePath source + mCpp <- metric () "cpp" + result <- parse (Config._language config) modulePath processedSource + case result of + Left err -> return (Left err, []) + Right (mod, cmts) -> do + mParse <- metric (mod `seq` (), cmts) "parse" + (index, indexFrom) <- Index.load + when (Config._debug config) $ Text.IO.putStr $ + "index from " <> indexFrom <> ":\n" <> Index.showIndex index + mLoad <- metric () "load-index" + let extracted = extract config mod cmts + mExtract <- metric extracted "extract" + case checkForCpp (_importRange extracted) source of + [] -> fmap (fmap List.reverse) $ flip State.runStateT [] $ + fmap (addMetrics [mStart, mCpp, mParse, mLoad, mExtract]) <$> + fixImports ioFilesystem config index modulePath extracted + cpps -> return + ( Left $ "can't handle CPP directives in import block:\n" + <> unlines cpps + , [] + ) + +parse :: [Types.Extension] -> FilePath -> String + -> IO (Either String (Parse.Module, [Parse.Comment])) +parse extensions modulePath = Parse.parse extensions modulePath + +-- | The parse function takes a CPP extension, but doesn't actually pay any +-- attention to it, so I have to run CPP myself. The imports are fixed +-- post-CPP so if you put CPP in the imports block it will be stripped out. +-- It seems hard to fix imports inside CPP. +cppModule :: FilePath -> String -> IO String +cppModule filename = Cpphs.runCpphs options filename + where + options = Cpphs.defaultCpphsOptions { Cpphs.boolopts = boolOpts } + boolOpts = Cpphs.defaultBoolOptions + { Cpphs.macros = True + , Cpphs.locations = False + , Cpphs.hashline = False + , Cpphs.pragma = False + , Cpphs.stripEol = True + , Cpphs.stripC89 = True + , Cpphs.lang = True -- lex input as haskell code + , Cpphs.ansi = True + , Cpphs.layout = True + , Cpphs.literate = False -- untested with literate code + , Cpphs.warnings = False + } + +-- | I have to get the CPP out before parsing and fixing imports, but then it's +-- hard to put it back in again. Especially the main reason for CPP is +-- conditional imports, which means I might not even know what to do with them. +-- I suppose I could try to detect them and preserve them, but for now it's +-- simpler to just abort on any CPP. At least it's better than silently +-- deleting it. +checkForCpp :: (Row, Row) -> String -> [String] +checkForCpp (start, end) = + map (\(i, line) -> show i <> ":" <> line) + . filter (any (`Set.member` cppThings) . words . snd) + . take (end-start) . drop start . zip [1 :: Int ..] . lines + where + cppThings = Set.fromList $ map ("#"<>) + [ "define", "undef", "include", "if", "ifdef", "ifndef", "else" + , "elif", "endif", "line", "error", "pragma" + ] + +-- | Capture all the IO operations needed by fixImports, so I can test without +-- IO. I could have used Free, but the operations are few, so it seemed +-- simpler to factor them out. +data Filesystem m = Filesystem { + _listDir :: FilePath -> m ([FilePath], [FilePath]) -- ^ (dirs, files) + , _doesFileExist :: FilePath -> m Bool + , _metric :: forall a. DeepSeq.NFData a => a -> Text -> m Metric + } + +ioFilesystem :: Filesystem IO +ioFilesystem = Filesystem + { _listDir = \ dir -> do + fns <- Maybe.fromMaybe [] <$> Util.catchENOENT (Util.listDir dir) + Util.partitionM isDir fns + , _doesFileExist = Directory.doesFileExist + , _metric = metric + } + where + -- Symlinks are not directories, so I don't walk into them. + isDir fn = (&&) <$> Directory.doesDirectoryExist fn + <*> (not <$> Directory.pathIsSymbolicLink fn) + +type LogT m a = State.StateT [Text] m a + +debug :: Monad m => Config.Config -> Text -> LogT m () +debug config msg = when (Config._debug config) $ State.modify' (msg:) + -- The check is unnecessary since I check debug before printing them, but + -- it'll save a thunk at least. + +-- | Take a parsed module along with its unparsed text. Generate a new import +-- block with proper spacing, formatting, and comments. Then snip out the +-- import block on the import file, and replace it. +fixImports :: Monad m => Filesystem m -> Config.Config -> Index.Index + -> FilePath -> Extracted -> LogT m (Either String Result) +fixImports fs config index modulePath extracted = do + mbNew <- mapM (findNewImport fs config modulePath index) + (Set.toList (_missingImports extracted)) + mNewImports <- lift $ _metric fs mbNew "find-new-imports" + (imports, newUnqualImports, unusedUnqual) <- return $ + fixUnqualified (_modToUnqualifieds extracted) config + (_unchangedImports extracted) + newUnqualImports <- lift $ mapM (locateImport fs) newUnqualImports + mUnqual <- lift $ _metric fs newUnqualImports "unqualified-imports" + mbExisting <- mapM (findImport fs index (Config._includes config)) imports + mExistingImports <- lift $ _metric fs mbExisting "find-existing-imports" + let existing = map (Types._importName . fst) imports + let (notFound, importLines) = Either.partitionEithers $ + zipWith mkError + (map qualToMod (Set.toList (_missingImports extracted)) + ++ existing) + (mbNew ++ mbExisting) + mkError _ (Just imp) = Right imp + mkError mod Nothing = Left mod + let formattedImports = + Format.formatGroups (Config._format config) (Config._order config) + (importLines ++ newUnqualImports) + return $ case notFound of + _ : _ -> Left $ "not found: " + ++ Util.join ", " (map Types.moduleName notFound) + [] -> Right $ Result + { resultRange = _importRange extracted + , resultImports = formattedImports + , resultAdded = Set.fromList $ + map (Types._importName . Types.importDecl) $ + Maybe.catMaybes mbNew ++ newUnqualImports + , resultRemoved = + _unusedImports extracted <> Set.fromList unusedUnqual + , resultMetrics = [mNewImports, mExistingImports, mUnqual] + } + where + qualToMod (Types.Qualification name) = Types.ModuleName name + +type ImportComment = (Types.Import, [Types.Comment]) + +locateImport :: Monad m => Filesystem m -> ImportComment -> m Types.ImportLine +locateImport fs (decl, cmts) = do + isLocal <- _doesFileExist fs $ Types.moduleToPath $ Types._importName decl + return $ Types.ImportLine + { importDecl = decl + , importComments = cmts + , importSource = if isLocal then Types.Local else Types.Package + } + +-- | Add unqualified imports. +-- +-- - Get unqualifieds. +-- - If _unqualified non-empty, filter them to the ones in _unqualified. +-- - Add or modify import lines for them. +-- - Remove imports that don't appear in modToUnqualifieds. +fixUnqualified :: Map Types.ModuleName (Set Types.Name) + -> Config.Config -> [ImportComment] + -> ([ImportComment], [ImportComment], [Types.ModuleName]) + -- ^ (modified, new, removed) +fixUnqualified modToUnqualifieds config imports = + removeEmptyImports moduleToNames $ + first (map (first stripReferences)) $ + foldr addReferences (imports, []) $ + filter (not . Set.null . snd) $ + map (second (Set.filter (not . alreadyImported))) $ + Map.toList modToUnqualifieds + where + -- Ignore unqualified references that are already imported, perhaps from + -- some other module. + alreadyImported :: Types.Name -> Bool + alreadyImported name = any ((name `elem`) . importedEntities . fst) imports + + -- Successively modify the ImportComment list for each new reference. Keep + -- existing modified imports separate from newly added ones, so they can be + -- reported as adds. + addReferences :: (Types.ModuleName, Set Types.Name) + -> ([ImportComment], [ImportComment]) + -> ([ImportComment], [ImportComment]) + addReferences (moduleName, names) (existing, new) = + case Util.modifyAt (matches moduleName . fst) add existing of + Nothing -> (existing, (newImport, []) : new) + Just modified -> (modified, new) + where + add = first $ Types.importModify (newEntities ++) + newImport = (Types.makeImport moduleName) + { Types._importEntities = Just $ map Right newEntities } + newEntities = map mkEntity $ Set.toList names + matches name imp = Types.importUnqualified imp + && Types._importName imp == name + + -- Remove managed unqualified imports that are no longer referenced. + stripReferences :: Types.Import -> Types.Import + stripReferences imp = Types.importModify (filter keep) imp + where + moduleName = Types._importName imp + -- Keep if it's not managed, or it is managed and referenced. + keep (Types.Entity Nothing var Nothing) = + not (isManaged moduleName var) + || maybe False (var `Set.member`) + (Map.lookup moduleName modToUnqualifieds) + keep _ = True + isManaged moduleName name = maybe False (name `elem`) $ + Map.lookup moduleName moduleToNames + moduleToNames :: Map Types.ModuleName [Types.Name] + moduleToNames = Util.multimap . map Tuple.swap . Map.toList + . Config._unqualified $ config + mkEntity var = Types.Entity Nothing var Nothing + +importedEntities :: Types.Import -> [Types.Name] +importedEntities = map Types._entityVar . Either.rights . Maybe.fromMaybe [] + . Types._importEntities + +-- | Remove unqualified imports that have been made empty. +removeEmptyImports :: Map Types.ModuleName names -> ([ImportComment], new) + -> ([ImportComment], new, [Types.ModuleName]) +removeEmptyImports moduleToNames (modified, new) = + (kept, new, map (Types._importName . fst) removed) + where + (kept, removed) = List.partition (not . emptyImport . fst) modified + emptyImport imp = Map.member (Types._importName imp) moduleToNames + -- Can delete if it has an import list, but it's empty. + && Types.importEmpty imp + + +-- | Make a map from each module with unqualified imports to its unqualified +-- imports that occur in the module. +makeModToUnqualifieds :: Config.Config -> Parse.Module + -> Map Types.ModuleName (Set Types.Name) +makeModToUnqualifieds config mod + | unqual == mempty = mempty + | otherwise = Util.setmap $ + Maybe.mapMaybe (\name -> (, name) <$> Map.lookup name unqual) $ + Set.toList $ Parse.unqualifieds mod + where unqual = Config._unqualified config + +-- | Clip out the range from the given text and replace it with the given +-- lines. +substituteImports :: String -> (Int, Int) -> String -> String +substituteImports imports (start, end) source = + unlines pre ++ imports ++ unlines post + where + (pre, within) = splitAt start (lines source) + (_, post) = splitAt (end-start) within + +-- * find new imports + +-- | Make a new ImportLine from a ModuleName. +findNewImport :: Monad m => Filesystem m -> Config.Config -> FilePath + -> Index.Index -> Types.Qualification + -> LogT m (Maybe Types.ImportLine) + -- ^ Nothing if the module wasn't found +findNewImport fs config modulePath index qual = + fmap make <$> findModule fs config index modulePath qual + where + make (mod, source) = Types.ImportLine + { importDecl = Types.setQualification qual (Types.makeImport mod) + , importComments = [] + , importSource = source + } + +-- | Find the qualification and its ModuleName and whether it was a Types.Local +-- or Types.Package module. Nothing if it wasn't found at all. +findModule :: Monad m => Filesystem m -> Config.Config -> Index.Index + -> FilePath -- ^ Path to the module being fixed. + -> Types.Qualification -> LogT m (Maybe (Types.ModuleName, Types.Source)) +findModule fs config index modulePath qual = do + local <- map fnameToModule <$> ((++) + <$> findLocalModules fs (Config._includes config) qual + <*> maybe (pure []) (findLocalModules fs (Config._includes config)) + qualifyAs) + let package = map (first Just) $ + findPackageModules qual ++ maybe [] findPackageModules qualifyAs + debug config $ "findModule " <> showt qual <> " from " + <> showt modulePath <> ": local " <> showt local + <> "\npackage: " <> showt package + let prio = Config._modulePriority config + return $ case Config.pickModule prio modulePath (local++package) of + Just (package, mod) -> Just + (mod, if package == Nothing then Types.Local else Types.Package) + Nothing -> Nothing + where + findPackageModules q = Map.findWithDefault [] q index + fnameToModule fn = (Nothing, Types.pathToModule fn) + qualifyAs = Map.lookup qual (Config._qualifyAs config) + +-- If it's in Config._qualifyAs, then I also search for exactly that module +-- name. + +-- | Given A.B, look for A/B.hs, */A/B.hs, */*/A/B.hs, etc. in each of the +-- include paths. +findLocalModules :: Monad m => Filesystem m -> [FilePath] + -> Types.Qualification -> LogT m [FilePath] +findLocalModules fs includes (Types.Qualification name) = + fmap concat . forM includes $ \dir -> map (stripDir dir) <$> + findFiles fs searchDepth (Types.moduleToPath (Types.ModuleName name)) + dir + +stripDir :: FilePath -> FilePath -> FilePath +stripDir dir path + | dir == "." = path + | otherwise = dropWhile (=='/') $ drop (length dir) path + +findFiles :: Monad m => Filesystem m + -> Int -- ^ Descend into subdirectories this many times. + -> FilePath -- ^ Find files with this suffix. Can contain slashes. + -> FilePath -- ^ Start from this directory. Return [] if it doesn't exist. + -> LogT m [FilePath] +findFiles fs depth file dir = do + (subdirs, fns) <- lift $ _listDir fs dir + subfns <- if depth > 0 + then concat <$> mapM (findFiles fs (depth-1) file) + (filter isModuleDir subdirs) + else return [] + return $ filter sameSuffix fns ++ subfns + where + isModuleDir = all Char.isUpper . take 1 . FilePath.takeFileName + sameSuffix fn = fn == file || ('/' : file) `List.isSuffixOf` fn + + +-- * figure out existing imports + +-- | Make an existing import into an ImportLine by finding out if it's a local +-- module or a package module. +findImport :: Monad m => Filesystem m -> Index.Index -> [FilePath] + -> ImportComment -> LogT m (Maybe Types.ImportLine) +findImport fs index includes (imp, cmts) = do + found <- findModuleName fs index includes (Types._importName imp) + return $ case found of + Nothing -> Nothing + Just source -> Just $ Types.ImportLine + { importDecl = imp + , importComments = cmts + , importSource = source + } + +-- | True if it was found in a local directory, False if it was found in the +-- ghc package db, and Nothing if it wasn't found at all. +findModuleName :: Monad m => Filesystem m -> Index.Index -> [FilePath] + -> Types.ModuleName -> LogT m (Maybe Types.Source) +findModuleName fs index includes mod = do + isLocal <- lift $ isLocalModule fs mod ("" : includes) + return $ + if isLocal then Just Types.Local + else if isPackageModule index mod then Just Types.Package + else Nothing + +isLocalModule :: Monad m => Filesystem m -> Types.ModuleName -> [FilePath] + -> m Bool +isLocalModule fs mod = + Util.anyM (_doesFileExist fs . ( Types.moduleToPath mod)) + +isPackageModule :: Index.Index -> Types.ModuleName -> Bool +isPackageModule index (Types.ModuleName name) = + Map.member (Types.Qualification name) index + +-- * util + +-- | All the relevant info extracted from a module. +data Extracted = Extracted { + -- | References exist, but no corresponding imports. + _missingImports :: Set Types.Qualification + -- | Imports exist but no reference. + , _unusedImports :: Set Types.ModuleName + , _unchangedImports :: [ImportComment] + , _importRange :: (Int, Int) + , _modToUnqualifieds :: Map Types.ModuleName (Set Types.Name) + } + +instance DeepSeq.NFData Extracted where + rnf (Extracted a b c d e) = DeepSeq.rnf (a, b, c, d, e) + +extract :: Config.Config -> Parse.Module -> [Parse.Comment] -> Extracted +extract config mod cmts = Extracted + { _missingImports = missing + , _unusedImports = unused + , _unchangedImports = importCmts + , _importRange = range + , _modToUnqualifieds = makeModToUnqualifieds config mod + } + where + unused = Set.difference (Set.fromList modules) + (Set.fromList (map (Types._importName . fst) importCmts)) + missing = Set.difference used imported + -- If the Prelude isn't explicitly imported, it's implicitly imported, so + -- if I see Prelude.x it doesn't mean to add an import. + imported = Set.fromList $ prelude : qualifiedImports + importCmts = + [ impCmt + | impCmt <- associateComments imports $ + dropWhile before $ List.sort cmts + , keepImport (fst impCmt) + ] + before = (< fst range) . Types._startLine . Parse._span + range = Parse.importRange mod + -- Keep unqualified imports, but only keep qualified ones if they are used. + -- Prelude is considered always used if it appears, because removing it + -- changes import behavour. + keepImport imp = + Set.member (Types.importQualification imp) (Set.insert prelude used) + || not (Types._importQualified imp) + prelude = Types.Qualification "Prelude" + + -- Get from the qualified import name back to the actual module name so + -- I can return that. + modules = map Types._importName imports + used = Parse.qualifications mod + qualifiedImports = map Types.importQualification imports + imports = normalizeImports $ Parse.extractImports mod + +-- | Clean up redundant imports. +normalizeImports :: [Types.Import] -> [Types.Import] +normalizeImports imports = + Util.uniqueOn key qual + ++ map merge (Util.groupOn key (Util.sortOn key unqual)) + where + (qual, unqual) = List.partition Types._importQualified imports + key imp = imp + { Types._importEntities = Nothing + , Types._importSpan = Types.noSpan + } + merge group@(imp:_) = imp + { Types._importEntities = mconcat (map Types._importEntities group) } + merge [] = error "groupOn postcondition" + +-- | Pair Imports up with the comments that apply to them. Comments +-- below the last import are dropped, but there shouldn't be any of those +-- because they should have been omitted from the comment block. +-- +-- Spaces between comments above an import will be lost, and multiple comments +-- to the right of an import (e.g. commenting a complicated import list) will +-- probably be messed up. TODO Fix it if it becomes a problem. +associateComments :: [Types.Import] -> [Parse.Comment] -> [ImportComment] +associateComments imports cmts = snd $ List.mapAccumL associate cmts imports + where + associate cmts imp = (after, (imp, associated)) + where + associated = map (Types.Comment Types.CmtAbove . Parse._comment) above + ++ map (Types.Comment Types.CmtRight . Parse._comment) right + -- cmts that end before the import beginning are above it + (above, rest) = List.span ((< start impSpan) . end . Parse._span) cmts + -- remaining cmts that start before or at the import's end are right + -- of it + (right, after) = List.span ((<= end impSpan) . start . Parse._span) rest + impSpan = Types._importSpan imp + start = Types._startLine + end = Types._endLine + +-- * metrics + +metric :: DeepSeq.NFData a => a -> Text -> IO Metric +metric val name = do + force val + flip (,) name <$> Clock.getCurrentTime + +showMetrics :: [Metric] -> Text +showMetrics = Text.unlines . format . map diff . Util.zipPrev . Util.sortOn fst + where + format metricDurs = + map (format1 total) (metricDurs ++ [("total", total)]) + where total = sum (map snd metricDurs) + format1 total (metric, dur) = Text.unwords + [ justifyR 8 (showDuration dur) + , justifyR 3 (percent (realToFrac dur / realToFrac total)) + , "-", metric + ] + diff ((prev, _), (cur, metric)) = + (metric, cur `Clock.diffUTCTime` prev) + +force :: DeepSeq.NFData a => a -> IO () +force x = DeepSeq.rnf x `seq` return () + +percent :: Double -> Text +percent = (<>"%") . showt . isInt . round . (*100) + where + isInt :: Int -> Int + isInt = id + +showDuration :: Clock.NominalDiffTime -> Text +showDuration = + Text.pack . ($ "s") . Numeric.showFFloat (Just 2) . isDouble . realToFrac + where + isDouble :: Double -> Double + isDouble = id + +justifyR :: Int -> Text -> Text +justifyR width = Text.justifyRight width ' ' + +showt :: Show a => a -> Text +showt = Text.pack . show diff --git a/src/FixImports/FixImports_test.hs b/src/FixImports/FixImports_test.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/FixImports_test.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module FixImports.FixImports_test where +import Control.Monad (unless, void) +import qualified Control.Monad.Identity as Identity +import qualified Control.Monad.State.Strict as State +import Data.Bifunctor (bimap) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Time.Clock.POSIX as Clock.POSIX +import qualified System.IO.Unsafe as Unsafe + +import qualified System.FilePath as FilePath + +import qualified FixImports.Config as Config +import qualified FixImports.FixImports as FixImports +import qualified FixImports.Index as Index +import qualified FixImports.Types as Types + +import EL.Test.Global + + +test_simple = do + let run = fmap FixImports.resultImports + . fixModule index ["C.hs"] (mkConfig "") "A.hs" + index = Index.makeIndex + [ ("pkg", ["A.B"]) + , ("zpkg", ["Z"]) + ] + rightEqual (run "x = B.c") "import qualified A.B as B\n" + rightEqual (run "x = A.B.c") "import qualified A.B\n" + leftLike (run "x = Q.c") "not found: Q" + -- Remove unused. + rightEqual (run "import qualified A.B as B\n\nx = y") "" + -- Unless it's unqualified. + rightEqual (run "import A.B as B\n\nx = y") + "import A.B as B\n" + + -- Local goes below package. + rightEqual (run "x = (B.a, C.a, Z.a)") + "import qualified A.B as B\n\ + \import qualified Z\n\ + \\n\ + \import qualified C\n" + + -- Don't mess with imports I don't manage. + rightEqual (run "import A.B hiding (mod)\n") "import A.B hiding (mod)\n" + rightEqual (run "import A.B\n") "import A.B\n" + -- remove redundant imports + rightEqual (run "import qualified Z\nimport qualified Z\nf = Z.a") + "import qualified Z\n" + +test_comments = do + let run = fmap FixImports.resultImports + . fixModule index [] (mkConfig "") "A.hs" + index = Index.makeIndex [("pkg", ["A", "B"])] + rightEqual (run "import A") "import A\n" + -- Comments out of the edited range are not affected. + rightEqual + (run + "-- before\n\ + \module M where -- where\ + \-- above\n\ + \import A\n\ + \-- below") + "import A\n" + rightEqual + (run + "module M where\n\ + \import A\n\ + \-- above1\n\ + \-- above2\n\ + \import B {- right -}\n") + + "import A\n\ + \-- above1\n\ + \-- above2\n\ + \import B {- right -}\n" + +test_qualifyAs = do + let run config files = fmap eResult . fixModule index files config "A.hs" + config = mkConfig "qualify-as: Data.Text.Lazy as DTL" + index = Index.makeIndex [("text", ["Data.Text.Lazy"]), ("pkg", ["A"])] + rightEqual (run config [] "x = DTL.y") + ( ["Data.Text.Lazy"] + , [] + , "import qualified Data.Text.Lazy as DTL\n" + ) + rightEqual (run config [] "import qualified Data.Text.Lazy as DTL\n") + ( [] + , ["Data.Text.Lazy"] + , "" + ) + + -- qualifyAs aliases are prioritized in the same way as others, so + -- the local module wins: + rightEqual (run config ["DTL.hs"] "x = DTL.y") + (["DTL"], [], "import qualified DTL\n") + + -- Unless explicitly suppressed: + let config2 = mkConfig $ Text.unlines + [ "qualify-as: Data.Text.Lazy as DTL" + , "prio-module-high: Data.Text.Lazy" + ] + rightEqual (run config2 ["DTL.hs"] "x = DTL.y") + ( ["Data.Text.Lazy"] + , [] + , "import qualified Data.Text.Lazy as DTL\n" + ) + + -- strip duplicates + rightEqual (run config2 [] + "import qualified Data.Text.Lazy as DTL\n\ + \import qualified Data.Text.Lazy as DTL\n\ + \x = DTL.y") + ([], [], "import qualified Data.Text.Lazy as DTL\n") + -- not confused by other imports with the same name + rightEqual (run config2 [] + "import qualified A as DTL\n\ + \import qualified Data.Text.Lazy as DTL\n\ + \x = DTL.y") + ( [] + , [] + , "import qualified A as DTL\nimport qualified Data.Text.Lazy as DTL\n" + ) + +test_unqualified = do + let run config = fmap eResult + . fixModule index ["C.hs"] (mkConfig ("unqualified: " <> config)) + "A.hs" + index = Index.makeIndex + [ ("pkg", ["A.B"]) + , ("zpkg", ["Z"]) + ] + rightEqual (run "A.B (c)" "x = (c, c)") + ( ["A.B"] + , [] + , "import A.B (c)\n" + ) + -- Modify an existing import. + rightEqual (run "A.B (c)" "import A.B (a, z)\nx = (c, c)") + ( [] + , [] + , "import A.B (a, c, z)\n" + ) + -- Remove an unused one, if I'm managing it. + rightEqual (run "A.B (a, c)" "import A.B (a, c)\nx = a") + ( [] + , [] + , "import A.B (a)\n" + ) + -- Don't accumulate duplicates. + rightEqual (run "A.B (c)" "import A.B (c)\nx = c") + ([], [], "import A.B (c)\n") + rightEqual (run "A.B (C)" "import A.B (C)\nx :: C") + ([], [], "import A.B (C)\n") + -- Don't manage it if it's not mine. + rightEqual (run "A.B (c)" "import A.B (d)") + ([], [], "import A.B (d)\n") + -- local still goes below package + rightEqual (run "C (a)" "import A.B\nimport Z\nx = a") + ( ["C"] + , [] + , "import A.B\n\ + \import Z\n\ + \\n\ + \import C (a)\n" + ) + -- Don't import when it's on the lhs. + rightEqual (run "A.B (c)" "c = x") ([], [], "") + rightEqual (run "A.B (())" "x = a b") + (["A.B"], [], "import A.B (())\n") + -- Add and remove operators + rightEqual (run "A.B (())" "x = a b") + (["A.B"], [], "import A.B (())\n") + rightEqual (run "A.B (())" "import A.B (())\nx = a b") + ([], ["A.B"], "") + -- Removed unused. + rightEqual (run "A.B (c)" "import A.B (c)\nx = x\n") ([], ["A.B"], "") + rightEqual + (run "A.B (c)" + "import A.B (c)\nimport A.B (c, d)\nimport A.B (d)\nx = d\n") + ([], [], "import A.B (d)\n") + -- But not if it's a everything-import. + rightEqual (run "A.B (c)" "import A.B\nx = x\n") ([], [], "import A.B\n") + -- Ignore if it's already imported unqualified. + rightEqual (run "A.B (c)" "import Z (c)\nx = c") ([], [], "import Z (c)\n") + + +-- * implementation + +eResult :: FixImports.Result -> ([Types.ModuleName], [Types.ModuleName], String) +eResult r = + ( Set.toList (FixImports.resultAdded r) + , Set.toList (FixImports.resultRemoved r) + , FixImports.resultImports r + ) + +fixModule :: Index.Index -> [FilePath] + -> Config.Config -> FilePath -> String -> Either String FixImports.Result +fixModule index files config modulePath source = + case Unsafe.unsafePerformIO $ + FixImports.parse (Config._language config) modulePath source of + Left err -> Left err + Right (mod, cmts) -> + fst $ Identity.runIdentity $ flip State.runStateT [] $ + FixImports.fixImports (pureFilesystem files) config index + modulePath (FixImports.extract config mod cmts) + +-- | The ./ stuff is tricky, this is probably still wrong. +pureFilesystem :: [FilePath] -> FixImports.Filesystem Identity.Identity +pureFilesystem files = FixImports.Filesystem + { _listDir = \dir -> return + . Maybe.fromMaybe ([], []) . (`Map.lookup` tree) $ dir + , _doesFileExist = \fn -> return . (`elem` files) . normalize $ fn + , _metric = \_ _ -> + return (Clock.POSIX.posixSecondsToUTCTime 0, Text.pack "metric") + } + where + tree = filesToTree (map ("./"++) files) + normalize ('.':'/':fn) = fn + normalize fn = fn + +-- group by first element, then second, etc. +filesToTree :: [FilePath] -> Map.Map FilePath ([FilePath], [FilePath]) + -- ^ (dirs, files) +filesToTree = Map.fromList + . map (bimap (List.dropWhileEnd (=='/')) separate) . groupFst + . concatMap prefixes + where + separate [""] = ([], []) + separate subs = (unique $ map (takeWhile (/='/')) dirs, files) + where (dirs, files) = List.partition ('/' `elem`) subs + +prefixes :: FilePath -> [(FilePath, FilePath)] +prefixes = map (bimap concat concat) . drop 1 + . (\xs -> zip (List.inits xs) (List.tails xs)) . FilePath.splitPath + +mkConfig :: Text.Text -> Config.Config +mkConfig content + | null errs = config { Config._includes = ["."] } + | otherwise = error $ "parsing " <> show content <> ": " + <> unlines (map Text.unpack errs) + where (config, errs) = Config.parse content + +-- * util + +type NonNull a = [a] + +-- | Similar to 'keyedGroupSort', but key on the fst element, and strip the +-- key out of the groups. +groupFst :: Ord a => [(a, b)] -> [(a, NonNull b)] +groupFst xs = [(key, map snd group) | (key, group) <- keyedGroupSort fst xs] + +-- | Group the unsorted list into @(key x, xs)@ where all @xs@ compare equal +-- after @key@ is applied to them. +keyedGroupSort :: Ord key => (a -> key) -> [a] -> [(key, NonNull a)] + -- ^ Sorted by key. The NonNull group is in the same order as the input. +keyedGroupSort key = Map.toAscList . foldr go Map.empty + where go x = Map.alter (Just . maybe [x] (x:)) (key x) + +unique :: Ord a => [a] -> [a] +unique = Set.toList . Set.fromList diff --git a/src/FixImports/Format.hs b/src/FixImports/Format.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Format.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} +module FixImports.Format ( + formatGroups + , showImport +) where +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Text.PrettyPrint as PP +import Text.PrettyPrint ((<+>)) + +import qualified FixImports.Config as Config +import qualified FixImports.Types as Types +import qualified FixImports.Util as Util + + +-- | Format import list. Imports are alphabetized and grouped into sections +-- based on the top level module name (before the first dot). Sections that +-- are too small are grouped with the section below them. +-- +-- The local imports are sorted and grouped separately from the package +-- imports. Rather than being alphabetical, they are sorted in a per-project +-- order that should be general-to-specific. +-- +-- An unqualified import will follow a qualified one. The Prelude, if +-- imported, always goes first. +formatGroups :: Config.Format -> Config.Order -> [Types.ImportLine] -> String +formatGroups format order imports = + unlines $ joinGroups + [ showGroups (group (Util.sortOn packagePrio package)) + , showGroups (group (Util.sortOn localPrio local)) + , showGroups [Util.sortOn name unqualified] + ] + where + packagePrio import_ = + ( name import_ /= prelude + , name import_ + , qualifiedPrio import_ + ) + localPrio import_ = + ( localPriority (Config._importOrder order) (name import_) + , name import_ + , qualifiedPrio import_ + ) + qualifiedPrio = not . Types._importQualified . Types.importDecl + name = Types._importName . Types.importDecl + (unqualified, local, package) = Util.partition2 + ((Config._sortUnqualifiedLast order &&) . isUnqualified + . Types.importDecl) + ((==Types.Local) . Types.importSource) + imports + group + | Config._groupImports format = collapse . Util.groupOn topModule + | otherwise = (:[]) + topModule = takeWhile (/='.') . Types.moduleName . name + collapse [] = [] + collapse (x:xs) + | length x <= 2 = case collapse xs of + [] -> [x] + y : ys -> (x ++ y) : ys + | otherwise = x : collapse xs + showGroups = List.intercalate [""] . map (map (showImportLine format)) + joinGroups = List.intercalate [""] . filter (not . null) + prelude = Types.ModuleName "Prelude" + +isUnqualified :: Types.Import -> Bool +isUnqualified imp = not (Types._importQualified imp) + && Maybe.isNothing (Types._importEntities imp) + +-- | Modules whose top level element is in 'importFirst' go first, ones in +-- 'importLast' go last, and the rest go in the middle. +-- +-- Like 'searchPrio' but for order. +localPriority :: Config.Priority Config.ModulePattern -> Types.ModuleName + -> (Int, Maybe Int) +localPriority prio import_ = + case List.findIndex (`Config.matchModule` import_) firsts of + Just k -> (-1, Just k) + Nothing -> case List.findIndex (`Config.matchModule` import_) lasts of + Nothing -> (0, Nothing) + Just k -> (1, Just k) + where + firsts = Config.high prio + lasts = Config.low prio + +showImportLine :: Config.Format -> Types.ImportLine -> String +showImportLine format (Types.ImportLine imp cmts _) = concat + [ above + , showImport format imp + , (if null right then "" else ' ' : right) + ] + where + above = concat [cmt ++ "\n" | Types.Comment Types.CmtAbove cmt <- cmts] + right = Util.join "\n" [cmt | Types.Comment Types.CmtRight cmt <- cmts] + +showImport :: Config.Format -> Types.Import -> String +showImport format + (Types.Import name pkgQualifier source safe qualified as hiding + entities _span) = + PP.renderStyle style $ PP.hang + (PP.hsep + [ "import" + , if qualified || not (Config._leaveSpaceForQualified format) + || source || safe + then mempty + else PP.text (replicate (length ("qualified" :: String)) ' ') + , if source then "{-# SOURCE #-}" else mempty + , if safe then "safe" else mempty + , if qualified then "qualified" else mempty + , maybe mempty (\s -> PP.text (show s)) pkgQualifier + , PP.text $ Types.moduleName name + , maybe mempty + (\(Types.Qualification qual) -> "as" <+> PP.text qual) as + , if hiding then "hiding" else mempty + ]) + (Config._wrapIndent format) (maybe mempty prettyEntities entities) + where + style = PP.style + { PP.lineLength = Config._columns format + , PP.ribbonsPerLine = 1 + } + +prettyEntities :: [Either Types.Error Types.Entity] -> PP.Doc +prettyEntities = parenList . map pp + where + -- This means 'extractEntity' hit something it didn't think should be + -- possible. + pp (Left err) = "{{parse error: " <> PP.text err <> "}}" + pp (Right (Types.Entity qualifier var list)) = + (maybe mempty PP.text qualifier <+> PP.text (Types.showName var)) + <> maybe mempty PP.text list + +parenList :: [PP.Doc] -> PP.Doc +parenList = PP.parens . PP.fsep . PP.punctuate PP.comma diff --git a/src/FixImports/Format_test.hs b/src/FixImports/Format_test.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Format_test.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module FixImports.Format_test where +import qualified Data.Text as Text +import qualified System.IO.Unsafe as Unsafe + +import qualified FixImports.Config as Config +import qualified FixImports.Format as Format +import qualified FixImports.Parse as Parse +import qualified FixImports.Types as Types + +import qualified EL.Test.Testing as Testing +import EL.Test.Global + + +test_formatGroups = do + let f config imports = lines $ Format.formatGroups Config.defaultFormat + (Config._order (parseConfig config)) + (Testing.expectRight (parse (unlines imports))) + equal (f [] []) [] + -- Unqualified import-all goes last. + equal (f ["sort-unqualified-last: t"] + [ "import Z", "import A" + , "import qualified C", "import qualified B" + , "import C (a)" + ]) + [ "import qualified B" + , "import qualified C" + , "import C (a)" + , "" + , "import A" + , "import Z" + ] + + equal (f [] ["import qualified Z", "import qualified A"]) + [ "import qualified A" + , "import qualified Z" + ] + equal (f ["import-order-first: Z"] + ["import qualified Z", "import qualified A"]) + [ "import qualified Z" + , "import qualified A" + ] + equal (f ["import-order-last: A"] + ["import qualified Z", "import qualified A"]) + [ "import qualified Z" + , "import qualified A" + ] + + -- Exact match. + equal (f ["import-order-first: Z"] + ["import qualified Z.A", "import qualified A"]) + [ "import qualified A" + , "import qualified Z.A" + ] + -- Unless it's a prefix match. + equal (f ["import-order-first: Z."] + ["import qualified Z.A", "import qualified A"]) + [ "import qualified Z.A" + , "import qualified A" + ] + +test_showImport = do + let f = fmap (Format.showImport style . Types.importDecl . head) . parse + style = Config.defaultFormat { Config._leaveSpaceForQualified = True } + equal (f "import A.B as C (x)") $ Right "import A.B as C (x)" + +test_leaveSpaceForQualified = do + let f columns leaveSpace = + fmap (Format.showImport (fmt columns leaveSpace) . head + . map Types.importDecl) + . parse + fmt columns leaveSpace = Config.defaultFormat + { Config._columns = columns + , Config._leaveSpaceForQualified = leaveSpace + } + rightEqual (f 80 False "import Foo.Bar (a, b, c)") + "import Foo.Bar (a, b, c)" + rightEqual (f 80 True "import Foo.Bar (a, b, c)") + "import Foo.Bar (a, b, c)" + + rightEqual (f 20 False "import Foo.Bar (a, b, c)") + "import Foo.Bar\n\ + \ (a, b, c)" + rightEqual (f 30 True "import Foo.Bar (a, b, c)") + "import Foo.Bar\n\ + \ (a, b, c)" + + rightEqual (f 30 True "import Foo.Bar (tweetle, beetle, paddle, battle)") + "import Foo.Bar\n\ + \ (tweetle, beetle, paddle,\n\ + \ battle)" + + +-- * util + +parse :: String -> Either String [Types.ImportLine] +parse = Unsafe.unsafePerformIO + . fmap (fmap (map importLine . Parse.extractImports . fst)) + . Parse.parse [] "M.hs" + +importLine :: Types.Import -> Types.ImportLine +importLine imp = Types.ImportLine + { importDecl = imp + , importComments = [] + , importSource = Types.Local + } + +parseConfig :: [Text.Text] -> Config.Config +parseConfig lines + | null errs = config + | otherwise = error $ "parsing " <> show lines <> ": " + <> Text.unpack (Text.unlines errs) + where (config, errs) = Config.parse (Text.unlines lines) diff --git a/src/FixImports/Index.hs b/src/FixImports/Index.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Index.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +-- | Maintain the index from Qualification to the full module from the package +-- db that this Qualification probably intends. +module FixImports.Index ( + Index, Package, empty, load, showIndex, makeIndex, parseSections +) where +import Prelude hiding (mod) +import Control.Monad +import Data.Bifunctor (second) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import System.FilePath (()) +import qualified Data.Either as Either +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified GHC.Paths + +import qualified System.Directory as Directory +import qualified System.IO as IO + +import qualified FixImports.PkgCache as PkgCache +import qualified FixImports.Types as Types +import qualified FixImports.Util as Util + + +-- | Map from tails of the each module in the package db to its module name. +-- So @List@ and @Data.List@ will map to @Data.List@. Modules from a set +-- of core packages, like base and containers, will take priority, so even if +-- there's a package with @Some.Obscure.List@, @List@ will still map to +-- @Data.List@. +type Index = Map.Map Types.Qualification [(Package, Types.ModuleName)] + +-- | Package name without the version. +type Package = String + +empty :: Index +empty = Map.empty + +load :: IO (Index, Text) +load = 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 + [ Text.pack k <> ": " <> Text.pack (show v) + | (Types.Qualification k, v) <- Map.toAscList index + ] + +-- | I think the global package db is always under the libdir? +bootPkgDb :: FilePath +bootPkgDb = GHC.Paths.libdir "package.conf.d" + +fromGhcEnvironment :: IO (Maybe Index) +fromGhcEnvironment = parseGhcEnvironment >>= \case + Nothing -> return Nothing + Just (pkgDbs, unitIds) -> do + nameModules <- PkgCache.load (Set.fromList unitIds) + (bootPkgDb : pkgDbs) + return $ Just $ makeIndex $ + map (fmap (map Types.ModuleName)) nameModules + +-- | The code to write .ghc.environment is in Cabal +-- Distribution.Simple.GHC.Internal, the code to read it is copy pasted over +-- into cabal-install Distribution.Client.CmdInstall. So they're not even +-- thinking of being consistent with themselves, let alone anyone else. +-- Too much bother. +parseGhcEnvironment :: IO (Maybe ([FilePath], [PkgCache.UnitId])) +parseGhcEnvironment = do + envFiles <- filter (".ghc.environment." `List.isPrefixOf`) <$> + Directory.listDirectory "." + case envFiles of + [] -> return Nothing + [envFile] -> Just . parseEnvFile <$> Text.IO.readFile envFile + _ -> error $ "multiple ghc env files: " <> unwords envFiles + +parseEnvFile :: Text -> ([FilePath], [PkgCache.UnitId]) +parseEnvFile = Either.partitionEithers . mapMaybe parse . Text.lines + where + parse line = case Text.words line of + ["package-db", path] -> Just $ Left $ Text.unpack path + ["package-id", unit] -> Just $ Right unit + _ -> Nothing + -- clear-package-db + -- global-package-db + -- package-db /Users/elaforge/.cabal/store/ghc-9.2.5/package.db + -- package-db dist-newstyle/packagedb/ghc-9.2.5 + -- package-id hlibgit2-0.18.0.16-inplace + -- package-id base-4.16.4.0 + -- package-id bndngs-DSL-1.0.25-d82df022 + +fromGhcPkg :: IO Index +fromGhcPkg = do + (_, out, err) <- Util.readProcessWithExitCode "ghc-pkg" + ["field", "*", "name,exposed,exposed-modules"] + unless (Text.null err) $ + IO.hPutStrLn IO.stderr $ "stderr from ghc-pkg: " ++ Text.unpack err + let (errors, index) = parseDump out + unless (null errors) $ + IO.hPutStrLn IO.stderr $ "errors parsing ghc-pkg output: " + ++ List.intercalate ", " errors + return index + +makeIndex :: [(Text, [Types.ModuleName])] -- ^ [(package, modules)] + -> Index +makeIndex packages = Map.fromListWith (++) + [ (qual, [(Text.unpack package, mod)]) + | (package, modules) <- packages + , mod <- modules + , qual <- moduleQualifications mod + ] + +parseDump :: Text -> ([String], Index) +parseDump text = (errors, makeIndex packages) + where + (errors, packages) = Either.partitionEithers $ + extractSections (parseGhcPkg text) + +extractSections :: [(Text, [Text])] + -> [Either String (Text, [Types.ModuleName])] +extractSections = Maybe.mapMaybe extract . Util.splitWith ((=="name") . fst) + where + extract [ ("name", [name]) + , ("exposed", [exposed]) + , ("exposed-modules", modules) + ] + | exposed /= "True" = Nothing + | otherwise = Just $ + Right (name, map (Types.ModuleName . Text.unpack) modules) + -- It may be missing exposed-modules, but that means I don't need it. + extract _ = Nothing + +-- | Take a module name to all its possible qualifications, i.e. its list +-- of suffixes. +moduleQualifications :: Types.ModuleName -> [Types.Qualification] +moduleQualifications = map (Types.Qualification . Util.join ".") + . filter (not . null) . List.tails . Util.split "." . Types.moduleName + +parseGhcPkg :: Text -> [(Text, [Text])] +parseGhcPkg = map (second (map uncomma . concatMap Text.words)) . parseSections + where + -- Somewhere in 9.2, ghc-pkg switched from space separated to comma + -- separated. + uncomma t = Maybe.fromMaybe t (Text.stripSuffix "," t) + +parseSections :: Text -> [(Text, [Text])] -- ^ [(section_name, lines)] +parseSections = List.unfoldr parseSection . stripComments . Text.lines + +stripComments :: [Text] -> [Text] +stripComments = + filter (not . Text.null) . map (Text.stripEnd . fst . Text.breakOn "--") + +-- | Consume a "tag: xyz" plus indents until the next dedented section. +parseSection :: [Text] -> Maybe ((Text, [Text]), [Text]) +parseSection [] = Nothing +parseSection (x:xs) = Just + ( (tag, map Text.strip (Text.drop 1 rest : pre)) + , post + ) + where + (tag, rest) = Text.break (==':') x + (pre, post) = span (" " `Text.isPrefixOf`) xs + + +-- * read cache + + diff --git a/src/FixImports/Main.hs b/src/FixImports/Main.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Main.hs @@ -0,0 +1,143 @@ +-- | Main file for FixImports that uses the default formatting. It reads +-- a config file from the current directory. +-- +-- More documentation in "FixImports". +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module FixImports.Main where +import qualified Control.Exception as Exception +import Control.Monad (when) +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Data.Version as Version + +import qualified System.Console.GetOpt as GetOpt +import qualified System.Directory as Directory +import qualified System.Environment as Environment +import qualified System.Exit as Exit +import qualified System.IO as IO + +import qualified FixImports.Config as Config +import qualified FixImports.FixImports as FixImports +import qualified FixImports.Types as Types +import qualified FixImports.Util as Util + +import qualified Paths_fix_imports + + +main :: IO () +main = do + -- I need the module path to search for modules relative to it first. I + -- could figure it out from the parsed module name, but a main module may + -- not have a name. + (modulePath, flags) <- parseArgs =<< Environment.getArgs + (config, errors) <- + fromMaybe (Config.empty, []) <$> case [fn | Config fn <- flags] of + [] -> findConfig + fns -> readConfig (last fns) + if null errors + then mainConfig config flags modulePath + else do + Text.IO.hPutStrLn IO.stderr $ Text.unlines errors + Exit.exitFailure + +findConfig :: IO (Maybe (Config.Config, [Text.Text])) +findConfig = firstJust . map readConfig =<< getConfigLocations + +getConfigLocations :: IO [FilePath] +getConfigLocations = sequence + [ return ".fix-imports" + , Directory.getXdgDirectory Directory.XdgConfig "fix-imports" + ] + +firstJust :: [IO (Maybe a)] -> IO (Maybe a) +firstJust [] = return Nothing +firstJust (x : xs) = maybe (firstJust xs) (return . Just) =<< x + +readConfig :: FilePath -> IO (Maybe (Config.Config, [Text.Text])) +readConfig = fmap (fmap Config.parse) . Util.catchENOENT . Text.IO.readFile + +mainConfig :: Config.Config -> [Flag] -> FilePath -> IO () +mainConfig config flags modulePath = do + let (verbose, debug, includes) = extractFlags flags + source <- IO.getContents + config <- return $ config + { Config._includes = includes ++ Config._includes config + , Config._debug = debug + } + (result, logs) <- FixImports.fixModule config modulePath source + `Exception.catch` \(exc :: Exception.SomeException) -> + return (Left $ "exception: " ++ show exc, []) + case result of + Left err -> do + if Edit `elem` flags then putStrLn "0,0" else putStr source + when debug $ mapM_ (Text.IO.hPutStrLn IO.stderr) logs + IO.hPutStrLn IO.stderr $ "error: " ++ err + Exit.exitFailure + Right (FixImports.Result range imports added removed metrics) -> do + if Edit `elem` flags + then do + putStrLn $ show (fst range) <> "," <> show (snd range) + putStr imports + else putStr $ FixImports.substituteImports imports range source + let names = Util.join ", " . map Types.moduleName . Set.toList + (addedMsg, removedMsg) = (names added, names removed) + mDone <- FixImports.metric metrics "done" + when debug $ mapM_ (Text.IO.hPutStrLn IO.stderr) logs + Config.debug config $ Text.stripEnd $ + FixImports.showMetrics (mDone : metrics) + when (verbose && not (null addedMsg) || not (null removedMsg)) $ + IO.hPutStrLn IO.stderr $ Util.join "; " $ filter (not . null) + [ if null addedMsg then "" else "added: " ++ addedMsg + , if null removedMsg then "" else "removed: " ++ removedMsg + ] + Exit.exitSuccess + +data Flag = Config FilePath | Debug | Edit | Include String | Verbose + deriving (Eq, Show) + +options :: [FilePath] -> [GetOpt.OptDescr Flag] +options configLocations = + [ 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 ['i'] [] (GetOpt.ReqArg Include "path") + "add to module include path" + , GetOpt.Option ['v'] [] (GetOpt.NoArg Verbose) + "print added and removed modules on stderr" + ] + +parseArgs :: [String] -> IO (String, [Flag]) +parseArgs args = do + configLocations <- getConfigLocations + case GetOpt.getOpt GetOpt.Permute (options configLocations) args of + (flags, [modulePath], []) -> return (modulePath, flags) + (_, [], errs) -> usage $ concat errs + _ -> usage "too many args" + +extractFlags :: [Flag] -> (Bool, Bool, [FilePath]) +extractFlags flags = + ( Verbose `elem` flags + , Debug `elem` flags + , "." : [p | Include p <- flags] + ) + -- Includes always have the current directory first. + +usage :: String -> IO a +usage msg = do + name <- Environment.getProgName + configLocations <- getConfigLocations + IO.hPutStr IO.stderr $ + GetOpt.usageInfo (msg ++ "\n" ++ name ++ " Module.hs )) +import qualified Control.DeepSeq as DeepSeq +import qualified Control.Monad as Monad +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set + +import qualified Language.Haskell.GhclibParserEx.GHC.Parser as Parser +import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as Config +import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as ExSession + +import qualified GHC.Data.FastString as FastString +import qualified GHC.Driver.Session as Session +import qualified GHC.Hs as Hs +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Parser.Lexer as Lexer +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.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 Data.Generics.Uniplate.Data as Uniplate + +import qualified FixImports.Types as Types +import qualified FixImports.Util as Util + + +-- * parse + +type Module = Hs.HsModule + +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])) +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 + +data Comment = Comment { _span :: !Types.SrcSpan, _comment :: !String } + deriving (Eq, Ord, Show) + +instance DeepSeq.NFData Comment where rnf (Comment _ cmt) = DeepSeq.rnf cmt + +makeDynFlags :: [Types.Extension] -> FilePath -> Src + -> IO (Either String Session.DynFlags) +makeDynFlags extensions fname src = + ExSession.parsePragmasIntoDynFlags defaultDynFlags + (extensions ++ defaultExtensions, []) fname src + where defaultExtensions = Session.languageExtensions Nothing + +defaultDynFlags :: Session.DynFlags +defaultDynFlags = + Session.defaultDynFlags Config.fakeSettings Config.fakeLlvmConfig + +extractParseResult :: Session.DynFlags + -> Lexer.ParseResult (SrcLoc.GenLocated l Module) + -> Either String (Module, [Comment]) +extractParseResult _dynFlags = \case + Lexer.POk state val -> Right + ( SrcLoc.unLoc val + , List.sort $ map extractComment (Lexer.comment_q state) + ++ maybe [] (map extractComment) (Lexer.header_comments state) + ++ 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 + ] + where (warns, errors) = Lexer.getMessages state + +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.EpaLineComment s -> s + Annotation.EpaBlockComment s -> s + Annotation.EpaEofComment -> "" + +-- * extract + +importComments :: Hs.HsModule -> [Comment] +importComments = + map extractComment + . concatMap (extract . extractAnn . Annotation.ann . SrcLoc.getLoc) + . Hs.hsmodImports + where + extractAnn = \case + Annotation.EpAnn _anchor _anns comments -> comments + Annotation.EpAnnNotUsed -> Annotation.emptyComments + extract = \case + Annotation.EpaComments prior -> prior + Annotation.EpaCommentsBalanced prior following -> prior ++ following + +-- | Qualifications of all the qualified names in this module. +qualifications :: Module -> Set.Set Types.Qualification +qualifications mod = Set.fromList + [ Types.Qualification $ Name.moduleNameString moduleName + | Reader.Qual moduleName _occName <- Uniplate.universeBi mod + ] + +-- | All unqualified names which are referenced in the module. This is a lot +-- more complicated than 'qualifications' because this needs to omit unqualified +-- names which are defined in here. +unqualifieds :: Module -> Set.Set Types.Name +unqualifieds mod = unqualifiedTypes mod <> unqualifiedValues mod + +-- | TODO: this doesn't handle type operators yet. +unqualifiedTypes :: Module -> Set.Set Types.Name +unqualifiedTypes mod = Set.fromList $ do + hsType :: Hs.HsType Hs.GhcPs <- Uniplate.universeBi mod + Reader.Unqual occName <- Uniplate.universeBi hsType + let var = Occurrence.occNameString occName + -- I don't want type variables, since they aren't references. I can just + -- filter out lower-case, which seems to be good enough? + Monad.guard $ case var of + c : _ -> Char.isUpper c + _ -> False + return $ inferName var + +unqualifiedValues :: Module -> Set.Set Types.Name +unqualifiedValues mod = Set.fromList $ do + (Hs.FunBind { fun_matches } :: Hs.HsBindLR Hs.GhcPs Hs.GhcPs) + <- Uniplate.universeBi mod + let matches = map SrcLoc.unLoc $ SrcLoc.unLoc $ Hs.mg_alts fun_matches + -- I think 'pats' is the binding names. + -- let pats = concatMap Hs.m_pats matches + let rhss = map Hs.m_grhss matches + Reader.Unqual occName <- Uniplate.universeBi rhss + return $ inferName $ Occurrence.occNameString occName + +-- | Return half-open line range of import block, starting from (0 based) line +-- of first import to the line after the last one. +importRange :: Module -> (Int, Int) +importRange mod = + get . unzip . map range + . Maybe.mapMaybe (getSpan . Annotation.locA . SrcLoc.getLoc) + . Hs.hsmodImports $ mod + where + -- This range is 1-based inclusive, and I want 0-based half-open, so + -- subtract 1 from the start. + get :: ([Int], [Int]) -> (Int, Int) + get (starts@(_:_), ends@(_:_)) = (minimum starts - 1, maximum ends) + -- No imports, pick the line after export list or module header. + get _ = fromMaybe (0, 0) $ do + span <- getSpan =<< + (Annotation.locA . SrcLoc.getLoc <$> Hs.hsmodExports mod) + <|> (Annotation.locA . SrcLoc.getLoc <$> Hs.hsmodName mod) + return (SrcLoc.srcSpanEndLine span, SrcLoc.srcSpanEndLine span) + range span = (SrcLoc.srcSpanStartLine span, SrcLoc.srcSpanEndLine span) + getSpan (SrcLoc.RealSrcSpan span _) = Just span + getSpan _ = Nothing + +-- ** Import + +extractImports :: Module -> [Types.Import] +extractImports = map extractImport . Hs.hsmodImports + +extractImport :: Hs.LImportDecl Hs.GhcPs -> Types.Import +extractImport locDecl = Types.Import + { _importName = Types.ModuleName $ Name.moduleNameString $ SrcLoc.unLoc $ + Hs.ideclName decl + , _importPkgQualifier = FastString.unpackFS . SourceText.sl_fs <$> + Hs.ideclPkgQual decl + , _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 + , _importSpan = extractSrcSpan $ Annotation.locA $ SrcLoc.getLoc locDecl + + } + where decl = SrcLoc.unLoc locDecl + +extractSrcSpan :: SrcLoc.SrcSpan -> Types.SrcSpan +extractSrcSpan (SrcLoc.RealSrcSpan span _) = extractRealSrcSpan span +extractSrcSpan (SrcLoc.UnhelpfulSpan fstr) = + error $ "UnhelpfulSpan: " <> show fstr + -- I think GHC uses these internally, in phases after Hs.GhcPs. + +extractRealSrcSpan :: SrcLoc.RealSrcSpan -> Types.SrcSpan +extractRealSrcSpan span = Types.SrcSpan + -- GHC SrcSpan has 1-based lines, I use 0-based ones. + { _startLine = SrcLoc.srcSpanStartLine span - 1 + , _startCol = SrcLoc.srcSpanStartCol span + , _endLine = SrcLoc.srcSpanEndLine span - 1 + , _endCol = SrcLoc.srcSpanEndCol span + } + +extractEntity :: Hs.IE Hs.GhcPs -> Either Types.Error Types.Entity +extractEntity = fmap entity . \case + -- var + Hs.IEVar _ var -> Right (unvar var, Nothing) + -- Constructor + Hs.IEThingAbs _ var -> Right (unvar var, Nothing) + -- Constructor(..) + Hs.IEThingAll _ var -> Right (unvar var, Just "(..)") + -- Constructor(x, y) + -- What is _wildcard? + Hs.IEThingWith _ var _wildcard things -> Right + ( unvar var + , Just $ "(" <> List.intercalate ", " (map (varStr . unvar) things) + <> ")" + ) + -- Shouldn't happen, export only. + Hs.IEModuleContents {} -> Left "IEModuleContents" + Hs.IEGroup {} -> Left "IEGroup" + Hs.IEDoc {} -> Left "IEDoc" + Hs.IEDocNamed {} -> Left "IEDocNamed" + where + entity ((qual, var), list) = Types.Entity qual var list + unvar var = case SrcLoc.unLoc var of + Hs.IEName n -> (Nothing, toName n) + Hs.IEPattern _ n -> (Just "pattern", toName n) + Hs.IEType _ n -> (Just "type", toName n) + varStr (Just qual, name) = qual <> " " <> Types.showName name + varStr (Nothing, name) = Types.showName name + toName = inferName . unRdrName . SrcLoc.unLoc + +inferName :: String -> Types.Name +inferName var + | all Util.haskellOpChar var = Types.Operator var + | otherwise = Types.Name var + +unRdrName :: Reader.RdrName -> String +unRdrName = \case + Reader.Unqual occName -> Occurrence.occNameString occName + Reader.Qual mod occName -> + Name.moduleNameString mod <> "." <> Occurrence.occNameString occName + -- TODO what is this? + Reader.Orig _mod occName -> -- modName mod <> + "+" <> Occurrence.occNameString occName + -- TODO what is this? + Reader.Exact _name -> "exact" diff --git a/src/FixImports/Parse_test.hs b/src/FixImports/Parse_test.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Parse_test.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module FixImports.Parse_test where +import qualified Data.Maybe as Maybe +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import qualified System.IO.Unsafe as Unsafe + +import qualified GHC.Hs as Hs +import qualified GHC.Types.SrcLoc as SrcLoc + +import qualified FixImports.Parse as Parse +import qualified FixImports.Types as Types + +import EL.Test.Global + + +test_importRange = do + let f = fmap Parse.importRange . parse + rightEqual (f "") (0, 0) + rightEqual (f "module M where\n") (1, 1) + rightEqual (f "-- hi\nmodule M where\n") (2, 2) + rightEqual (f + "module M (\n\ + \ x, y\n\ + \) where\n\ + \import A\n\ + \import B\n\ + \f = 42\n") + (3, 5) + rightEqual (f + "module M (\n\ + \ x, y\n\ + \) where\n\ + \f = 42\n") + (3, 3) + rightEqual (f + "module M where\n\ + \f = 42\n") + (1, 1) + +test_extractImports = do + let f = fmap (head . map strip . Parse.extractImports) . parse + strip imp = imp { Types._importSpan = Types.noSpan } + rightEqual (f "import \"pkg\" A ()") $ (Types.makeImport "A") + { Types._importPkgQualifier = Just "pkg" + , Types._importEntities = Just [] + } + rightEqual (f "import {-# SOURCE #-} A") $ (Types.makeImport "A") + { Types._importIsBoot = True } + rightEqual (f "import A as B hiding (a, b)") $ (Types.makeImport "A") + { Types._importAs = Just "B" + , Types._importHiding = True + , Types._importEntities = Just + [ Right $ Types.Entity Nothing (Types.Name "a") Nothing + , Right $ Types.Entity Nothing (Types.Name "b") Nothing + ] + } + +test_extensions = do + let f exts = Parse.parse (map (expectRight . parseExtension) exts) "M.hs" + let extract = fmap (fmap (extractEntities . fst)) + apply1 leftLike (extract $ f [] "import X (pattern A)") "parse error" + apply1 rightEqual (extract $ f ["PatternSynonyms"] "import X (pattern A)") + [Right ("pattern", Types.Name "A", "")] + apply1 rightEqual + (extract $ f [] + "{-# LANGUAGE PatternSynonyms #-}\nimport X (pattern A)") + [Right ("pattern", Types.Name "A", "")] + +parseExtension :: String -> Either String Types.Extension +parseExtension w = maybe (Left w) Right $ Types.parseExtension w + +test_comments = do + let f = fmap (fmap (map extract . snd)) . Parse.parse [] "M.hs" + extract (Parse.Comment (Types.SrcSpan x1 y1 x2 y2) cmt) = + ((x1, y1, x2, y2), cmt) + apply1 rightEqual (f "module M where\n") [] + apply1 rightEqual (f "-- above\nimport X -- right\n") + [((0, 1, 0, 9), "-- above"), ((1, 10, 1, 18), "-- right")] + apply1 rightEqual (f "-- | above\nimport X {- right -}\n") + [((0, 1, 0, 11), "-- | above"), ((1, 10, 1, 21), "{- right -}")] + apply1 rightEqual (f "-- *** section\nimport X {- ^ right -}\n") + [((0, 1, 0, 15), "-- *** section"), ((1, 10, 1, 23), "{- ^ right -}")] + +test_extractEntity = do + let f = fmap extractEntities . parse + extractEntities = map (fmap extractEntity) . fromMaybe [] + . Types._importEntities . head . Parse.extractImports + extractEntity (Types.Entity qual name list) = + (fromMaybe "" qual, name, fromMaybe "" list) + let n = Types.Name + rightEqual (f "import X") [] + rightEqual (f "import X (a, b)") + [Right ("", n "a", ""), Right ("", n "b", "")] + rightEqual (f "import X (type A)") [Right ("type", n "A", "")] + + rightEqual (f "import X (A)") [Right ("", n "A", "")] + rightEqual (f "import X (A(..))") [Right ("", n "A", "(..)")] + rightEqual (f "import X (A())") [Right ("", n "A", "()")] + rightEqual (f "import X (A(b, c))") [Right ("", n "A", "(b, c)")] + rightEqual (f "import X (A(B))") [Right ("", n "A", "(B)")] + rightEqual (f "import X ((*))") [Right ("", Types.Operator "*", "")] + + +extractEntities = map (fmap extractEntity) . fromMaybe [] + . Types._importEntities . head . Parse.extractImports + where + extractEntity (Types.Entity qual name list) = + (fromMaybe "" qual, name, fromMaybe "" list) + +test_qualifications = do + let f = fmap (Set.toList . Parse.qualifications) . parse + rightEqual (f "f = x") [] + rightEqual (f "f = A.x") ["A"] + rightEqual (f "f = A.B.x D.y") ["A.B", "D"] + rightEqual (f "f :: A.X -> B.Y") ["A", "B"] + rightEqual (f "f = x A. y") ["A"] + rightEqual (f "f = (A.) x y") ["A"] + rightEqual (f "f = g @A.B @C.D") ["A", "C"] + +test_unqualifiedValues = do + let f = fmap (map unname . Set.toList . Parse.unqualifiedValues) . parse + unname (Types.Name s) = s + unname (Types.Operator s) = "(" <> s <> ")" + -- Don't pick up imports and exports. + rightEqual (f "module A (b) where\nimport C (d)\n") [] + -- Don't pick up function lhs. + rightEqual (f "f x = 10") [] + rightEqual (f "f x = y") ["y"] + rightEqual (f "x = y") ["y"] + -- TODO I'd rather just "pat", but I'd need to dig deeper into + -- the pattern AST which is complicated. + rightEqual (f "f | x <- pat = 10") ["pat", "x"] + rightEqual (f "f = 10 * 20") ["(*)"] + -- instance declarations + rightEqual (f "instance A B where f = x") ["x"] + +test_unqualifiedTypes = do + let f = fmap (map unname . Set.toList . Parse.unqualifiedTypes) . parse + unname (Types.Name s) = s + unname (Types.Operator s) = "(" <> s <> ")" + -- Also look in type signatures. + rightEqual (f "f :: A -> B C") ["A", "B", "C"] + rightEqual (f "instance A b where f = x") ["A"] + rightEqual (f "instance A b where f = x") ["A"] + -- But not type declarations. + rightEqual (f "data A = B c | D e deriving (Z)") ["Z"] + rightEqual (f "class A where f :: A") ["A"] + +apply1 :: Monad m => (a -> b -> m c) -> m a -> b -> m c +apply1 f ma b = do + a <- ma + f a b + +parse :: String -> Either String Parse.Module +parse = Unsafe.unsafePerformIO . fmap (fmap fst) . Parse.parse [] "M.hs" diff --git a/src/FixImports/PkgCache.hs b/src/FixImports/PkgCache.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/PkgCache.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +module FixImports.PkgCache ( + load, UnitId, PkgName, ModuleName +) where +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as Text +import System.FilePath (()) +import qualified Data.Set as Set + +import qualified Distribution.InstalledPackageInfo as IPI +import qualified Distribution.ModuleName as ModuleName +import qualified Distribution.Types.PackageId as PackageId +import qualified Distribution.Types.PackageName as PackageName +import qualified Distribution.Types.UnitId as UnitId +import qualified GHC.Unit.Database as Database + + +-- t_pkgs = Set.fromList . map fst <$> loadCache cache +-- t_load = load (Set.fromList ["base-4.16.4.0"]) +-- [cache, global] +-- cache = "/Users/elaforge/.cabal/store/ghc-9.2.5/package.db" +-- global = "/Users/elaforge/.ghcup/ghc/9.2.5/lib/ghc-9.2.5/lib/package.conf.d" + +type UnitId = Text +type PkgName = Text +type ModuleName = String + +load :: Set UnitId -> [FilePath] -> IO [(PkgName, [ModuleName])] +load wanted pkgDbs = do + pkgs <- concat <$> mapM (\dir -> loadCache (dir "package.cache")) + pkgDbs + pure $ map snd $ filter ((`Set.member` wanted) . fst) pkgs + +loadCache :: FilePath -> IO [(UnitId, (PkgName, [ModuleName]))] +loadCache cachePath = do + (pkgs, _) <- Database.readPackageDbForGhcPkg cachePath + Database.DbOpenReadOnly + pure $ mapMaybe extract pkgs + +extract :: IPI.InstalledPackageInfo -> Maybe (UnitId, (PkgName, [ModuleName])) +extract pkg + | not (IPI.exposed pkg) = Nothing + | otherwise = Just + ( Text.pack $ UnitId.unUnitId $ IPI.installedUnitId pkg + , ( pkgName (IPI.sourcePackageId pkg) + , map (modString . IPI.exposedName) $ IPI.exposedModules pkg + ) + ) + where + modString = map (\c -> if c == '/' then '.' else c) . ModuleName.toFilePath + pkgName = Text.pack . PackageName.unPackageName . PackageId.pkgName diff --git a/src/FixImports/Types.hs b/src/FixImports/Types.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Types.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PackageImports #-} +module FixImports.Types ( + module FixImports.Types + , module GHC.LanguageExtensions.Type +) where +import qualified Control.DeepSeq as DeepSeq +import Control.DeepSeq (deepseq) +import qualified Data.Either as Either +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import qualified Data.String as String +import qualified System.FilePath as FilePath + +import "ghc-lib-parser" GHC.LanguageExtensions.Type (Extension(..)) +import qualified "ghc-lib-parser-ex" Language.Haskell.GhclibParserEx.GHC.Driver.Session + + +type Error = String + +parseExtension :: String -> Maybe Extension +parseExtension = + Language.Haskell.GhclibParserEx.GHC.Driver.Session.readExtension + +-- * ImportLine + +data ImportLine = ImportLine { + importDecl :: !Import + , importComments :: ![Comment] + , importSource :: !Source + } deriving (Show) + +instance DeepSeq.NFData ImportLine where + rnf (ImportLine decl cmts source) = + decl `seq` cmts `deepseq` source `deepseq` () + +-- | Where did this import come from? +data Source = Local | Package deriving (Eq, Show) + +instance DeepSeq.NFData Source where + rnf _ = () + +-- | A Comment is associated with a particular import line. +data Comment = Comment !CmtPos !String deriving (Show) +data CmtPos = CmtAbove | CmtRight deriving (Show) + +instance DeepSeq.NFData Comment where + rnf (Comment a b) = a `seq` b `seq` () + +-- * Import + +data Import = Import { + _importName :: !ModuleName + , _importPkgQualifier :: !(Maybe String) + -- | SOURCE pragma? There is also ideclSourceSrc, but it looks like it's + -- just to preserve the exact case or British-ness of the pragma, so I can + -- discard it. + , _importIsBoot :: !Bool + , _importSafe :: !Bool -- ^ safe import + , _importQualified :: !Bool -- ^ qualified + , _importAs :: !(Maybe Qualification) -- ^ import as + , _importHiding :: !Bool -- ^ import list is hiding + , _importEntities :: !(Maybe [Either Error Entity]) + , _importSpan :: !SrcSpan + } deriving (Eq, Ord, Show) + +instance DeepSeq.NFData Import where + rnf imp = _importPkgQualifier `deepseq` _importEntities imp `deepseq` () + +data SrcSpan = SrcSpan { _startLine, _startCol, _endLine, _endCol :: !Int } + deriving (Eq, Ord, Show) + +noSpan :: SrcSpan +noSpan = SrcSpan 0 0 0 0 + +makeImport :: ModuleName -> Import +makeImport name = Import + { _importName = name + , _importPkgQualifier = Nothing + , _importIsBoot = False + , _importSafe = False + , _importQualified = False + , _importAs = Nothing + , _importHiding = False + , _importEntities = Nothing + , _importSpan = noSpan + } + +-- | Get the qualified name from an Import. +importQualification :: Import -> Qualification +importQualification imp = + fromMaybe (toQual (_importName imp)) (_importAs imp) + where toQual (ModuleName m) = Qualification m + +setQualification :: Qualification -> Import -> Import +setQualification qual imp = imp + { _importQualified = True + , _importAs = if toQual (_importName imp) == qual then Nothing + else Just qual + } where toQual (ModuleName m) = Qualification m + +-- | @import X hiding (x)@ doesn't count as an unqualified import, at least not +-- the kind that I manage. +importUnqualified :: Import -> Bool +importUnqualified imp = + not (_importQualified imp) && not (_importHiding imp) + +-- | Has an import list, but is empty. This import is a no-op, except for +-- instances. +importEmpty :: Import -> Bool +importEmpty imp = case _importEntities imp of + Just [] -> True + _ -> False + +-- | If this import has a import list, modify its contents. +importModify :: ([Entity] -> [Entity]) -> Import -> Import +importModify modify imp = case (_importHiding imp, _importEntities imp) of + (False, Just errEntities) -> imp + { _importEntities = Just $ map Left errs + ++ map Right (normalize (modify entities)) + } + where (errs, entities) = Either.partitionEithers errEntities + _ -> imp + where + -- Keep entities unique and sorted. + normalize = Set.toList . Set.fromList + +-- | An imported entity, e.g. @import X (entity)@. +data Entity = Entity { + _entityQualifier :: !(Maybe String) + , _entityVar :: !Name + , _entityList :: !(Maybe String) + } deriving (Eq, Ord, Show) + +instance DeepSeq.NFData Entity where + rnf (Entity a b c) = a `deepseq` b `deepseq` c `deepseq` () + +-- | A Qualification is a qualified name minus the actual name. So it should +-- be the tail of a ModuleName. +newtype Qualification = Qualification String + deriving (Eq, Ord, Show, DeepSeq.NFData, String.IsString) + +-- | An unqualified identifier. +data Name = Name !String | Operator !String + deriving (Eq, Ord, Show) + +instance DeepSeq.NFData Name where + rnf (Name s) = DeepSeq.rnf s + rnf (Operator s) = DeepSeq.rnf s + +showName :: Name -> String +showName (Name s) = s +showName (Operator s) = "(" <> s <> ")" + +newtype ModuleName = ModuleName String + deriving (Eq, Ord, Show, DeepSeq.NFData, String.IsString) + +moduleName :: ModuleName -> String +moduleName (ModuleName n) = n + +pathToModule :: FilePath -> ModuleName +pathToModule = ModuleName + . map (\c -> if c == '/' then '.' else c) . FilePath.dropExtension + +moduleToPath :: ModuleName -> FilePath +moduleToPath (ModuleName name) = + map (\c -> if c == '.' then '/' else c) name ++ ".hs" diff --git a/src/FixImports/Util.hs b/src/FixImports/Util.hs new file mode 100644 --- /dev/null +++ b/src/FixImports/Util.hs @@ -0,0 +1,187 @@ +module FixImports.Util where +import Prelude hiding (head) +import qualified Control.Concurrent as Concurrent +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Exception as Exception +import Control.Monad + +import qualified Data.Char as Char +import qualified Data.Function as Function +import qualified Data.IntSet as IntSet +import qualified Data.List as List +import qualified Data.List.Split as Split +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as Text.IO + +import qualified System.Directory as Directory +import qualified System.Exit as Exit +import System.FilePath (()) +import qualified System.IO as IO +import qualified System.IO.Error as IO.Error +import qualified System.Process as Process + + +-- | Copy paste from FastTags.Tag.haskellOpChar. +-- +-- From the haskell report: +-- > varsym → ( symbol⟨:⟩ {symbol} )⟨reservedop | dashes⟩ +-- > symbol → ascSymbol | uniSymbol⟨special | _ | " | '⟩ +-- > uniSymbol → any Unicode symbol or punctuation +haskellOpChar :: Char -> Bool +haskellOpChar c = + IntSet.member (Char.ord c) opChars + || (IntSet.notMember (Char.ord c) exceptions + && isSymbolCharacterCategory (Char.generalCategory c)) + where + opChars = IntSet.fromList $ map Char.ord "-!#$%&*+./<=>?@^|~:\\" + exceptions = IntSet.fromList $ map Char.ord "_\"'" + +isSymbolCharacterCategory :: Char.GeneralCategory -> Bool +isSymbolCharacterCategory cat = Set.member cat symbolCategories + where + symbolCategories :: Set.Set Char.GeneralCategory + symbolCategories = Set.fromList + [ Char.ConnectorPunctuation + , Char.DashPunctuation + , Char.OtherPunctuation + , Char.MathSymbol + , Char.CurrencySymbol + , Char.ModifierSymbol + , Char.OtherSymbol + ] + +-- * list + +-- | List initial and final element, if any. +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = Just $ go x xs + where + go x [] = ([], x) + go x (x':xs) = let (pre, post) = go x' xs in (x:pre, post) + +-- | Concat a list with 'sep' in between. +join :: [a] -> [[a]] -> [a] +join = List.intercalate + +-- | Split 'xs' on 'sep', dropping 'sep' from the result. +split :: (Eq a) => [a] -> [a] -> [[a]] +split = Split.splitOn + +-- | Split where the function matches. +splitWith :: (a -> Bool) -> [a] -> [[a]] +splitWith f xs = map reverse (go f xs []) + where + go _ [] collect = [collect] + go f (x:xs) collect + | f x = collect : go f xs [x] + | otherwise = go f xs (x:collect) + +head :: [a] -> Maybe a +head [] = Nothing +head (x:_) = Just x + +sortOn :: (Ord k) => (a -> k) -> [a] -> [a] +sortOn key = List.sortBy (compare `Function.on` key) + +groupOn :: (Eq k) => (a -> k) -> [a] -> [[a]] +groupOn key = List.groupBy ((==) `Function.on` key) + +minimumOn :: Ord k => (a -> k) -> [a] -> Maybe a +minimumOn _ [] = Nothing +minimumOn key xs = Just (List.foldl1' f xs) + where f low x = if key x < key low then x else low + +-- | Like 'List.partition', but partition by two functions consecutively. +partition2 :: (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a], [a]) +partition2 f1 f2 xs = (as, bs, xs3) + where + (as, xs2) = List.partition f1 xs + (bs, xs3) = List.partition f2 xs2 + +zipPrev :: [a] -> [(a, a)] +zipPrev xs = zip xs (drop 1 xs) + +-- | Modify a list at the first place the predicate matches. +modifyAt :: (a -> Bool) -> (a -> a) -> [a] -> Maybe [a] +modifyAt match modify = go + where + go [] = Nothing + go (x:xs) + | match x = Just (modify x : xs) + | otherwise = (x:) <$> go xs + +setmap :: (Ord k, Ord a) => [(k, a)] -> Map.Map k (Set.Set a) +setmap = Map.fromAscList + . map (\gs -> (fst (List.head gs), Set.fromList (map snd gs))) + . groupOn fst . sortOn fst + +multimap :: Ord k => [(k, a)] -> Map.Map k [a] +multimap = Map.fromAscList . map (\gs -> (fst (List.head gs), map snd gs)) + . groupOn fst . sortOn fst + +partitionOn :: (a -> Maybe b) -> [a] -> ([b], [a]) +partitionOn f = go + where + go [] = ([], []) + go (x:xs) = case f x of + Just b -> (b:bs, as) + Nothing -> (bs, x:as) + where (bs, as) = go xs + +uniqueOn :: Ord k => (a -> k) -> [a] -> [a] +uniqueOn key xs = Map.elems $ Map.fromList $ zip (map key xs) xs + +-- * control + +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM cond consequent alternative = do + b <- cond + if b then consequent else alternative + +partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM f = go [] [] + where + go ts fs [] = return (ts, fs) + go ts fs (x:xs) = ifM (f x) (go (x:ts) fs xs) (go ts (x:fs) xs) + +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = return False +anyM f (x:xs) = ifM (f x) (return True) (anyM f xs) + +-- | If @op@ raised ENOENT, return Nothing. +catchENOENT :: IO a -> IO (Maybe a) +catchENOENT op = Exception.handleJust (guard . IO.Error.isDoesNotExistError) + (const (return Nothing)) (fmap Just op) + +-- * file + +listDir :: FilePath -> IO [FilePath] +listDir dir = fmap (map add . filter (not . (`elem` [".", ".."]))) + (Directory.getDirectoryContents dir) + where add = if dir == "." then id else (dir ) + +-- | Similar to System.Process.readProcessWithExitCode but return Text instead +-- of String. +readProcessWithExitCode :: FilePath -> [String] + -> IO (Exit.ExitCode, T.Text, T.Text) +readProcessWithExitCode cmd args = do + (_, Just outh, Just errh, pid) <- + Process.createProcess (Process.proc cmd args) + { Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + outMVar <- MVar.newEmptyMVar + errMVar <- MVar.newEmptyMVar + void $ Concurrent.forkIO $ + MVar.putMVar outMVar =<< Text.IO.hGetContents outh + void $ Concurrent.forkIO $ + MVar.putMVar errMVar =<< Text.IO.hGetContents errh + out <- MVar.takeMVar outMVar + err <- MVar.takeMVar errMVar + IO.hClose outh + IO.hClose errh + ex <- Process.waitForProcess pid + return (ex, out, err) diff --git a/src/FixImports_test.hs b/src/FixImports_test.hs deleted file mode 100644 --- a/src/FixImports_test.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -module FixImports_test where -import Control.Monad (unless, void) -import qualified Control.Monad.Identity as Identity -import qualified Control.Monad.State.Strict as State -import Data.Bifunctor (bimap) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Time.Clock.POSIX as Clock.POSIX - -import qualified Language.Haskell.Exts as Haskell -import qualified System.FilePath as FilePath - -import qualified Config -import qualified FixImports -import qualified Index -import qualified Types - -import EL.Test.Global - - -test_simple = do - let run config = fmap FixImports.resultImports - . fixModule index ["C.hs"] (mkConfig config) "A.hs" - index = Index.makeIndex - [ ("pkg", ["A.B"]) - , ("zpkg", ["Z"]) - ] - equal (run "" "x = B.c") $ Right "import qualified A.B as B\n" - equal (run "" "x = A.B.c") $ Right "import qualified A.B\n" - leftLike (run "" "x = Q.c") "not found: Q" - -- Remove unused. - equal (run "" "import qualified A.B as B\n\nx = y") $ Right "" - -- Unless it's unqualified. - equal (run "" "import A.B as B\n\nx = y") $ Right - "import A.B as B\n" - - -- Local goes below package. - equal (run "" "x = (B.a, C.a, Z.a)") $ Right - "import qualified A.B as B\n\ - \import qualified Z\n\ - \\n\ - \import qualified C\n" - - -- Don't mess with imports I don't manage. - equal (run "" "import A.B hiding (mod)\n") $ - Right "import A.B hiding (mod)\n" - equal (run "" "import A.B\n") $ - Right "import A.B\n" - -test_qualifyAs = do - let run config files = fmap eResult . fixModule index files config "A.hs" - config = mkConfig "qualify-as: Data.Text.Lazy as DTL" - index = Index.makeIndex [("text", ["Data.Text.Lazy"])] - equal (run config [] "x = DTL.y") $ Right - ( ["Data.Text.Lazy"] - , [] - , "import qualified Data.Text.Lazy as DTL\n" - ) - equal (run config [] "import qualified Data.Text.Lazy as DTL\n") $ Right - ( [] - , ["Data.Text.Lazy"] - , "" - ) - - -- qualifyAs aliases are prioritized in the same way as others, so - -- the local module wins: - equal (run config ["DTL.hs"] "x = DTL.y") $ - Right (["DTL"], [], "import qualified DTL\n") - - -- Unless explicitly suppressed: - let config2 = mkConfig $ Text.unlines - [ "qualify-as: Data.Text.Lazy as DTL" - , "prio-module-high: Data.Text.Lazy" - ] - equal (run config2 ["DTL.hs"] "x = DTL.y") $ Right - ( ["Data.Text.Lazy"] - , [] - , "import qualified Data.Text.Lazy as DTL\n" - ) - -test_unqualified = do - let run config = fmap eResult - . fixModule index ["C.hs"] (mkConfig config) "A.hs" - index = Index.makeIndex - [ ("pkg", ["A.B"]) - , ("zpkg", ["Z"]) - ] - equal (run "unqualified: A.B (c)" "x = (c, c)") $ Right - ( ["A.B"] - , [] - , "import A.B (c)\n" - ) - - -- Modify an existing import. - equal (run "unqualified: A.B (c)" "import A.B (a, z)\nx = (c, c)") $ Right - ( [] - , [] - , "import A.B (a, c, z)\n" - ) - equal (run "unqualified: A.B (a, c)" "import A.B (a, c)\nx = a") $ Right - ( [] - , [] - , "import A.B (a)\n" - ) - -- Don't accumulate duplicates. - equal (run "unqualified: A.B (c)" "import A.B (c)\nx = c") $ - Right ([], [], "import A.B (c)\n") - equal (run "unqualified: A.B (C)" "import A.B (C)\nx :: C") $ - Right ([], [], "import A.B (C)\n") - - -- Don't manage it if it's not mine. - equal (run "unqualified: A.B (c)" "import A.B (d)") $ Right - ([], [], "import A.B (d)\n") - - -- local still goes below package - equal (run "unqualified: C (a)" "import A.B\nimport Z\nx = a") $ Right - ( ["C"] - , [] - , "import A.B\n\ - \import Z\n\ - \\n\ - \import C (a)\n" - ) - - -- Don't import when it's an assignee. - equal (run "unqualified: A.B (c)" "c = x") $ Right ([], [], "") - equal (run "unqualified: A.B (())" "x = a b") $ - Right (["A.B"], [], "import A.B (())\n") - - -- Removed unused. - equal (run "unqualified: A.B (c)" "import A.B (c)\nx = x\n") $ - Right ([], ["A.B"], "") - -- But not if it's a spec-less import. - equal (run "unqualified: A.B (c)" "import A.B\nx = x\n") $ - Right ([], [], "import A.B\n") - -eResult :: FixImports.Result -> ([Types.ModuleName], [Types.ModuleName], String) -eResult r = - ( Set.toList (FixImports.resultAdded r) - , Set.toList (FixImports.resultRemoved r) - , FixImports.resultImports r - ) - -fixModule :: Index.Index -> [FilePath] - -> Config.Config -> FilePath -> String -> Either String FixImports.Result -fixModule index files config modulePath source = - case FixImports.parse (Config._language config) modulePath source of - Haskell.ParseFailed srcloc err -> - Left $ Haskell.prettyPrint srcloc ++ ": " ++ err - Haskell.ParseOk (mod, cmts) -> - fst $ Identity.runIdentity $ flip State.runStateT [] $ - FixImports.fixImports (pureFilesystem files) config index - modulePath mod cmts - --- | The ./ stuff is tricky, this is probably still wrong. -pureFilesystem :: [FilePath] -> FixImports.Filesystem Identity.Identity -pureFilesystem files = FixImports.Filesystem - { _listDir = \dir -> return - . Maybe.fromMaybe ([], []) . (`Map.lookup` tree) $ dir - , _doesFileExist = \fn -> return . (`elem` files) . normalize $ fn - , _metric = \_ _ -> - return (Clock.POSIX.posixSecondsToUTCTime 0, Text.pack "metric") - } - where - tree = filesToTree (map ("./"++) files) - normalize ('.':'/':fn) = fn - normalize fn = fn - --- group by first element, then second, etc. -filesToTree :: [FilePath] -> Map.Map FilePath ([FilePath], [FilePath]) - -- ^ (dirs, files) -filesToTree = Map.fromList - . map (bimap (List.dropWhileEnd (=='/')) separate) . groupFst - . concatMap prefixes - where - separate [""] = ([], []) - separate subs = (unique $ map (takeWhile (/='/')) dirs, files) - where (dirs, files) = List.partition ('/' `elem`) subs - -prefixes :: FilePath -> [(FilePath, FilePath)] -prefixes = map (bimap concat concat) . drop 1 - . (\xs -> zip (List.inits xs) (List.tails xs)) . FilePath.splitPath - -mkConfig :: Text.Text -> Config.Config -mkConfig content - | null errs = config { Config._includes = ["."] } - | otherwise = error $ "parsing " <> show content <> ": " - <> unlines (map Text.unpack errs) - where (config, errs) = Config.parse content - --- * util - -type NonNull a = [a] - --- | Similar to 'keyedGroupSort', but key on the fst element, and strip the --- key out of the groups. -groupFst :: Ord a => [(a, b)] -> [(a, NonNull b)] -groupFst xs = [(key, map snd group) | (key, group) <- keyedGroupSort fst xs] - --- | Group the unsorted list into @(key x, xs)@ where all @xs@ compare equal --- after @key@ is applied to them. -keyedGroupSort :: Ord key => (a -> key) -> [a] -> [(key, NonNull a)] - -- ^ Sorted by key. The NonNull group is in the same order as the input. -keyedGroupSort key = Map.toAscList . foldr go Map.empty - where go x = Map.alter (Just . maybe [x] (x:)) (key x) - -unique :: Ord a => [a] -> [a] -unique = Set.toList . Set.fromList diff --git a/src/Index.hs b/src/Index.hs deleted file mode 100644 --- a/src/Index.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Maintain the index from Qualification to the full module from the package --- db that this Qualification probably intends. -module Index (Index, Package, empty, load, makeIndex, parseSections) where -import Prelude hiding (mod) -import Control.Monad -import qualified Data.Either as Either -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Maybe as Maybe -import Data.Text (Text) - -import qualified System.IO as IO - -import qualified Types -import qualified Util - - --- | Map from tails of the each module in the package db to its module name. --- So @List@ and @Data.List@ will map to @Data.List@. Modules from a set --- of core packages, like base and containers, will take priority, so even if --- there's a package with @Some.Obscure.List@, @List@ will still map to --- @Data.List@. -type Index = Map.Map Types.Qualification [(Package, Types.ModuleName)] - --- | Package name without the version. -type Package = String - -empty :: Index -empty = Map.empty - -load :: IO Index -load = build -- TODO load cache? - -build :: IO Index -build = do - (_, out, err) <- Util.readProcessWithExitCode "ghc-pkg" - ["field", "*", "name,exposed,exposed-modules"] - unless (T.null err) $ - IO.hPutStrLn IO.stderr $ "stderr from ghc-pkg: " ++ T.unpack err - let (errors, index) = parseDump out - unless (null errors) $ - IO.hPutStrLn IO.stderr $ "errors parsing ghc-pkg output: " - ++ List.intercalate ", " errors - return index - -makeIndex :: [(Text, [Types.ModuleName])] -- ^ [(package, modules)] - -> Index -makeIndex packages = Map.fromListWith (++) - [ (qual, [(T.unpack package, mod)]) - | (package, modules) <- packages - , mod <- modules - , qual <- moduleQualifications mod - ] - -parseDump :: Text -> ([String], Index) -parseDump text = (errors, makeIndex packages) - where - (errors, packages) = Either.partitionEithers $ - extractSections (parseSections text) - -extractSections :: [(Text, [Text])] - -> [Either String (Text, [Types.ModuleName])] -extractSections = Maybe.mapMaybe extract . Util.splitWith ((=="name") . fst) - where - extract [ ("name", [name]) - , ("exposed", [exposed]) - , ("exposed-modules", modules) - ] - | exposed /= "True" = Nothing - | otherwise = Just $ - Right (name, map (Types.ModuleName . T.unpack) modules) - -- It may be missing exposed-modules, but that means I don't need it. - extract _ = Nothing - --- | Take a module name to all its possible qualifications, i.e. its list --- of suffixes. -moduleQualifications :: Types.ModuleName -> [Types.Qualification] -moduleQualifications = map (Types.Qualification . Util.join ".") - . filter (not . null) . List.tails . Util.split "." . Types.moduleName - -parseSections :: Text -> [(Text, [Text])] -- ^ [(section_name, words)] -parseSections = List.unfoldr parseSection . stripComments . T.lines - -stripComments :: [Text] -> [Text] -stripComments = filter (not . T.null) . map (T.stripEnd . fst . T.breakOn "--") - -parseSection :: [Text] -> Maybe ((Text, [Text]), [Text]) -parseSection [] = Nothing -parseSection (x:xs) = - Just ((tag, concatMap T.words (T.drop 1 rest : pre)), post) - where - (tag, rest) = T.break (==':') x - (pre, post) = span (" " `T.isPrefixOf`) xs diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,122 +0,0 @@ --- | Main file for FixImports that uses the default formatting. It reads --- a config file from the current directory. --- --- More documentation in "FixImports". -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Main where -import qualified Control.Exception as Exception -import Control.Monad (when) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Version as Version - -import qualified System.Console.GetOpt as GetOpt -import qualified System.Environment as Environment -import qualified System.Exit as Exit -import qualified System.IO as IO - -import qualified Config -import qualified FixImports -import qualified Paths_fix_imports -import qualified Types -import qualified Util - - -main :: IO () -main = do - -- I need the module path to search for modules relative to it first. I - -- could figure it out from the parsed module name, but a main module may - -- not have a name. - (modulePath, flags) <- parseArgs =<< Environment.getArgs - let configFile = if null fns then ".fix-imports" else last fns - where fns = [fn | Config fn <- flags] - (config, errors) <- readConfig configFile - if null errors - then mainConfig config flags modulePath - else do - Text.IO.hPutStrLn IO.stderr $ Text.unlines errors - Exit.exitFailure - -readConfig :: FilePath -> IO (Config.Config, [Text.Text]) -readConfig = fmap (maybe (Config.empty, []) Config.parse) - . Util.catchENOENT . Text.IO.readFile - -mainConfig :: Config.Config -> [Flag] -> FilePath -> IO () -mainConfig config flags modulePath = do - let (verbose, debug, includes) = extractFlags flags - source <- IO.getContents - config <- return $ config - { Config._includes = includes ++ Config._includes config - , Config._debug = debug - } - (fixed, logs) <- FixImports.fixModule config modulePath source - `Exception.catch` \(exc :: Exception.SomeException) -> - return (Left $ "exception: " ++ show exc, []) - case fixed of - Left err -> do - if Edit `elem` flags then putStrLn "0,0" else putStr source - when debug $ mapM_ (Text.IO.hPutStrLn IO.stderr) logs - IO.hPutStrLn IO.stderr $ "error: " ++ err - Exit.exitFailure - Right (FixImports.Result range imports added removed metrics) -> do - if Edit `elem` flags - then do - putStrLn $ show (fst range) <> "," <> show (snd range) - putStr imports - else putStr $ FixImports.substituteImports imports range source - let names = Util.join ", " . map Types.moduleName . Set.toList - (addedMsg, removedMsg) = (names added, names removed) - mDone <- FixImports.metric metrics "done" - when debug $ mapM_ (Text.IO.hPutStrLn IO.stderr) logs - Config.debug config $ Text.stripEnd $ - FixImports.showMetrics (mDone : metrics) - when (verbose && not (null addedMsg) || not (null removedMsg)) $ - IO.hPutStrLn IO.stderr $ Util.join "; " $ filter (not . null) - [ if null addedMsg then "" else "added: " ++ addedMsg - , if null removedMsg then "" else "removed: " ++ removedMsg - ] - Exit.exitSuccess - -data Flag = Config FilePath | Debug | Edit | Include String | Verbose - deriving (Eq, Show) - -options :: [GetOpt.OptDescr Flag] -options = - [ GetOpt.Option ['c'] ["config"] (GetOpt.ReqArg Config "path") - "path to config file, defaults to .fix-imports" - , 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 ['i'] [] (GetOpt.ReqArg Include "path") - "add to module include path" - , GetOpt.Option ['v'] [] (GetOpt.NoArg Verbose) - "print added and removed modules on stderr" - ] - -parseArgs :: [String] -> IO (String, [Flag]) -parseArgs args = case GetOpt.getOpt GetOpt.Permute options args of - (flags, [modulePath], []) -> return (modulePath, flags) - (_, [], errs) -> usage $ concat errs - _ -> usage "too many args" - -extractFlags :: [Flag] -> (Bool, Bool, [FilePath]) -extractFlags flags = - ( Verbose `elem` flags - , Debug `elem` flags - , "." : [p | Include p <- flags] - ) - -- Includes always have the current directory first. - -usage :: String -> IO a -usage msg = do - name <- Environment.getProgName - IO.hPutStr IO.stderr $ - GetOpt.usageInfo (msg ++ "\n" ++ name ++ " Module.hs String -moduleName (ModuleName n) = n - -pathToModule :: FilePath -> ModuleName -pathToModule = ModuleName - . map (\c -> if c == '/' then '.' else c) . FilePath.dropExtension - -moduleToPath :: ModuleName -> FilePath -moduleToPath (ModuleName name) = - map (\c -> if c == '.' then '/' else c) name ++ ".hs" - --- | Get the qualified name from an import. -importDeclQualification :: ImportDecl -> Qualification -importDeclQualification decl = moduleToQualification $ - maybe (Haskell.importModule decl) id (Haskell.importAs decl) - --- | Extract the ModuleName from an ImportDecl. -importDeclModule :: ImportDecl -> ModuleName -importDeclModule imp = case Haskell.importModule imp of - Haskell.ModuleName _ s -> ModuleName s - -importModule :: ImportLine -> ModuleName -importModule = importDeclModule . importDecl - --- | The parser represents the \'as\' part of an import as a ModuleName even --- though it's actually a Qualification. -moduleToQualification :: Haskell.ModuleName Haskell.SrcSpanInfo - -> Qualification -moduleToQualification (Haskell.ModuleName _ s) = Qualification s diff --git a/src/Util.hs b/src/Util.hs deleted file mode 100644 --- a/src/Util.hs +++ /dev/null @@ -1,180 +0,0 @@ -module Util where -import Prelude hiding (head) -import qualified Control.Concurrent as Concurrent -import qualified Control.Concurrent.MVar as MVar -import qualified Control.Exception as Exception -import Control.Monad - -import qualified Data.Char as Char -import qualified Data.Function as Function -import qualified Data.IntSet as IntSet -import qualified Data.List as List -import qualified Data.List.Split as Split -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.IO as Text.IO - -import qualified System.Directory as Directory -import qualified System.Exit as Exit -import System.FilePath (()) -import qualified System.IO as IO -import qualified System.IO.Error as IO.Error -import qualified System.Process as Process - - --- | Copy paste from FastTags.Tag.haskellOpChar. --- --- From the haskell report: --- > varsym → ( symbol⟨:⟩ {symbol} )⟨reservedop | dashes⟩ --- > symbol → ascSymbol | uniSymbol⟨special | _ | " | '⟩ --- > uniSymbol → any Unicode symbol or punctuation -haskellOpChar :: Char -> Bool -haskellOpChar c = - IntSet.member (Char.ord c) opChars - || (IntSet.notMember (Char.ord c) exceptions - && isSymbolCharacterCategory (Char.generalCategory c)) - where - opChars = IntSet.fromList $ map Char.ord "-!#$%&*+./<=>?@^|~:\\" - exceptions = IntSet.fromList $ map Char.ord "_\"'" - -isSymbolCharacterCategory :: Char.GeneralCategory -> Bool -isSymbolCharacterCategory cat = Set.member cat symbolCategories - where - symbolCategories :: Set.Set Char.GeneralCategory - symbolCategories = Set.fromList - [ Char.ConnectorPunctuation - , Char.DashPunctuation - , Char.OtherPunctuation - , Char.MathSymbol - , Char.CurrencySymbol - , Char.ModifierSymbol - , Char.OtherSymbol - ] - --- * list - --- | List initial and final element, if any. -unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc (x:xs) = Just $ go x xs - where - go x [] = ([], x) - go x (x':xs) = let (pre, post) = go x' xs in (x:pre, post) - --- | Concat a list with 'sep' in between. -join :: [a] -> [[a]] -> [a] -join = List.intercalate - --- | Split 'xs' on 'sep', dropping 'sep' from the result. -split :: (Eq a) => [a] -> [a] -> [[a]] -split = Split.splitOn - --- | Split where the function matches. -splitWith :: (a -> Bool) -> [a] -> [[a]] -splitWith f xs = map reverse (go f xs []) - where - go _ [] collect = [collect] - go f (x:xs) collect - | f x = collect : go f xs [x] - | otherwise = go f xs (x:collect) - -head :: [a] -> Maybe a -head [] = Nothing -head (x:_) = Just x - -sortOn :: (Ord k) => (a -> k) -> [a] -> [a] -sortOn key = List.sortBy (compare `Function.on` key) - -groupOn :: (Eq k) => (a -> k) -> [a] -> [[a]] -groupOn key = List.groupBy ((==) `Function.on` key) - -minimumOn :: Ord k => (a -> k) -> [a] -> Maybe a -minimumOn _ [] = Nothing -minimumOn key xs = Just (List.foldl1' f xs) - where f low x = if key x < key low then x else low - --- | Like 'List.partition', but partition by two functions consecutively. -partition2 :: (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a], [a]) -partition2 f1 f2 xs = (as, bs, xs3) - where - (as, xs2) = List.partition f1 xs - (bs, xs3) = List.partition f2 xs2 - -zipPrev :: [a] -> [(a, a)] -zipPrev xs = zip xs (drop 1 xs) - --- | Modify a list at the first place the predicate matches. -modifyAt :: (a -> Bool) -> (a -> a) -> [a] -> Maybe [a] -modifyAt match modify = go - where - go [] = Nothing - go (x:xs) - | match x = Just (modify x : xs) - | otherwise = (x:) <$> go xs - -multimap :: Ord k => [(k, a)] -> Map.Map k [a] -multimap = Map.fromAscList . map (\gs -> (fst (List.head gs), map snd gs)) - . groupOn fst . sortOn fst - -partitionOn :: (a -> Maybe b) -> [a] -> ([b], [a]) -partitionOn f = go - where - go [] = ([], []) - go (x:xs) = case f x of - Just b -> (b:bs, as) - Nothing -> (bs, x:as) - where (bs, as) = go xs - --- * control - -ifM :: Monad m => m Bool -> m a -> m a -> m a -ifM cond consequent alternative = do - b <- cond - if b then consequent else alternative - -partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) -partitionM f = go [] [] - where - go ts fs [] = return (ts, fs) - go ts fs (x:xs) = ifM (f x) (go (x:ts) fs xs) (go ts (x:fs) xs) - -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM _ [] = return False -anyM f (x:xs) = ifM (f x) (return True) (anyM f xs) - --- | If @op@ raised ENOENT, return Nothing. -catchENOENT :: IO a -> IO (Maybe a) -catchENOENT op = Exception.handleJust (guard . IO.Error.isDoesNotExistError) - (const (return Nothing)) (fmap Just op) - --- * file - -listDir :: FilePath -> IO [FilePath] -listDir dir = fmap (map add . filter (not . (`elem` [".", ".."]))) - (Directory.getDirectoryContents dir) - where add = if dir == "." then id else (dir ) - --- | Similar to System.Process.readProcessWithExitCode but return Text instead --- of String. -readProcessWithExitCode :: FilePath -> [String] - -> IO (Exit.ExitCode, T.Text, T.Text) -readProcessWithExitCode cmd args = do - (_, Just outh, Just errh, pid) <- - Process.createProcess (Process.proc cmd args) - { Process.std_out = Process.CreatePipe - , Process.std_err = Process.CreatePipe - } - outMVar <- MVar.newEmptyMVar - errMVar <- MVar.newEmptyMVar - void $ Concurrent.forkIO $ - MVar.putMVar outMVar =<< Text.IO.hGetContents outh - void $ Concurrent.forkIO $ - MVar.putMVar errMVar =<< Text.IO.hGetContents errh - out <- MVar.takeMVar outMVar - err <- MVar.takeMVar errMVar - IO.hClose outh - IO.hClose errh - ex <- Process.waitForProcess pid - return (ex, out, err) -