{-# 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.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 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

loadIndex :: IO Index
loadIndex = buildIndex -- TODO load cache?

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 :: Text -> ([String], Index)
parseDump text = (errors, index)
    where
    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

-- | 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

{-
-- * 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"
    ]
-}