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: 0.1.3 +version: 1.0.0 cabal-version: >= 1.6 build-type: Simple synopsis: Program to manage the imports of a haskell module @@ -11,13 +11,31 @@ Unqualified imports are left untouched. . It's most convenient if bound to an editor key. + . + Recent major changes: + . + * 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 license-file: LICENSE author: Evan Laforge maintainer: Evan Laforge -stability: experimental +stability: stable tested-with: GHC>=7.0.3 data-files: README, vimrc extra-source-files: src/*.hs @@ -26,9 +44,9 @@ type: darcs location: http://ofb.net/~elaforge/darcs/fix-imports/ -executable FixImports +executable fix-imports main-is: Main.hs hs-source-dirs: src build-depends: base >= 3 && < 5, containers, directory, filepath, process, - haskell-src-exts >= 1.11, uniplate, split, cpphs + haskell-src-exts >= 1.11, 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 @@ -6,26 +6,89 @@ module Config where import qualified Data.List as List import qualified Language.Haskell.Exts.Annotated as Haskell +import qualified System.FilePath as FilePath +import qualified Index import qualified Types import qualified Util -import qualified Index data Config = Config { + -- | Additional directories to search for local modules. Taken from the + -- -i flag. + configIncludes :: [FilePath] -- | Format the import block. - configShowImports :: [Types.ImportLine] -> String - -- | See 'Index.Config'. - , configIndex :: Index.Config + , configShowImports :: [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)] + -> Maybe (Maybe Index.Package, Types.ModuleName) } -defaultConfig :: [String] -> Config -defaultConfig localModules = Config (formatGroups localModules) - (Index.Config packagePriority []) +config :: ImportOrder -> Priorities -> Config +config order prios = Config + { configIncludes = [] + , configShowImports = formatGroups order + , configPickModule = pickModule prios + } -packagePriority :: [String] -packagePriority = ["base", "containers", "directory", "mtl"] +data Priorities = Priorities { + -- | Place these packages either first or last in priority. + prioPackage :: ([Index.Package], [Index.Package]) + -- | Place these modules either first or last in priority. + , prioModule :: ([Types.ModuleName], [Types.ModuleName]) + } deriving (Show) +-- | Sort order for local modules. +newtype ImportOrder = ImportOrder [Types.ModuleName] + deriving (Show) + + +defaultPriorities :: Priorities +defaultPriorities = Priorities + ([], ["haskell98"]) + (map Types.ModuleName [], map Types.ModuleName ["GHC"]) + +-- * pick candidates + +-- | Prefer local modules that share prefix with the module path, then prefer +-- local modules to ones from packages, then prefer modules from the packages +-- in packagePriority. +pickModule :: Priorities -> FilePath + -> [(Maybe Index.Package, Types.ModuleName)] + -> Maybe (Maybe Index.Package, Types.ModuleName) +pickModule prios modulePath candidates = + Util.head $ Util.sortOn (uncurry (prioritize prios modulePath)) candidates + +prioritize :: Priorities -> FilePath -> Maybe String -> Types.ModuleName + -> ((Int, Int), (Int, Int)) +prioritize prios modulePath mbPackage mod = + (packagePrio (prioPackage prios) mbPackage, + (modulePrio (prioModule prios) mod, dots mod)) + where + packagePrio _ Nothing = (localPrio modulePath mod, 0) + packagePrio (high, low) (Just pack) = (1, searchPrio high low pack) + modulePrio (high, low) = + searchPrio (map Types.moduleName high) (map Types.moduleName low) + . Types.moduleName + dots = length . filter (=='.') . Types.moduleName + +-- | Lower numbers for modules that share more prefix with the module's path. +-- A/B/Z.hs vs A.B.C -> -2 +-- A/Z.hs vs B -> 0 +localPrio :: FilePath -> Types.ModuleName -> Int +localPrio modulePath mod = negate $ length $ takeWhile id $ zipWith (==) + (Util.split "/" (Types.moduleToPath mod)) + (Util.split "/" (FilePath.takeDirectory modulePath)) + +searchPrio :: [String] -> [String] -> String -> Int +searchPrio high low mod = case List.findIndex (`List.isPrefixOf` mod) high of + Just n -> - length high + n + Nothing -> maybe 0 (+1) (List.findIndex (`List.isPrefixOf` mod) low) + + +-- * format imports + -- | Print out the imports with spacing how I like it. formatImports :: [Types.ImportLine] -> String formatImports imports = unlines $ @@ -44,8 +107,8 @@ -- -- An unqualified import will follow a qualified one. The Prelude, if -- imported, always goes first. -formatGroups :: [String] -> [Types.ImportLine] -> String -formatGroups priorities imports = +formatGroups :: ImportOrder -> [Types.ImportLine] -> String +formatGroups (ImportOrder order) imports = unlines $ joinGroups [ showGroups (group (Util.sortOn packagePrio package)) , showGroups (group (Util.sortOn localPrio local)) @@ -53,7 +116,7 @@ where packagePrio imp = (fromEnum (name imp /= prelude), name imp, qualifiedPrio imp) - localPrio imp = (listPriority (topModule imp) priorities, + localPrio imp = (listPriority (topModule imp) (map Types.moduleName order), name imp, qualifiedPrio imp) qualifiedPrio imp = fromEnum (not (qualifiedImport imp)) name = Types.importModule diff --git a/src/FixImports.hs b/src/FixImports.hs --- a/src/FixImports.hs +++ b/src/FixImports.hs @@ -38,8 +38,10 @@ module FixImports where import Prelude hiding (mod) import Control.Applicative ((<$>)) +import qualified Control.Arrow as Arrow import qualified Control.Exception as Exception -import qualified Control.Monad as Monad +import Control.Monad + import qualified Data.Char as Char import qualified Data.Either as Either import qualified Data.Generics.Uniplate.Data as Uniplate @@ -73,7 +75,8 @@ (modulePath, (verbose, includes)) <- parseArgs =<< System.Environment.getArgs text <- IO.getContents - fixed <- fixModule includes config modulePath text + fixed <- fixModule (config { Config.configIncludes = includes }) + modulePath text `Exception.catch` (\(exc :: Exception.SomeException) -> return $ Left $ "exception: " ++ show exc) case fixed of @@ -83,7 +86,7 @@ System.Exit.exitFailure Right (Result text added removed) -> do IO.putStr text - Monad.when (verbose + when (verbose && (not (Set.null added) || not (Set.null removed))) $ IO.hPutStrLn IO.stderr $ "added: " ++ names added ++ "; removed: " ++ names removed @@ -105,16 +108,17 @@ ] usage :: String -> IO a -usage msg = - putStr (GetOpt.usageInfo (msg ++ help) options) >> System.Exit.exitFailure - where - help = "FixImports Module.hs IO (String, (Bool, [FilePath])) parseArgs args = case GetOpt.getOpt GetOpt.Permute options args of (flags, [modulePath], []) -> return (modulePath, parse flags) (_, [], errs) -> usage $ concat errs - _ -> usage "too many args\n" + _ -> usage "too many args" where parse flags = (Verbose `elem` flags, "." : [p | Include p <- flags]) -- Includes always have the current directory first. @@ -124,15 +128,15 @@ , resultRemoved :: Set.Set Types.ModuleName } deriving (Show) -fixModule :: [FilePath] -> Config.Config -> FilePath -> String +fixModule :: Config.Config -> FilePath -> String -> IO (Either String Result) -fixModule includes config modulePath text = do +fixModule config modulePath text = do processed <- cppModule modulePath text case parse processed of Haskell.ParseFailed srcloc err -> return $ Left $ Haskell.prettyPrint srcloc ++ ": " ++ err Haskell.ParseOk (mod, cmts) -> - fixImports includes config modulePath mod cmts text + fixImports config modulePath mod cmts text where parse = Haskell.parseFileContentsWithComments $ Haskell.defaultParseMode @@ -167,18 +171,16 @@ -- | 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 :: [FilePath] -> Config.Config -> FilePath -> Types.Module +fixImports :: Config.Config -> FilePath -> Types.Module -> [Haskell.Comment] -> String -> IO (Either String Result) -fixImports includes config modulePath mod cmts text = do +fixImports config modulePath mod cmts text = do -- Don't bother loading the index if I'm not going to use it. -- TODO actually, only load it if I don't find local imports -- I guess Data.Binary's laziness will serve me there - index <- if Set.null newImports - then return Index.empty - else Index.loadIndex (Config.configIndex config) - mbNew <- mapM (mkImportLine includes modulePath index) + index <- if Set.null newImports then return Index.empty else Index.loadIndex + mbNew <- mapM (mkImportLine config modulePath index) (Set.toList newImports) - mbExisting <- mapM (findImport includes) imports + mbExisting <- mapM (findImport (Config.configIncludes config)) imports let existing = map (Types.importDeclModule . fst) imports let (notFound, importLines) = Either.partitionEithers $ zipWith mkError @@ -211,10 +213,10 @@ -- * find new imports -- | Make a new ImportLine from a ModuleName. -mkImportLine :: [FilePath] -> FilePath -> Index.Index -> Types.Qualification +mkImportLine :: Config.Config -> FilePath -> Index.Index -> Types.Qualification -> IO (Maybe Types.ImportLine) -mkImportLine includes modulePath index qual@(Types.Qualification name) = do - found <- findModule includes index modulePath qual +mkImportLine config modulePath index qual@(Types.Qualification name) = do + found <- findModule config index modulePath qual return $ case found of Nothing -> Nothing Just (mod, local) -> Just (Types.ImportLine (mkImport mod) [] local) @@ -229,50 +231,43 @@ -- | Find the qualification and its ModuleName and True if it was a local -- import. Nothing if it wasn't found at all. -findModule :: [FilePath] -> Index.Index -> FilePath -> Types.Qualification - -> IO (Maybe (Types.ModuleName, Bool)) -findModule includes index modulePath qual = do - found <- findLocalModule includes modulePath qual - return $ case found of - Just path -> Just (pathToModule path, True) - Nothing -> case Map.lookup qual index of - Just mod -> Just (mod, False) - Nothing -> Nothing +findModule :: Config.Config -> Index.Index -> FilePath + -- ^ Path to the module being fixed. + -> Types.Qualification -> IO (Maybe (Types.ModuleName, Bool)) +findModule config index modulePath qual = do + found <- findLocalModules (Config.configIncludes 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 + Just (package, mod) -> Just (mod, package == Nothing) + Nothing -> Nothing --- | Given A.B, look for A/B.hs, */A/B.hs, */*/A/B.hs, etc. Look in the --- directory of the current module first. -findLocalModule :: [FilePath] -> FilePath -> Types.Qualification - -> IO (Maybe String) -findLocalModule includes modulePath (Types.Qualification name) = - Util.untilJust $ - findFile path 0 moduleDir : map (findFileStrip path 4) includes - where - path = moduleToPath (Types.ModuleName name) - moduleDir = FilePath.takeDirectory modulePath +-- | Given A.B, look for A/B.hs, */A/B.hs, */*/A/B.hs, etc. in each of the +-- include paths. +findLocalModules :: [FilePath] -> Types.Qualification -> IO [FilePath] +findLocalModules includes (Types.Qualification name) = do + concat <$> forM includes (\dir -> map (stripDir dir) <$> + findFiles 4 (Types.moduleToPath (Types.ModuleName name)) dir) --- | Like 'findFile', but strip the base directory name from the front of the --- returned file. -findFileStrip :: FilePath -> Int -> FilePath -> IO (Maybe FilePath) -findFileStrip file depth dir = do - fmap (dropWhile (=='/') . strip dir) <$> findFile file depth dir - where - strip xs ys - | take (length xs) ys == xs = drop (length xs) ys - | otherwise = ys +stripDir :: FilePath -> FilePath -> FilePath +stripDir dir path + | dir == "." = path + | otherwise = dropWhile (=='/') $ drop (length dir) path --- | Find the file somewhere below the given directory, giving up after --- descending the given depth. -findFile :: FilePath -> Int -> FilePath -> IO (Maybe FilePath) -findFile file depth dir = fmap (fmap FilePath.normalise) $ - Util.ifM (Directory.doesFileExist current) (return (Just current)) $ - if depth <= 0 then return Nothing else descend +findFiles :: Int -- ^ Descend into subdirectories this many times. + -> FilePath -- ^ Find files with this suffix. Can contain slashes. + -> FilePath -- ^ Start from this directory. Return [] if it doesn't exist. + -> IO [FilePath] +findFiles depth file dir = do + fns <- Maybe.fromMaybe [] <$> Util.catchENOENT (Util.listDir dir) + (subdirs, fns) <- Util.partitionM Directory.doesDirectoryExist fns + subfns <- if depth > 0 + then concat <$> mapM (findFiles (depth-1) file) + (filter isModuleDir subdirs) + else return [] + return $ filter (file `List.isSuffixOf`) fns ++ subfns where - descend = do - subdirs <- Monad.filterM Directory.doesDirectoryExist - =<< Util.listDir dir - Util.untilJust $ - map (findFile file (depth-1)) (filter isModuleDir subdirs) - current = dir file isModuleDir = all Char.isUpper . take 1 . FilePath.takeFileName @@ -298,7 +293,7 @@ isLocalModule :: Types.ModuleName -> [FilePath] -> IO Bool isLocalModule mod = - Util.anyM (Directory.doesFileExist . ( moduleToPath mod)) + Util.anyM (Directory.doesFileExist . ( Types.moduleToPath mod)) isPackageModule :: Types.ModuleName -> IO Bool isPackageModule (Types.ModuleName name) = do @@ -307,14 +302,6 @@ return $ not (null output) -- * util - -pathToModule :: FilePath -> Types.ModuleName -pathToModule = Types.ModuleName . - map (\c -> if c == '/' then '.' else c) . FilePath.dropExtension - -moduleToPath :: Types.ModuleName -> FilePath -moduleToPath (Types.ModuleName name) = - map (\c -> if c == '.' then '/' else c) name ++ ".hs" importInfo :: Types.Module -> [Haskell.Comment] -> (Set.Set Types.Qualification, Set.Set Types.ModuleName, diff --git a/src/FixImports_test.hs b/src/FixImports_test.hs --- a/src/FixImports_test.hs +++ b/src/FixImports_test.hs @@ -3,14 +3,18 @@ module FixImports_test where import qualified Language.Haskell.Exts.Annotated as Haskell +import qualified Config import qualified FixImports +import qualified Index import qualified Types +importRange :: String -> Either String (Int, Int) importRange modText = do (mod, cmts) <- parse modText return $ FixImports.importRange mod +cmtsInRange :: String -> Either String [Haskell.Comment] cmtsInRange modText = do (mod, cmts) <- parse modText return $ FixImports.filterImportCmts (FixImports.importRange mod) cmts @@ -21,6 +25,12 @@ Left $ Haskell.prettyPrint srcloc ++ ": " ++ err Haskell.ParseOk (mod, comments) -> Right (mod, comments) where mode = Haskell.defaultParseMode + +findModule :: [FilePath] -> FilePath -> String + -> IO (Maybe (Types.ModuleName, Bool)) +findModule includes modulePath qual = do + index <- Index.loadIndex (Config.configIndex (Config.defaultConfig [])) + FixImports.findModule includes index modulePath (Types.Qualification qual) -- TODO quasi-quoting has a nicer way for multi-line strings, right? tmod0 = "-- cmt1\n\ diff --git a/src/Index.hs b/src/Index.hs --- a/src/Index.hs +++ b/src/Index.hs @@ -1,88 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} -- | Maintain the index from Qualification to the full module from the package -- db that this Qualification probably intends. module Index where import Prelude hiding (mod) -import Control.Applicative ( (<$>) ) -import Control.Monad.Instances () -- Monad (Either x) instance +import Control.Monad +import qualified Data.Either as Either import qualified Data.List as List import qualified Data.Map as Map -import qualified System.Process as Process +import qualified Data.Text as T +import Data.Text (Text) +import qualified System.IO as IO + import qualified Types import qualified Util -data Config = Config { - -- | The modules in the packages earlier in this list will override those - -- later. So even if there's a package with @Some.Obscure.List@, @List@ - -- will still map to @Data.List@ because @containers@ gets priority. - -- - -- The rest will be in a consistent but uninteresting order. - configPackagePriorities :: [String] - - -- | Ignore these packages entirely even if they are exposed, in case they - -- export something annoyingly general. - , configIgnorePackages :: [String] - } deriving (Show) - -- | 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 Types.ModuleName +type Index = Map.Map Types.Qualification [(Package, Types.ModuleName)] +-- | Package name without the version. +type Package = String + empty :: Index empty = Map.empty -loadIndex :: Config -> IO Index +loadIndex :: IO Index loadIndex = buildIndex -- TODO load cache? -buildIndex :: Config -> IO Index -buildIndex config = do - result <- parseDump config <$> Process.readProcess "ghc-pkg" - ["field", "*", "name,exposed,exposed-modules"] "" - either error return result +buildIndex :: IO Index +buildIndex = 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 -parseDump :: Config -> String -> Either String Index -parseDump config text = do - triples <- sequence (triple sections) - return $ Map.fromList $ makePairs (configPackagePriorities config) - [(package, mods) | (package, True, mods) <- triples, - package `notElem` configIgnorePackages config] +parseDump :: Text -> ([String], Index) +parseDump text = (errors, index) where - sections = List.unfoldr parseSection (lines text) - triple [] = [] - triple (("name", [name]) : ("exposed", [exposed]) - : ("exposed-modules", modules) : rest) = - Right (name, exposed == "True", map Types.ModuleName modules) - : triple rest - triple ((tag, _) : _) = [Left $ "unexpected tag: " ++ tag] + index = Map.fromListWith (++) + [(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 -makePairs :: [String] -> [(String, [Types.ModuleName])] - -> [(Types.Qualification, Types.ModuleName)] -makePairs packagePrio packageMods = - [(qual, mod) | (_, mod) <- pairs, qual <- modQuals mod] - where - pairs = Util.sortOn (priority (reverse packagePrio)) - [(p, m) | (p, mods) <- packageMods, m <- mods] - modQuals = map (Types.Qualification . Util.join ".") . filter (not . null) - . List.tails . Util.split "." . Types.moduleName +-- | 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 --- | Put the high priority packages last, so they will override the others --- in @Map.fromList@. -priority :: [String] -> (String, Types.ModuleName) -> (Int, Int, String) -priority packagePrio (package, mod) = (pprio, mprio, package) - where - pprio = maybe 0 (+1) (List.elemIndex package packagePrio) - mprio = negate $ length $ filter (=='.') $ Types.moduleName mod +parseSections :: Text -> [(Text, [Text])] -- ^ [(section_name, words)] +parseSections = List.unfoldr parseSection . stripComments . T.lines -parseSection :: [String] -> Maybe ((String, [String]), [String]) +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 words (drop 1 rest : pre)), post) +parseSection (x:xs) = + Just ((tag, concatMap T.words (T.drop 1 rest : pre)), post) where - (tag, rest) = break (==':') x - (pre, post) = span ((==" ") . take 1) xs + (tag, rest) = T.break (==':') x + (pre, post) = span (" " `T.isPrefixOf`) xs {- -- * test diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,19 +1,44 @@ --- | Main file for FixImports that uses the default formatting. Since import --- priority is per-project, it reads it from a file in the current directory. +-- | Main file for FixImports that uses the default formatting. It reads +-- a config file from the current directory. -- -- More documentation in "FixImports". module Main where -import qualified System.Directory as Directory +import Control.Monad +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified System.IO as IO + import qualified Config import qualified FixImports +import qualified Index +import qualified Types import qualified Util main :: IO () main = do - priorities <- fmap words (readEmpty "fix-imports-priority") - FixImports.runMain (Config.defaultConfig priorities) + let deflt = (Config.ImportOrder [], Config.defaultPriorities, []) + (order, prios, warns) <- fmap (maybe deflt 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 order prios) -readEmpty :: FilePath -> IO String -readEmpty fn = Util.ifM (Directory.doesFileExist fn) (readFile fn) (return "") +parse :: Text.Text -> (Config.ImportOrder, Config.Priorities, [String]) +parse text = (order, prios, extra) + where + extra = Map.keys config List.\\ valid + valid = ["import-order", "prio-package-high", "prio-package-low", + "prio-module-high", "prio-module-low"] + 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) + | (section, words) <- Index.parseSections text] + getModules = map Types.ModuleName . get + get k = Map.findWithDefault [] k config diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,5 +1,6 @@ module Types where import qualified Language.Haskell.Exts.Annotated as Haskell +import qualified System.FilePath as FilePath data ImportLine = ImportLine { @@ -26,6 +27,15 @@ 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 a qualified import, if it is a qualified -- import. importDeclQualification :: ImportDecl -> Maybe Qualification @@ -45,5 +55,5 @@ -- | The parser represents the \'as\' part of an import as a ModuleName even -- though it's actually a Qualification. moduleToQualification :: Haskell.ModuleName Haskell.SrcSpanInfo - -> Types.Qualification -moduleToQualification (Haskell.ModuleName _ s) = Types.Qualification s + -> Qualification +moduleToQualification (Haskell.ModuleName _ s) = Qualification s diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -1,9 +1,22 @@ 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.Function as Function import qualified Data.List as List import qualified Data.List.Split as Split +import qualified Data.Text as T +import qualified Data.Text.IO as Text.IO + import qualified System.Directory as Directory -import System.FilePath ( () ) +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 -- * list @@ -16,6 +29,16 @@ split :: (Eq a) => [a] -> [a] -> [[a]] split = Split.splitOn +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) + -- * control ifM :: (Monad m) => m Bool -> m a -> m a -> m a @@ -23,24 +46,20 @@ 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 :: (a -> IO Bool) -> [a] -> IO Bool anyM _ [] = return False anyM f (x:xs) = ifM (f x) (return True) (anyM f xs) -mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe f xs = [b | Just b <- map f xs] - -groupOn :: (Eq k) => (a -> k) -> [a] -> [[a]] -groupOn key = List.groupBy ((==) `Function.on` key) - -sortOn :: (Ord k) => (a -> k) -> [a] -> [a] -sortOn key = List.sortBy (compare `Function.on` key) - --- | Keep running the action until it returns a Just. -untilJust :: [IO (Maybe a)] -> IO (Maybe a) -untilJust [] = return Nothing -untilJust (m:ms) = do - maybe (untilJust ms) (return . Just) =<< m +-- | 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 @@ -48,3 +67,27 @@ listDir dir = fmap (map add . filter (not . (`elem` [".", ".."]))) (Directory.getDirectoryContents dir) where add = if dir == "." then id else (dir ) + +-- | Similar to System.Process.readProcessWithExitCode but return Text instead +-- of String. +readProcessWithExitCode :: FilePath -> [String] + -> IO (Exit.ExitCode, T.Text, T.Text) +readProcessWithExitCode cmd args = do + (_, Just outh, Just errh, pid) <- + Process.createProcess (Process.proc cmd args) + { Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + outMVar <- MVar.newEmptyMVar + errMVar <- MVar.newEmptyMVar + void $ Concurrent.forkIO $ + MVar.putMVar outMVar =<< Text.IO.hGetContents outh + void $ Concurrent.forkIO $ + MVar.putMVar errMVar =<< Text.IO.hGetContents errh + out <- MVar.takeMVar outMVar + err <- MVar.takeMVar errMVar + IO.hClose outh + IO.hClose errh + ex <- Process.waitForProcess pid + return (ex, out, err) + diff --git a/vimrc b/vimrc --- a/vimrc +++ b/vimrc @@ -1,8 +1,8 @@ -" Example vimrc file to bind a key to FixImports. +" Example vimrc file to bind a key to fix-imports. nm ,a :call FixImports() -" Run the contents of the current buffer through the FixImports cmd. Print +" Run the contents of the current buffer through the fix-imports cmd. Print " any stderr output on the status line. " Remove 'a' from cpoptions if you don't want this to mess up #. function FixImports() @@ -12,7 +12,7 @@ " Using a tmp file means I don't have to save the buffer, which the user " didn't ask for. execute 'write' tmp - execute 'silent !FixImports -v' expand('%') '<' tmp '>' out '2>' err + execute 'silent !fix-imports -v' expand('%') '<' tmp '>' out '2>' err let errs = readfile(err) if v:shell_error == 0 " Don't replace the buffer if there's no change, this way I won't