diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/dot-fix-imports b/dot-fix-imports --- a/dot-fix-imports +++ b/dot-fix-imports @@ -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 diff --git a/fix-imports.cabal b/fix-imports.cabal --- a/fix-imports.cabal +++ b/fix-imports.cabal @@ -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 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 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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 diff --git a/src/Config_test.hs b/src/Config_test.hs new file mode 100644 --- /dev/null +++ b/src/Config_test.hs @@ -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) diff --git a/src/FixImports.hs b/src/FixImports.hs --- a/src/FixImports.hs +++ b/src/FixImports.hs @@ -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 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 diff --git a/src/FixImports_test.hs b/src/FixImports_test.hs --- a/src/FixImports_test.hs +++ b/src/FixImports_test.hs @@ -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 diff --git a/src/Index.hs b/src/Index.hs --- a/src/Index.hs +++ b/src/Index.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 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. diff --git a/src/RunTests.hs b/src/RunTests.hs new file mode 100644 --- /dev/null +++ b/src/RunTests.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF test-karya-generate #-} diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -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)