module HDocs.Haddock (
        -- * Documentation functions

        readInstalledDocsF, readInstalledDocs,
        readHaddock,
        readSources, readSources_, readSource, readSourcesGhc, readSourceGhc,

        -- * Extract docs

        installedInterfaceDocs, installedInterfacesDocs,
        interfaceDocs,

        -- * Utility functions

        haddockFilesF, haddockFiles,
        readInstalledInterfaces, readPackageInterfaces,
        lookupDoc, lookupNameDoc,

        module HDocs.Base,

        Ghc,
        module Control.Monad.Except,
        withGhc
        ) where

import Control.Applicative
import Control.Arrow
import Control.Exception
import Control.Monad.Except
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (listToMaybe)

import Distribution.Verbosity (silent)
import Documentation.Haddock
import Documentation.Haddock.Types (_doc)

import DynFlags (DynFlags)
import Exception (gtry)
import GHC (Ghc)
import Module
import Name
import PackageConfig

import HDocs.Base
import HDocs.Ghc.Compat

-- | Read all installed docs

readInstalledDocsF :: DynFlags -> ExceptT String IO (Map String ModuleDocMap)
readInstalledDocsF df = do
        fs <- haddockFilesF df
        liftM M.unions $ forM fs $ \f -> (readHaddock f) `mplus` (return M.empty)

-- | Read all installed docs

readInstalledDocs :: [String] -> ExceptT String IO (Map String ModuleDocMap)
readInstalledDocs opts = do
        fs <- haddockFiles opts
        liftM M.unions $ forM fs $ \f -> (readHaddock f) `mplus` (return M.empty)

-- | Read docs from .haddock file

readHaddock :: FilePath -> ExceptT String IO (Map String ModuleDocMap)
readHaddock f = M.fromList . map installedInterfaceDocs <$> readInstalledInterfaces f

-- | Read docs for haskell modules

readSources :: [String] -> [FilePath] -> ExceptT String IO (Map String ModuleDocMap)
readSources opts = liftM M.fromList . readSources_ opts

-- | Read docs for haskell modules

readSources_ :: [String] -> [FilePath] -> ExceptT String IO [(String, ModuleDocMap)]
readSources_ opts fs = do
        ifaces <- liftError $ liftIO $ createInterfaces ([Flag_Verbosity "0", Flag_NoWarnings, Flag_UseUnicode] ++ map Flag_OptGhc opts) fs
        return $ map interfaceDocs ifaces

-- | Read docs for haskell module

readSource :: [String] -> FilePath -> ExceptT String IO (String, ModuleDocMap)
readSource opts f = liftM listToMaybe (readSources_ opts [f]) >>= maybe (throwError $ "Failed to load docs for " ++ f) return

-- | Read docs for source in Ghc monad

readSourcesGhc :: [String] -> [FilePath] -> ExceptT String Ghc [(String, ModuleDocMap)]
readSourcesGhc opts fs = ExceptT $ liftM (left (show :: SomeException -> String)) $ gtry $ do
        ifaces <- liftM fst $ processModules silent fs ([Flag_Verbosity "0", Flag_NoWarnings, Flag_UseUnicode] ++ map Flag_OptGhc opts) []
        return $ map interfaceDocs ifaces

-- | Read docs for haskell module

readSourceGhc :: [String] -> FilePath -> ExceptT String Ghc (String, ModuleDocMap)
readSourceGhc opts f = liftM listToMaybe (readSourcesGhc opts [f]) >>= maybe (throwError $ "Failed to load docs for " ++ f) return

-- | Get docs for 'InstalledInterface'

installedInterfaceDocs :: InstalledInterface -> (String, ModuleDocMap)
installedInterfaceDocs = stringize . (instMod &&& (fmap _doc . instDocMap))

-- | Get docs for 'InstalledInterface's

installedInterfacesDocs :: [InstalledInterface] -> Map String ModuleDocMap
installedInterfacesDocs = M.fromList . map installedInterfaceDocs

-- | Get docs for 'Interface'

interfaceDocs :: Interface -> (String, ModuleDocMap)
interfaceDocs = stringize . (ifaceMod &&& (fmap _doc . ifaceDocMap))

-- | Get list of haddock files in package db

haddockFilesF :: DynFlags -> ExceptT String IO [FilePath]
haddockFilesF = ExceptT . return . maybe
        (Left "Package database empty")
        (Right . concatMap haddockInterfaces) .
        pkgDatabase

-- | Get list of haddock files in package db

haddockFiles :: [String] -> ExceptT String IO [FilePath]
haddockFiles opts = ExceptT $ withInitializedPackages opts (runExceptT . haddockFilesF)

-- | Read installed interface

readInstalledInterfaces :: FilePath -> ExceptT String IO [InstalledInterface]
readInstalledInterfaces f = do
        ifile <- liftError $ ExceptT $ readInterfaceFile freshNameCache f
        return $ ifInstalledIfaces ifile

-- | Read installed interfaces for package

readPackageInterfaces :: PackageConfig -> ExceptT String IO [InstalledInterface]
readPackageInterfaces = liftM concat . mapM readInstalledInterfaces . haddockInterfaces

-- | Lookup doc

lookupDoc :: String -> String -> Map String ModuleDocMap -> Maybe (Doc String)
lookupDoc m n = M.lookup m >=> M.lookup n

-- | Lookup doc for Name

lookupNameDoc :: Name -> Map String ModuleDocMap -> Maybe (Doc String)
lookupNameDoc n = lookupDoc (moduleNameString $ moduleName $ nameModule n) (getOccString n)

stringize :: (Module, Map Name (Doc Name)) -> (String, ModuleDocMap)
stringize = moduleNameString . moduleName *** strDoc where
        strDoc = M.mapKeys getOccString . M.map (fmap getOccString)

liftError :: ExceptT String IO a -> ExceptT String IO a
liftError = ExceptT . handle onErr . runExceptT where
        onErr :: SomeException -> IO (Either String a)
        onErr = return . Left . show