fix-imports 1.1.0 → 2.1.0
raw patch · 14 files changed
+1517/−407 lines, 14 filesdep +deepseqdep +mtldep +pretty
Dependencies added: deepseq, mtl, pretty, test-karya, time
Files
- README +0/−20
- README.md +15/−0
- changelog.md +34/−6
- dot-fix-imports +31/−14
- fix-imports.cabal +67/−15
- src/Config.hs +403/−94
- src/Config_test.hs +157/−0
- src/FixImports.hs +367/−162
- src/FixImports_test.hs +231/−40
- src/Index.hs +15/−7
- src/Main.hs +88/−40
- src/RunTests.hs +1/−0
- src/Types.hs +28/−6
- src/Util.hs +80/−3
− README
@@ -1,20 +0,0 @@-There are a few things which can be configured. Edit src/Main.hs and mess with-the Config it passes in. There isn't much configurability but what there is-should be documented in the modules in which it is defined.--See the vimrc for an exmaple of how it can be bound to a key in vim.--It'll reformat the import lines, including an import list if you have one.-Sorry about that. The formatting style of Language.Haskell.Exts.prettyPrint-is not my personal style. If it ever bothers me enough maybe I'll write my-own formatter, or come up with a way to not reformat unqualified imports.--Also, it will search for modules starting from '.', so you should be in the-root of the module hierarchy. It wouldn't be hard to add a -i flag though.--haskell-src-exts will crash the program if it gets an ambigious operator-fixity parse. I don't know why it does that, but if you get a crash like that-you can add your custom operators to the Config.--It can be a little slow. Most of the time is haskell-src-exts parsing the-module.
+ README.md view
@@ -0,0 +1,15 @@+`fix-imports` is a small standalone program to manage the import block of a+haskell program. It will try to add import lines for qualified names+with no corresponding import, remove unused import lines, and keep the+import block sorted, with optional rules for grouping.++Support for unqualified imports is limited to symbols you explicitly configure,+so if you list `System.FilePath.(</>)`, it will add that import when you use+it, or remove when it's no longer used, but it won't go search modules for+unqualified imports.++It doesn't mess with non-managed unqualified imports, so you can still use+unqualified imports, you just have to do it manually.++Since it's a unix-style filter, it should be possible to integrate into any+editor. There's an example vimrc to bind to a key in vim.
changelog.md view
@@ -1,29 +1,57 @@-1.1.0+### 2.1.0 +- unqualified syntax changed to support multiple imports per module++- add `format: leave-space-for-qualified` and `format: no-group`++- add import-as config option++ E.g. import Data.Text.Lazy as DTL, instead of always having to qualify+ as a suffix, like Lazy, or Text.Lazy.++- various bugs with unqualified imports++#### 2.0.0++- add support for unqualified imports for explicitly configured symbols, via+the `unqualified` field in `.fix-imports`++- significant speed improvement, reuse the loaded pkg index instead of asking+ghc-pkg find-module++- --debug now emits timing metrics++- import-order-{first,last} are exact matches, or are prefix matches if they+have a trailing dot++- prio-module-{high,low} are now exact matches instead of prefix++#### 1.1.0+ - Rename import-order to import-order-first, and add import-order-last. -1.0.5+#### 1.0.5 - support haskell-src-exts > 1.16 - add 'language' field to .fix-imports, to turn on local extensions -1.0.3 and 1.0.4+#### 1.0.3 and 1.0.4 - upgrade to haskell-src-exts-1.16 -1.0.2+#### 1.0.2 - Fix bug where a qualified import with >1 dot wasn't found. And don't mess with Prelude. -1.0.1+#### 1.0.1 - Fix a bunch of bugs: properly recognize unqualified imports as imports, never import the current module, don't pick up modules with the same suffix but a different name. -1.0.0+#### 1.0.0 - Change name from FixImports to fix-imports, which is more unixy.
dot-fix-imports view
@@ -1,35 +1,52 @@ -- fix-imports looks for a .fix-imports file in the current directory for -- per-project configuration. ----- The syntax is the same as the ghc-pkg output: word, colon, and a list--- of words. A line with leading space is a continuation of the previous--- line. Comments are written with "--".+-- 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.+-- Comments are written with "--". -- Include extra directories on the search path. Directories passed via -i -- go before this list. include: dist/build/my-project/my-project-tmp --- Control the sorting of the import list by prefix.+-- Control the sorting of the import list by prefix. A trailing dot+-- like "M." matches exactly M or anything starting with "M.". -- These go in the given order, before other imports.-import-order-first: Util Midi Ui Cmd Derive Perform Instrument Local- LogView App+import-order-first: Util. -- These go in the given order, but after all the other imports. import-order-last: Global+-- If present at all, unqualified import-all lines always go last.+-- They should be special, and this helps them stand out.+sort-unqualified-last: t --- When there are multiple candidates for a module, pick ones from a--- particular package first, or last.+-- When there are multiple candidates for a module, prefer or don't prefer+-- ones from these lists. These are exact matches:+prio-module-high: Ui+prio-module-low: GHC++-- Or increase or decrease priority for an entire package: prio-package-high: -- haskell98 and ghc export a lot of toplevel modules that most programs -- don't want to import. prio-package-low: haskell98 ghc Cabal --- ... or pick a particular module name prefix first, or last.-prio-module-high: Ui-prio-module-low: GHC+-- In the abscence of prio-* config, the module with the least number of dots+-- is picked. Usually packages put the most "public" modules at the top, e.g.+-- IO should choose System.IO, not Data.Text.Lazy.IO --- Otherwise, the module with the least number of dots is picked. Usually--- packages put the most "public" modules at the top, e.g. IO should choose--- System.IO, not Data.Text.Lazy.IO+-- Manage these symbols as unqualified imports. Use ()s for operators.+-- The syntax is meant to resemble import syntax, separated by semicolons:+unqualified: Data.Bifunctor (first, second); System.FilePath ((</>))++-- DTL.something will turn into a search for Data.Text.Lazy.+qualify-as: Data.Text.Lazy as DTL++format:+ -- Insert a space gap for the "qualified" keyword.+ leave-space-for-qualified+ -- Suppress the usual behaviour where imports are grouped by the first+ -- component.+ no-group -- Space separate list of extensions that are enabled by default. language: GeneralizedNewtypeDeriving
fix-imports.cabal view
@@ -1,17 +1,24 @@ name: fix-imports-version: 1.1.0-cabal-version: >= 1.6+version: 2.1.0+cabal-version: >= 1.10 build-type: Simple synopsis: Program to manage the imports of a haskell module description:- fix-imports is a small standalone program to manage the import block of a- haskell program. It will try to add import lines for qualified names- with no corresponding import, remove unused import lines, and sort the- import block according to some heuristic you can define. This only works- for qualified imports! Unqualified imports are left untouched.+ `fix-imports` is a small standalone program to manage the import block of+ a haskell program. It will try to add import lines for qualified names+ with no corresponding import, remove unused import lines, and keep the+ import block sorted, with optional rules for grouping. .- It's most convenient if bound to an editor key. See the included vimrc- for an example. You may have to cabal unpack or git clone to see it.+ Support for unqualified imports is limited to symbols you explicitly+ configure, so if you list `System.FilePath.(</>)`, it will add that import+ when you use it, or remove when it's no longer used, but it won't go search+ modules for unqualified imports.+ .+ It doesn't mess with non-managed unqualified imports, so you can still use+ unqualified imports, you just have to do it manually.+ .+ Since it's a unix-style filter, it should be possible to integrate into any+ editor. There's an example vimrc to bind to a key in vim. category: Editor, Haskell, IDE license: BSD3@@ -19,13 +26,12 @@ author: Evan Laforge maintainer: Evan Laforge <qdunkan@gmail.com> stability: stable-tested-with: GHC>=8.0.2-data-files: README, vimrc+tested-with: GHC == 8.4.2 extra-source-files:- src/*.hs+ README.md changelog.md- vimrc dot-fix-imports+ vimrc source-repository head type: git@@ -33,8 +39,54 @@ executable fix-imports main-is: Main.hs+ other-modules:+ Config FixImports Index Types Util+ Paths_fix_imports hs-source-dirs: src- build-depends: base >= 3 && < 5, containers, directory, filepath, process+ default-language: Haskell2010+ build-depends:+ base >= 3 && < 5+ , containers+ , cpphs+ , deepseq+ , directory+ , filepath , haskell-src-exts >= 1.16.0- , uniplate, split, cpphs, text+ , process+ , split+ , text+ , time+ , pretty+ , uniplate ghc-options: -Wall -fno-warn-name-shadowing++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: src+ main-is: RunTests.hs+ default-language: Haskell2010+ build-depends:+ base >= 3 && < 5+ , containers+ , cpphs+ , deepseq+ , directory+ , filepath+ , haskell-src-exts >= 1.16.0+ , mtl+ , process+ , split+ , text+ , time+ , pretty+ , uniplate++ , test-karya+ other-modules:+ Config+ Config_test+ FixImports+ FixImports_test+ Index+ Types+ Util
src/Config.hs view
@@ -1,14 +1,28 @@--- | This module pulls out a few values I'm more likely to want to configure--- per-project. They are passed to 'FixImports.runMain', so you can write--- your own Main.hs that passes its own Config.------ TODO dyre does this sort of thing+-- | 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 Index import qualified Types@@ -18,108 +32,300 @@ data Config = Config { -- | Additional directories to search for local modules. Taken from the -- -i flag and 'include' config line.- includes :: [FilePath]+ _includes :: [FilePath] -- | These language extensions are enabled by default.- , language :: [Extension.Extension]- -- | Format the import block.- , showImports :: [Types.ImportLine] -> String- -- | Often multiple modules from the package index will match- -- a qualification. Apply some heuristics to pick the most likely one.- , pickModule :: FilePath -> [(Maybe Index.Package, Types.ModuleName)]- -> Maybe (Maybe Index.Package, Types.ModuleName)- }+ , _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) -empty :: Config-empty = Config- { includes = []- , language = []- , showImports = formatGroups $ ImportOrder [] []- , pickModule = makePickModule defaultPriorities- }+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 :: ([Index.Package], [Index.Package])+ prioPackage :: Priority Index.Package -- | Place these modules either first or last in priority.- , prioModule :: ([Types.ModuleName], [Types.ModuleName])- } deriving (Show)+ , prioModule :: Priority Types.ModuleName+ } deriving (Eq, Show) --- | Sort order for local modules.-data ImportOrder = ImportOrder {- importFirst :: [Types.ModuleName]- , importLast :: [Types.ModuleName]- } deriving (Show)+instance Semigroup Priorities where+ Priorities a1 b1 <> Priorities a2 b2 = Priorities (a1<>a2) (b1<>b2)+instance Monoid Priorities where+ mempty = Priorities mempty mempty -parseLanguage :: [String] -> ([String], [Extension.Extension])+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 {+ -- | How to format import lines. Nothing to use the standard+ -- haskell-src-exts style with defaultMode.+ _ppConfig :: Maybe PPConfig+ -- | If true, group imports by their first component.+ , _groupImports :: Bool+ } deriving (Eq, Show)++data PPConfig = PPConfig {+ _leaveSpaceForQualified :: Bool+ } 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+ { _ppConfig = Nothing+ , _groupImports = True+ }++-- | 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+ { _ppConfig = Just $ PPConfig { _leaveSpaceForQualified = True } }+ set fmt "no-group" = Right $ fmt { _groupImports = False }+ 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 w of+ parse w = case Extension.parseExtension (Text.unpack w) of Extension.UnknownExtension _ -> Left w ext -> Right ext -defaultPriorities :: Priorities-defaultPriorities = Priorities- -- Make some common packages low priority so their exports don't get- -- chosen over what you probably wanted:- -- haskell98 has obsolete toplevel module names.- -- ghc exports tons of toplevel modules that you probably don't want.- -- Cabal is probably mostly used in Setup.hs and exports Distribution.Text.- ([], ["haskell98", "ghc", "Cabal"])- (map Types.ModuleName [], map Types.ModuleName ["GHC"])- -- * pick candidates --- | Prefer local modules that share prefix with the module path, then prefer--- local modules to ones from packages, then prefer modules from the packages--- in packagePriority. If all else is equal alphabetize so at least the--- order is predictable.-makePickModule :: Priorities -> FilePath+pickModule :: Priorities -> FilePath -> [(Maybe Index.Package, Types.ModuleName)] -> Maybe (Maybe Index.Package, Types.ModuleName)-makePickModule prios modulePath candidates =- Util.head $ Util.sortOn (uncurry (prioritize prios modulePath)) $+pickModule prios modulePath candidates =+ Util.minimumOn (uncurry (prioritize prios modulePath)) $ -- Don't pick myself! filter ((/= Types.pathToModule modulePath) . snd) candidates -prioritize :: Priorities -> FilePath -> Maybe String -> Types.ModuleName- -> ((Int, Int), (Int, Int), String)+-- | 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 =- ( packagePrio (prioPackage prios) mbPackage- , (modulePrio (prioModule prios) mod, dots mod)+ ( modulePrio (prioModule prios) mod+ , localPrio mbPackage+ , packagePrio (prioPackage prios) mbPackage+ , length $ filter (=='.') $ Types.moduleName mod , Types.moduleName mod ) where- packagePrio _ Nothing = (localPrio modulePath mod, 0)- packagePrio (high, low) (Just pack) = (1, searchPrio high low pack)- modulePrio (high, low) =+ 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- dots = length . filter (=='.') . 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-localPrio :: FilePath -> Types.ModuleName -> Int-localPrio modulePath mod = negate $ length $ takeWhile id $ zipWith (==)+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 (`List.isPrefixOf` mod) high of+searchPrio high low mod = case List.findIndex (== mod) high of Just n -> - length high + n- Nothing -> maybe 0 (+1) (List.findIndex (`List.isPrefixOf` mod) low)+ Nothing -> maybe 0 (+1) (List.findIndex (== mod) low) -- * format imports --- | Print out the imports with spacing how I like it.-formatImports :: [Types.ImportLine] -> String-formatImports imports = unlines $- map showImport (sort package) ++ [""] ++ map showImport (sort local)- where- sort = Util.sortOn Types.importModule- (local, package) = List.partition Types.importIsLocal 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.@@ -130,27 +336,33 @@ -- -- An unqualified import will follow a qualified one. The Prelude, if -- imported, always goes first.-formatGroups :: ImportOrder -> [Types.ImportLine] -> String-formatGroups order imports =+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 imp =- ( name imp /= prelude- , name imp- , qualifiedPrio imp+ packagePrio import_ =+ ( name import_ /= prelude+ , name import_+ , qualifiedPrio import_ )- localPrio imp =- ( localPriority order (topModule imp)- , name imp- , qualifiedPrio imp+ localPrio import_ =+ ( localPriority (_importOrder order) (Types.importModule import_)+ , name import_+ , qualifiedPrio import_ ) qualifiedPrio = not . qualifiedImport name = Types.importModule- (local, package) = List.partition Types.importIsLocal imports- group = collapse . Util.groupOn topModule+ (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)@@ -158,34 +370,131 @@ [] -> [x] y : ys -> (x ++ y) : ys | otherwise = x : collapse xs- showGroups = List.intercalate [""] . map (map showImport)+ 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.-localPriority :: ImportOrder -> String -> (Int, Maybe Int)-localPriority order importTop = case List.elemIndex importTop firsts of- Just k -> (-1, Just k)- Nothing -> case List.elemIndex importTop lasts of- Nothing -> (0, Nothing)- Just k -> (1, Just k)+--+-- 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 = map Types.moduleName (importFirst order)- lasts = map Types.moduleName (importLast order)+ firsts = high prio+ lasts = low prio qualifiedImport :: Types.ImportLine -> Bool qualifiedImport = Haskell.importQualified . Types.importDecl -showImport :: Types.ImportLine -> String-showImport (Types.ImportLine imp cmts _) =- above ++ importLine ++ (if null right then "" else ' ' : right)+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]- importLine = Haskell.prettyPrintStyleMode style mode imp right = Util.join "\n" [cmt | Types.Comment Types.CmtRight cmt <- cmts]++showImportDecl :: Format -> Types.ImportDecl -> String+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 = 80 , Haskell.ribbonsPerLine = 1 }- mode = Haskell.defaultMode++prettyImportDecl :: PPConfig -> Haskell.ImportDecl a -> PP.Doc+prettyImportDecl config+ (Haskell.ImportDecl _ m qual src safe mbPkg mbName mbSpecs) = do+ PP.hsep+ [ "import"+ , if qual || not (_leaveSpaceForQualified config) 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.hsep . PP.punctuate PP.comma++pretty :: Haskell.Pretty a => a -> PP.Doc+pretty _ = "?"+++-- * 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
+ src/Config_test.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+module Config_test where+import qualified Data.Map as Map+import qualified Data.Text as Text+import EL.Test.Global+import qualified EL.Test.Testing as Testing+import qualified Language.Haskell.Exts as Haskell++import qualified Config+import qualified FixImports+import qualified Types+++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._ppConfig = Just $ Config.PPConfig+ { _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)"++-- * 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)
src/FixImports.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} {- | Automatically fix the import list in a haskell module. This only really works for qualified names. The process is as follows:@@ -35,13 +34,16 @@ 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.Arrow as Arrow-import qualified Control.Exception as Exception-import Control.Monad-+import qualified Control.DeepSeq as DeepSeq+import Data.Bifunctor (first) import qualified Data.Char as Char import qualified Data.Either as Either import qualified Data.Generics.Uniplate.Data as Uniplate@@ -49,105 +51,67 @@ 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 System.Console.GetOpt as GetOpt+import qualified Numeric import qualified System.Directory as Directory-import qualified System.Environment-import qualified System.Exit import qualified System.FilePath as FilePath import System.FilePath ((</>))-import qualified System.IO as IO-import qualified System.Process as Process import qualified Config import qualified Index import qualified Types import qualified Util +import Control.Monad -runMain :: Config.Config -> IO ()-runMain config = 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, (verbose, includes)) <-- parseArgs =<< System.Environment.getArgs- text <- IO.getContents- config <- return $ config- { Config.includes = includes ++ Config.includes config }- fixed <- fixModule config modulePath text- `Exception.catch` (\(exc :: Exception.SomeException) ->- return $ Left $ "exception: " ++ show exc)- case fixed of- Left err -> do- IO.putStr text- IO.hPutStrLn IO.stderr $ "error: " ++ err- System.Exit.exitFailure- Right (Result text added removed) -> do- IO.putStr text- let names = Util.join ", " . map Types.moduleName . Set.toList- (addedMsg, removedMsg) = (names added, names removed)- 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- ]- System.Exit.exitSuccess -data Flag = Verbose | Include String- deriving (Eq, Show)--options :: [GetOpt.OptDescr Flag]-options =- [ GetOpt.Option ['v'] [] (GetOpt.NoArg Verbose)- "print added and removed modules on stderr"- , GetOpt.Option ['i'] [] (GetOpt.ReqArg Include "path")- "add to module include path"- ]--usage :: String -> IO a-usage msg = do- name <- System.Environment.getProgName- putStr $ GetOpt.usageInfo (msg ++ "\n" ++ name ++ " Module.hs <Module.hs")- options- System.Exit.exitFailure--parseArgs :: [String] -> IO (String, (Bool, [FilePath]))-parseArgs args = case GetOpt.getOpt GetOpt.Permute options args of- (flags, [modulePath], []) -> return (modulePath, parse flags)- (_, [], errs) -> usage $ concat errs- _ -> usage "too many args"- where parse flags = (Verbose `elem` flags, "." : [p | Include p <- flags])- -- Includes always have the current directory first.- data Result = Result { resultText :: String , resultAdded :: Set.Set Types.ModuleName , resultRemoved :: Set.Set Types.ModuleName+ , resultMetrics :: [Metric] } deriving (Show) -fixModule :: Config.Config -> FilePath -> String- -> IO (Either String Result)-fixModule config modulePath text = do- processed <- cppModule modulePath text- case parse processed of+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)+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) ->- fixImports config modulePath mod cmts text- where- parse = Haskell.parseFileContentsWithComments $ Haskell.defaultParseMode+ Haskell.ParseOk (mod, cmts) -> do+ mParse <- metric (mod `seq` (), cmts) "parse"+ index <- Index.load+ mLoad <- metric () "load-index"+ fmap (addMetrics [mStart, mCpp, mParse, mLoad]) <$>+ fixImports ioFilesystem config index modulePath mod cmts source++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 = Config.language config- ++ defaultExtensions+ , 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@@ -158,9 +122,9 @@ -- | 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.--- Serves you right anyway.+-- It seems hard to fix imports inside CPP. cppModule :: FilePath -> String -> IO String-cppModule filename s = Cpphs.runCpphs options filename s+cppModule filename = Cpphs.runCpphs options filename where options = Cpphs.defaultCpphsOptions { Cpphs.boolopts = boolOpts } boolOpts = Cpphs.defaultBoolOptions@@ -173,22 +137,48 @@ , Cpphs.lang = True -- lex input as haskell code , Cpphs.ansi = True , Cpphs.layout = True- , Cpphs.literate = False -- untested with literate code + , 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+ }+ -- | 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 :: Config.Config -> FilePath -> Types.Module- -> [Haskell.Comment] -> String -> IO (Either String Result)-fixImports config modulePath mod cmts text = do- -- Don't bother loading the index if I'm not going to use it.- -- TODO actually, only load it if I don't find local imports- -- I guess Data.Binary's laziness will serve me there- index <- if Set.null newImports then return Index.empty else Index.load- mbNew <- mapM (mkImportLine config modulePath index) (Set.toList newImports)- mbExisting <- mapM (findImport (Config.includes config)) imports+fixImports :: Monad m => Filesystem m -> Config.Config -> Index.Index+ -> FilePath -> Types.Module -> [Haskell.Comment] -> String+ -> m (Either String Result)+fixImports fs config index modulePath mod cmts source = do+ let (newImports, unusedImports, imports, range) = importInfo mod cmts+ mProcess <- _metric fs+ (length newImports, length unusedImports, length imports, range)+ "process"+ mbNew <- mapM (findNewImport fs config modulePath index)+ (Set.toList newImports)+ mNewImports <- _metric fs mbNew "find-new-imports"+ (imports, newUnqualImports, unusedUnqual) <- return $+ fixUnqualified config mod imports+ newUnqualImports <- mapM (locateImport fs) newUnqualImports+ mUnqual <- _metric fs newUnqualImports "unqualified-imports"+ mbExisting <- mapM (findImport fs index (Config._includes config)) imports+ mExistingImports <- _metric fs mbExisting "find-existing-imports" let existing = map (Types.importDeclModule . fst) imports let (notFound, importLines) = Either.partitionEithers $ zipWith mkError@@ -196,89 +186,246 @@ (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 $ "modules not found: "+ _ : _ -> Left $ "not found: " ++ Util.join ", " (map Types.moduleName notFound) [] -> Right $ Result- (substituteImports (showImports importLines) range text)- (Set.fromList (map (Types.importDeclModule . Types.importDecl)- (Maybe.catMaybes mbNew)))- unusedImports+ { resultText = substituteImports formattedImports range source+ , resultAdded = Set.fromList $+ map (Types.importDeclModule . Types.importDecl) $+ Maybe.catMaybes mbNew ++ newUnqualImports+ , resultRemoved = unusedImports <> Set.fromList unusedUnqual+ , resultMetrics =+ [mProcess, mNewImports, mExistingImports, mUnqual]+ } where- (newImports, unusedImports, imports, range) = importInfo mod cmts toModule (Types.Qualification name) = Types.ModuleName name- showImports = Config.showImports config +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) text =+substituteImports imports (start, end) source = unlines pre ++ imports ++ unlines post where- (pre, within) = splitAt start (lines text)+ (pre, within) = splitAt start (lines source) (_, post) = splitAt (end-start) within -- * find new imports -- | Make a new ImportLine from a ModuleName.-mkImportLine :: Config.Config -> FilePath -> Index.Index -> Types.Qualification- -> IO (Maybe Types.ImportLine)-mkImportLine config modulePath index qual@(Types.Qualification name) = do- found <- findModule config index modulePath qual- return $ case found of- Nothing -> Nothing- Just (mod, local) -> Just (Types.ImportLine (mkImport mod) [] local)+findNewImport :: Monad m => Filesystem m -> Config.Config -> FilePath+ -> Index.Index -> Types.Qualification+ -> 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- mkImport (Types.ModuleName mod) = Haskell.ImportDecl- { Haskell.importAnn = empty- , Haskell.importModule = Haskell.ModuleName empty mod- , Haskell.importQualified = True+ 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 = importAs mod- , Haskell.importSpecs = Nothing+ , Haskell.importAs = Haskell.ModuleName noSpan <$> importAs+ , Haskell.importSpecs = if withImportList+ then Just $ Haskell.ImportSpecList noSpan False []+ else Nothing }- importAs mod- | name == mod = Nothing- | otherwise = Just $ Haskell.ModuleName empty name- empty = Haskell.noInfoSpan (Haskell.SrcSpan "" 0 0 0 0)+ where+ importAs+ -- | Just (Types.Qualification importAs) <- mbImportAs = Just importAs+ | Just (Types.Qualification q) <- qualification, q /= name = Just q+ | otherwise = Nothing --- | Find the qualification and its ModuleName and True if it was a local--- import. Nothing if it wasn't found at all.-findModule :: Config.Config -> Index.Index -> FilePath- -- ^ Path to the module being fixed.- -> Types.Qualification -> IO (Maybe (Types.ModuleName, Bool))-findModule config index modulePath qual = do- found <- findLocalModules (Config.includes config) qual- let local = [(Nothing, Types.pathToModule fn) | fn <- found]- package = map (Arrow.first Just) $ Map.findWithDefault [] qual index- -- clunky- return $ case Config.pickModule config modulePath (local++package) of- Just (package, mod) -> Just (mod, package == 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 -> 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+ -- Config.debug config $ "findModule " <> showt qual <> " from "+ -- <> showt modulePath <> ": local " <> showt found+ -- <> "\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 :: [FilePath] -> Types.Qualification -> IO [FilePath]-findLocalModules includes (Types.Qualification name) = do- concat <$> forM includes (\dir -> map (stripDir dir) <$>- findFiles 4 (Types.moduleToPath (Types.ModuleName name)) dir)+findLocalModules :: Monad m => Filesystem m -> [FilePath]+ -> Types.Qualification -> m [FilePath]+findLocalModules fs includes (Types.Qualification name) =+ fmap concat . forM includes $ \dir -> map (stripDir dir) <$>+ findFiles fs 4 (Types.moduleToPath (Types.ModuleName name)) dir stripDir :: FilePath -> FilePath -> FilePath stripDir dir path | dir == "." = path | otherwise = dropWhile (=='/') $ drop (length dir) path -findFiles :: Int -- ^ Descend into subdirectories this many times.+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.- -> IO [FilePath]-findFiles depth file dir = do- fns <- Maybe.fromMaybe [] <$> Util.catchENOENT (Util.listDir dir)- (subdirs, fns) <- Util.partitionM Directory.doesDirectoryExist fns+ -> m [FilePath]+findFiles fs depth file dir = do+ (subdirs, fns) <- _listDir fs dir subfns <- if depth > 0- then concat <$> mapM (findFiles (depth-1) file)+ then concat <$> mapM (findFiles fs (depth-1) file) (filter isModuleDir subdirs) else return [] return $ filter sameSuffix fns ++ subfns@@ -291,38 +438,47 @@ -- | Make an existing import into an ImportLine by finding out if it's a local -- module or a package module.-findImport :: [FilePath] -> (Types.ImportDecl, [Types.Comment])- -> IO (Maybe Types.ImportLine)-findImport includes (imp, cmts) = do- found <- findModuleName includes (Types.importDeclModule imp)+findImport :: Monad m => Filesystem m -> Index.Index -> [FilePath] -> ImportLine+ -> 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 local -> Just $ Types.ImportLine imp cmts local+ 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 :: [FilePath] -> Types.ModuleName -> IO (Maybe Bool)-findModuleName includes mod =- Util.ifM (isLocalModule mod ("" : includes)) (return (Just True)) $- Util.ifM (isPackageModule mod) (return (Just False))- (return Nothing)+findModuleName :: Monad m => Filesystem m -> Index.Index -> [FilePath]+ -> Types.ModuleName -> m (Maybe Types.Source)+findModuleName fs index includes mod = do+ isLocal <- isLocalModule fs mod ("" : includes)+ return $+ if isLocal then Just Types.Local+ else if isPackageModule index mod then Just Types.Package+ else Nothing -isLocalModule :: Types.ModuleName -> [FilePath] -> IO Bool-isLocalModule mod =- Util.anyM (Directory.doesFileExist . (</> Types.moduleToPath mod))+isLocalModule :: Monad m => Filesystem m -> Types.ModuleName -> [FilePath]+ -> m Bool+isLocalModule fs mod =+ Util.anyM (_doesFileExist fs . (</> Types.moduleToPath mod)) -isPackageModule :: Types.ModuleName -> IO Bool-isPackageModule (Types.ModuleName name) = do- output <- Process.readProcess "ghc-pkg"- ["--simple-output", "find-module", name] ""- return $ not (null output)+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,- [(Types.ImportDecl, [Types.Comment])], (Int, Int))- -- ^ (missingImports, unusedImports, unchangedImports, rangeOfImportBlock).+ -> ( 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)@@ -339,8 +495,9 @@ used = Set.fromList (moduleQNames mod) imports = moduleImportDecls mod declCmts =- [ imp | imp@(decl, _)- <- associateComments imports (filterImportCmts range cmts)+ [ imp+ | imp@(decl, _) <- associateComments imports+ (filterImportCmts range cmts) , keepImport decl ] -- Keep unqualified imports, but only keep qualified ones if they are used.@@ -367,8 +524,7 @@ -- 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]- -> [(Types.ImportDecl, [Types.Comment])]+associateComments :: [Types.ImportDecl] -> [Haskell.Comment] -> [ImportLine] associateComments imports cmts = snd $ List.mapAccumL associate cmts imports where associate cmts imp = (after, (imp, associated))@@ -420,5 +576,54 @@ -- | Uniplate is rad. moduleQNames :: Types.Module -> [Types.Qualification]-moduleQNames mod = [Types.moduleToQualification m- | Haskell.Qual _ m _ <- Uniplate.universeBi mod]+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
src/FixImports_test.hs view
@@ -1,56 +1,247 @@--- | Grody hand-testing because I'm too lazy to libraryize the test framework--- just for this.+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-} module FixImports_test where-import qualified Language.Haskell.Exts.Annotated as Haskell+import Control.Monad (unless, void)+import qualified Control.Monad.Identity as Identity+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 -importRange :: String -> Either String (Int, Int)-importRange modText = do- (mod, cmts) <- parse modText- return $ FixImports.importRange mod -cmtsInRange :: String -> Either String [Haskell.Comment]-cmtsInRange modText = do- (mod, cmts) <- parse modText- return $ FixImports.filterImportCmts (FixImports.importRange mod) cmts+test_simple = do+ let run config = fmap FixImports.resultText+ . 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\+ \x = B.c\n"+ equal (run "" "x = A.B.c") $ Right+ "import qualified A.B\n\+ \x = A.B.c\n"+ leftLike (run "" "x = Q.c") "not found: Q"+ -- Remove unused.+ equal (run "" "import qualified A.B as B\n\nx = y") $ Right+ "\nx = y\n"+ -- Unless it's unqualified.+ equal (run "" "import A.B as B\n\nx = y") $ Right+ "import A.B as B\n\nx = y\n" -parse :: String -> Either String (Types.Module, [Haskell.Comment])-parse text = case Haskell.parseFileContentsWithComments mode text of- Haskell.ParseFailed srcloc err ->- Left $ Haskell.prettyPrint srcloc ++ ": " ++ err- Haskell.ParseOk (mod, comments) -> Right (mod, comments)- where mode = Haskell.defaultParseMode+ -- 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\+ \x = (B.a, C.a, Z.a)\n" -findModule :: [FilePath] -> FilePath -> String- -> IO (Maybe (Types.ModuleName, Bool))-findModule includes modulePath qual = do- index <- Index.loadIndex (Config.configIndex (Config.defaultConfig []))- FixImports.findModule includes index modulePath (Types.Qualification qual)+ -- 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" --- TODO quasi-quoting has a nicer way for multi-line strings, right?-tmod0 = "-- cmt1\n\-\-- cmt2\n\-\import Data.List\n\-\x = 42\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\nx = DTL.y\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\nx = DTL.y\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\nx = DTL.y\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\+ \x = (c, 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\+ \x = (c, c)\n"+ )+ equal (run "unqualified: A.B (a, c)" "import A.B (a, c)\nx = a") $+ Right ([], [],+ "import A.B (a)\n\+ \x = a\n"+ )+ -- Don't accumulate duplicates.+ equal (run "unqualified: A.B (c)" "import A.B (c)\nx = c") $+ Right ([], [], "import A.B (c)\nx = c\n")+ equal (run "unqualified: A.B (C)" "import A.B (C)\nx :: C") $+ Right ([], [],+ "import A.B (C)\n\+ \x :: 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\+ \x = a\n"+ )++ -- Don't import when it's an assignee.+ equal (run "unqualified: A.B (c)" "c = x") $ Right ([], [], "c = x\n")+ equal (run "unqualified: A.B ((</>))" "x = a </> b") $ Right (["A.B"], [],+ "import A.B ((</>))\n\+ \x = a </> b\n"+ )++ -- Removed unused.+ equal (run "unqualified: A.B (c)" "import A.B (c)\nx = x\n") $+ Right ([], ["A.B"], "x = x\n")+ -- 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\nx = x\n")++eResult :: FixImports.Result -> ([Types.ModuleName], [Types.ModuleName], String)+eResult r =+ ( Set.toList (FixImports.resultAdded r)+ , Set.toList (FixImports.resultRemoved r)+ , FixImports.resultText 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) -> Identity.runIdentity $+ FixImports.fixImports (pureFilesystem files) config index+ modulePath mod cmts source++-- | 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++tmod0 :: String+tmod0 =+ "-- cmt1\n\+ \-- cmt2\n\+ \import Data.List\n\+ \x = 42\n"+ tmod1 = "module Foo\nwhere\n" ++ tmod0 tmod2 = "module Foo\nwhere\nx = 42\n" -tmod = "{-# LANGUAGE SomeExtension #-} -- comment on LANGUAGE\n\-\-- cmt1 for Data.List\n\-\-- cmt2 for Data.List\n\-\import qualified Data.List as C\n\-\-- cmt1 for Util\n\-\-- cmt2 for Util\n\-\import qualified Util -- cmt right of Util\n\-\import qualified Extra as Biz {- block cmt -}\n\-\import Data.Map (a,\n\-\ b)\n\-\\n\-\f :: Util.One -> Midi.New.Two -> Util.Foo -> C.Result\n\-\f x = x * C.z\n"+tmod :: String+tmod =+ "{-# LANGUAGE SomeExtension #-} -- comment on LANGUAGE\n\+ \-- cmt1 for Data.List\n\+ \-- cmt2 for Data.List\n\+ \import qualified Data.List as C\n\+ \-- cmt1 for Util\n\+ \-- cmt2 for Util\n\+ \import qualified Util -- cmt right of Util\n\+ \import qualified Extra as Biz {- block cmt -}\n\+ \import Data.Map (a,\n\+ \ b)\n\+ \\n\+ \f :: Util.One -> Midi.New.Two -> Util.Foo -> C.Result\n\+ \f x = x * C.z\n"++-- * 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
src/Index.hs view
@@ -1,7 +1,7 @@ {-# 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, parseSections) where+module Index (Index, Package, empty, load, makeIndex, parseSections) where import Prelude hiding (mod) import Control.Monad import qualified Data.Either as Either@@ -45,12 +45,18 @@ ++ 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, index)+parseDump text = (errors, makeIndex packages) where- index = Map.fromListWith (++)- [(qual, [(T.unpack package, mod)]) | (package, modules) <- packages,- mod <- modules, qual <- moduleQualifications mod] (errors, packages) = Either.partitionEithers $ extractSections (parseSections text) @@ -58,8 +64,10 @@ -> [Either String (Text, [Types.ModuleName])] extractSections = Maybe.mapMaybe extract . Util.splitWith ((=="name") . fst) where- extract [("name", [name]), ("exposed", [exposed]),- ("exposed-modules", modules)]+ extract [ ("name", [name])+ , ("exposed", [exposed])+ , ("exposed-modules", modules)+ ] | exposed /= "True" = Nothing | otherwise = Just $ Right (name, map (Types.ModuleName . T.unpack) modules)
src/Main.hs view
@@ -2,59 +2,107 @@ -- a config file from the current directory. -- -- More documentation in "FixImports".+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where-import qualified Data.List as List-import qualified Data.Map as Map+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 Index+import qualified Paths_fix_imports import qualified Types import qualified Util main :: IO () main = do- (config, errors) <- fmap (maybe (Config.empty, []) parse) $- Util.catchENOENT $ Text.IO.readFile ".fix-imports"- mapM_ (IO.hPutStrLn IO.stderr) errors- FixImports.runMain config+ (config, errors) <- readConfig ".fix-imports"+ if null errors+ then mainConfig config+ else do+ IO.putStr =<< IO.getContents+ mapM_ (Text.IO.hPutStrLn IO.stderr) errors+ Exit.exitFailure -parse :: Text.Text -> (Config.Config, [String])-parse text = (config, errors)- where- commas = List.intercalate ", "- errors =- [ ".fix-imports has unrecognized fields: "- ++ commas unknownFields | not (null unknownFields) ]- ++ [ ".fix-imports has unknown language extensions: "- ++ commas unknownLanguage | not (null unknownLanguage) ]- config = Config.empty- { Config.includes = get "include"- , Config.language = language- , Config.showImports = Config.formatGroups order- , Config.pickModule = Config.makePickModule prios- }- (unknownLanguage, language) = Config.parseLanguage (get "language")- unknownFields = Map.keys fields List.\\ valid- valid =- [ "include"- , "import-order-first", "import-order-last"- , "prio-package-high", "prio-package-low"- , "prio-module-high", "prio-module-low"- , "language"- ]- order = Config.ImportOrder- { Config.importFirst = getModules "import-order-first"- , Config.importLast = getModules "import-order-last"+readConfig :: FilePath -> IO (Config.Config, [Text.Text])+readConfig = fmap (maybe (Config.empty, []) Config.parse)+ . Util.catchENOENT . Text.IO.readFile++mainConfig :: Config.Config -> IO ()+mainConfig config = 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, (verbose, debug, includes)) <-+ parseArgs =<< Environment.getArgs+ source <- IO.getContents+ config <- return $ config+ { Config._includes = includes ++ Config._includes config+ , Config._debug = debug }- prios = Config.Priorities (get "prio-package-high", get "prio-package-low")- (getModules "prio-module-high", getModules "prio-module-low")- fields = Map.fromList [(Text.unpack section, map Text.unpack words)- | (section, words) <- Index.parseSections text]- getModules = map Types.ModuleName . get- get k = Map.findWithDefault [] k fields+ fixed <- FixImports.fixModule config modulePath source+ `Exception.catch` (\(exc :: Exception.SomeException) ->+ return $ Left $ "exception: " ++ show exc)+ case fixed of+ Left err -> do+ IO.putStr source+ IO.hPutStrLn IO.stderr $ "error: " ++ err+ Exit.exitFailure+ Right (FixImports.Result source added removed metrics) -> do+ IO.putStr source+ let names = Util.join ", " . map Types.moduleName . Set.toList+ (addedMsg, removedMsg) = (names added, names removed)+ mDone <- FixImports.metric metrics "done"+ 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 = Debug | Include String | Verbose+ deriving (Eq, Show)++options :: [GetOpt.OptDescr Flag]+options =+ [ 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"+ ]++usage :: String -> IO a+usage msg = do+ name <- Environment.getProgName+ putStr $ GetOpt.usageInfo (msg ++ "\n" ++ name ++ " Module.hs <Module.hs")+ options+ putStrLn $ "version: " ++ Version.showVersion Paths_fix_imports.version+ Exit.exitFailure++parseArgs :: [String] -> IO (String, (Bool, Bool, [FilePath]))+parseArgs args = case GetOpt.getOpt GetOpt.Permute options args of+ (flags, [modulePath], []) -> return (modulePath, parse flags)+ (_, [], errs) -> usage $ concat errs+ _ -> usage "too many args"+ where+ parse flags =+ ( Verbose `elem` flags+ , Debug `elem` flags+ , "." : [p | Include p <- flags]+ )+ -- Includes always have the current directory first.
+ src/RunTests.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF test-karya-generate #-}
src/Types.hs view
@@ -1,28 +1,50 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Types where+import qualified Control.DeepSeq as DeepSeq+import Control.DeepSeq (deepseq)+import qualified Data.String as String import qualified Language.Haskell.Exts as Haskell import qualified System.FilePath as FilePath +instance DeepSeq.NFData Haskell.Comment where+ rnf (Haskell.Comment bool srcspan str) =+ bool `seq` srcspan `seq` str `deepseq` ()+ data ImportLine = ImportLine {- importDecl :: ImportDecl- , importComments :: [Comment]- , importIsLocal :: Bool+ importDecl :: !ImportDecl+ , importComments :: ![Comment]+ , importSource :: !Source } deriving (Show) +instance DeepSeq.NFData ImportLine where+ rnf (ImportLine decl cmts source) =+ decl `seq` cmts `deepseq` source `seq` ()++-- | Where did this import come from?+data Source = Local | Package deriving (Eq, Show)+ -- | A Comment is associated with a particular import line.-data Comment = Comment CmtPos String deriving (Show)+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` ()++-- | A parsed import line. type ImportDecl = Haskell.ImportDecl Haskell.SrcSpanInfo type Module = Haskell.Module Haskell.SrcSpanInfo -- | 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)+ deriving (Eq, Ord, Show, String.IsString) +-- | An unqualified identifier.+type Name = Haskell.Name Haskell.SrcSpanInfo+ newtype ModuleName = ModuleName String- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, DeepSeq.NFData, String.IsString) moduleName :: ModuleName -> String moduleName (ModuleName n) = n
src/Util.hs view
@@ -1,13 +1,17 @@ module Util where-import Prelude hiding (head, join)+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 @@ -19,8 +23,44 @@ 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+ || isSymbolCharacterCategory (Char.generalCategory c)+ where+ opChars :: IntSet.IntSet+ opChars = 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@@ -48,9 +88,46 @@ 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 :: Monad m => m Bool -> m a -> m a -> m a ifM cond consequent alternative = do b <- cond if b then consequent else alternative@@ -61,7 +138,7 @@ 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 :: (a -> IO Bool) -> [a] -> IO Bool+anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM _ [] = return False anyM f (x:xs) = ifM (f x) (return True) (anyM f xs)