packages feed

fix-imports 2.3.0 → 2.4.0

raw patch · 25 files changed

+2749/−2059 lines, 25 filesdep +Cabaldep +ghc-lib-parserdep +ghc-lib-parser-exdep −haskell-src-exts

Dependencies added: Cabal, ghc-lib-parser, ghc-lib-parser-ex, ghc-paths

Dependencies removed: haskell-src-exts

Files

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