diff --git a/fix-imports.cabal b/fix-imports.cabal --- a/fix-imports.cabal +++ b/fix-imports.cabal @@ -1,5 +1,5 @@ name: fix-imports -version: 1.0.4 +version: 1.0.5 cabal-version: >= 1.6 build-type: Simple synopsis: Program to manage the imports of a haskell module @@ -12,36 +12,6 @@ . It's most convenient if bound to an editor key. . - Recent major changes: - * version 1.0.3 and 1.0.4 - . - * upgrade to haskell-src-exts-1.16 - . - * version 1.0.2 - . - * Fix bug where a qualified import with >1 dot wasn't found. And don't - mess with Prelude. - . - * version 1.0.1 - . - * Fix a bunch of bugs: properly recognize unqualified imports as imports, - never import the current module, don't pick up modules with the same suffix - but a different name. - . - * version 1.0.0 - . - * Change name from FixImports to fix-imports, which is more unixy. - . - * Change ghc-pkg parsing from String to Text. It's noticeably faster. - . - * Add a more flexible system for prioritizing imports. - When there are several possibilities for a module name, they are all given - to a single function to decide. The config file moved from - fix-imports-priority to .fix-imports and can now specify sort orders for - packages and modules by prefix. - . - * Make -i includes for non-existent dirs ignored instead of causing an - error. category: Editor, Haskell, IDE license: BSD3 @@ -61,6 +31,6 @@ main-is: Main.hs hs-source-dirs: src build-depends: base >= 3 && < 5, containers, directory, filepath, process - , haskell-src-exts >= 1.16.0 && < 1.17 + , haskell-src-exts >= 1.16.0 , uniplate, split, cpphs, text ghc-options: -Wall -fno-warn-name-shadowing diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -4,8 +4,10 @@ -- -- TODO dyre does this sort of thing module Config where +import qualified Data.Either as Either import qualified Data.List as List -import qualified Language.Haskell.Exts.Annotated as Haskell +import qualified Language.Haskell.Exts as Haskell +import qualified Language.Haskell.Exts.Extension as Extension import qualified System.FilePath as FilePath import qualified Index @@ -16,20 +18,23 @@ data Config = Config { -- | Additional directories to search for local modules. Taken from the -- -i flag and 'include' config line. - configIncludes :: [FilePath] + includes :: [FilePath] + -- | These language extensions are enabled by default. + , language :: [Extension.Extension] -- | Format the import block. - , configShowImports :: [Types.ImportLine] -> String + , showImports :: [Types.ImportLine] -> String -- | Often multiple modules from the package index will match -- a qualification. Apply some heuristics to pick the most likely one. - , configPickModule :: FilePath -> [(Maybe Index.Package, Types.ModuleName)] + , pickModule :: FilePath -> [(Maybe Index.Package, Types.ModuleName)] -> Maybe (Maybe Index.Package, Types.ModuleName) } -config :: [FilePath] -> ImportOrder -> Priorities -> Config -config include order prios = Config - { configIncludes = include - , configShowImports = formatGroups order - , configPickModule = pickModule prios +empty :: Config +empty = Config + { includes = [] + , language = [] + , showImports = formatGroups $ ImportOrder [] + , pickModule = makePickModule defaultPriorities } data Priorities = Priorities { @@ -43,6 +48,12 @@ newtype ImportOrder = ImportOrder [Types.ModuleName] deriving (Show) +parseLanguage :: [String] -> ([String], [Extension.Extension]) +parseLanguage = Either.partitionEithers . map parse + where + parse w = case Extension.parseExtension w of + Extension.UnknownExtension _ -> Left w + ext -> Right ext defaultPriorities :: Priorities defaultPriorities = Priorities @@ -60,10 +71,10 @@ -- local modules to ones from packages, then prefer modules from the packages -- in packagePriority. If all else is equal alphabetize so at least the -- order is predictable. -pickModule :: Priorities -> FilePath +makePickModule :: Priorities -> FilePath -> [(Maybe Index.Package, Types.ModuleName)] -> Maybe (Maybe Index.Package, Types.ModuleName) -pickModule prios modulePath candidates = +makePickModule prios modulePath candidates = Util.head $ Util.sortOn (uncurry (prioritize prios modulePath)) $ -- Don't pick myself! filter ((/= Types.pathToModule modulePath) . snd) candidates diff --git a/src/FixImports.hs b/src/FixImports.hs --- a/src/FixImports.hs +++ b/src/FixImports.hs @@ -50,7 +50,7 @@ import qualified Data.Maybe as Maybe import qualified Data.Set as Set -import qualified Language.Haskell.Exts.Annotated as Haskell +import qualified Language.Haskell.Exts as Haskell import qualified Language.Haskell.Exts.Extension as Extension import qualified Language.Preprocessor.Cpphs as Cpphs @@ -78,7 +78,7 @@ parseArgs =<< System.Environment.getArgs text <- IO.getContents config <- return $ config - { Config.configIncludes = includes ++ Config.configIncludes config } + { Config.includes = includes ++ Config.includes config } fixed <- fixModule config modulePath text `Exception.catch` (\(exc :: Exception.SomeException) -> return $ Left $ "exception: " ++ show exc) @@ -140,19 +140,20 @@ Haskell.ParseOk (mod, cmts) -> fixImports config modulePath mod cmts text where - parse = Haskell.parseFileContentsWithComments $ - Haskell.defaultParseMode - { Haskell.parseFilename = modulePath - , Haskell.extensions = 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 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 - } + parse = Haskell.parseFileContentsWithComments $ Haskell.defaultParseMode + { Haskell.parseFilename = modulePath + , Haskell.extensions = Config.language config + ++ 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 + } + 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 @@ -185,9 +186,9 @@ -- Don't bother loading the index if I'm not going to use it. -- TODO actually, only load it if I don't find local imports -- I guess Data.Binary's laziness will serve me there - index <- if Set.null newImports then return Index.empty else Index.loadIndex + index <- if Set.null newImports then return Index.empty else Index.load mbNew <- mapM (mkImportLine config modulePath index) (Set.toList newImports) - mbExisting <- mapM (findImport (Config.configIncludes config)) imports + mbExisting <- mapM (findImport (Config.includes config)) imports let existing = map (Types.importDeclModule . fst) imports let (notFound, importLines) = Either.partitionEithers $ zipWith mkError @@ -206,7 +207,7 @@ where (newImports, unusedImports, imports, range) = importInfo mod cmts toModule (Types.Qualification name) = Types.ModuleName name - showImports = Config.configShowImports config + showImports = Config.showImports config -- | Clip out the range from the given text and replace it with the given -- lines. @@ -249,11 +250,11 @@ -- ^ Path to the module being fixed. -> Types.Qualification -> IO (Maybe (Types.ModuleName, Bool)) findModule config index modulePath qual = do - found <- findLocalModules (Config.configIncludes config) qual + found <- findLocalModules (Config.includes config) qual let local = [(Nothing, Types.pathToModule fn) | fn <- found] package = map (Arrow.first Just) $ Map.findWithDefault [] qual index -- clunky - return $ case Config.configPickModule config modulePath (local++package) of + return $ case Config.pickModule config modulePath (local++package) of Just (package, mod) -> Just (mod, package == Nothing) Nothing -> Nothing diff --git a/src/Index.hs b/src/Index.hs --- a/src/Index.hs +++ b/src/Index.hs @@ -1,13 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -- | Maintain the index from Qualification to the full module from the package -- db that this Qualification probably intends. -module Index where +module Index (Index, Package, empty, load, 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 @@ -29,11 +30,11 @@ empty :: Index empty = Map.empty -loadIndex :: IO Index -loadIndex = buildIndex -- TODO load cache? +load :: IO Index +load = build -- TODO load cache? -buildIndex :: IO Index -buildIndex = do +build :: IO Index +build = do (_, out, err) <- Util.readProcessWithExitCode "ghc-pkg" ["field", "*", "name,exposed,exposed-modules"] unless (T.null err) $ @@ -51,18 +52,20 @@ [(qual, [(T.unpack package, mod)]) | (package, modules) <- packages, mod <- modules, qual <- moduleQualifications mod] (errors, packages) = Either.partitionEithers $ - extractExposed (parseSections text) - extractExposed :: [(Text, [Text])] - -> [Either String (Text, [Types.ModuleName])] - extractExposed [] = [] - extractExposed (("name", [name]) : ("exposed", [exposed]) - : ("exposed-modules", modules) : rest) - | exposed /= "True" = extractExposed rest - | otherwise = Right (name, map (Types.ModuleName . T.unpack) modules) - : extractExposed rest - extractExposed ((tag, _) : rest) = - Left ("unexpected tag: " ++ T.unpack tag) : extractExposed rest + 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] @@ -82,24 +85,3 @@ where (tag, rest) = T.break (==':') x (pre, post) = span (" " `T.isPrefixOf`) xs - -{- --- * test - -t0 = makePairs prio $ map (\(p, ms) -> (p, map Types.ModuleName ms)) - [ ("base", ["Data.List", "Foo.Bar.List"]) - , ("haskell98", ["List"]) - , ("containers", ["Box.List"]) - ] - -- Not containers Box.List because containers is lower prio. - -- Not haskell98 List because haskell98 is lowest prio, even though that's - -- the shortest match. - -- Not Foo.Bar.List because Data.List is a shorter match. - -t1 = Map.lookup (Types.Qualification "List") (Map.fromList t0) -t10 = List.unfoldr parseSection ["hi: there fred", " foo", "next: section"] -tdump = - [ "name: base", "exposed: True", "exposed-modules: Data.List Data.Map" - , "name: mtl", "exposed: True", "exposed-modules: Monad.B.List" - ] --} diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -20,30 +20,38 @@ main :: IO () main = do - let deflt = ([], Config.ImportOrder [], Config.defaultPriorities, []) - (include, order, prios, warns) <- fmap (maybe deflt parse) $ + (config, errors) <- fmap (maybe (Config.empty, []) parse) $ Util.catchENOENT $ Text.IO.readFile ".fix-imports" - unless (null warns) $ - IO.hPutStrLn IO.stderr $ - "warnings unrecognized fields in .fix-imports: " - ++ List.intercalate ", " warns - FixImports.runMain (Config.config include order prios) + mapM_ (IO.hPutStrLn IO.stderr) errors + FixImports.runMain config -parse :: Text.Text - -> ([FilePath], Config.ImportOrder, Config.Priorities, [String]) -parse text = (include, order, prios, extra) +parse :: Text.Text -> (Config.Config, [String]) +parse text = (config, errors) where - extra = Map.keys config List.\\ valid + commas = List.intercalate ", " + errors = + [ ".fix-imports has unrecognized fields: " + ++ commas unknownFields | not (null unknownFields) ] + ++ [ ".fix-imports has unknown language extensions: " + ++ commas unknownLanguage | not (null unknownLanguage) ] + config = Config.empty + { Config.includes = get "include" + , Config.language = language + , Config.showImports = Config.formatGroups order + , Config.pickModule = Config.makePickModule prios + } + (unknownLanguage, language) = Config.parseLanguage (get "language") + unknownFields = Map.keys fields List.\\ valid valid = [ "include", "import-order" , "prio-package-high", "prio-package-low" , "prio-module-high", "prio-module-low" + , "language" ] - include = get "include" order = Config.ImportOrder (getModules "import-order") prios = Config.Priorities (get "prio-package-high", get "prio-package-low") (getModules "prio-module-high", getModules "prio-module-low") - config = Map.fromList [(Text.unpack section, map Text.unpack words) + fields = Map.fromList [(Text.unpack section, map Text.unpack words) | (section, words) <- Index.parseSections text] getModules = map Types.ModuleName . get - get k = Map.findWithDefault [] k config + get k = Map.findWithDefault [] k fields diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,5 +1,5 @@ module Types where -import qualified Language.Haskell.Exts.Annotated as Haskell +import qualified Language.Haskell.Exts as Haskell import qualified System.FilePath as FilePath diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -29,6 +29,15 @@ 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