-- | 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 qualified Data.List as List
import qualified Data.Map as Map
import qualified System.Process as Process
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
empty :: Index
empty = Map.empty
loadIndex :: Config -> 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
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]
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]
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
-- | 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
parseSection :: [String] -> Maybe ((String, [String]), [String])
parseSection [] = Nothing
parseSection (x:xs) = Just ((tag, concatMap words (drop 1 rest : pre)), post)
where
(tag, rest) = break (==':') x
(pre, post) = span ((==" ") . take 1) 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"
]
-}