{-# LANGUAGE CPP, OverloadedStrings #-}

module HsDev.Tools.HDocs (
	hdocsy, hdocs, hdocsPackage, hdocsCabal,
	setSymbolDocs, setDocs, setModuleDocs,

	hdocsProcess,

	readDocs, readModuleDocs, readProjectTargetDocs,

	hdocsSupported,

	module Control.Monad.Except
	) where

import Control.Lens
import Control.Monad ()
import Control.Monad.Except

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
#ifdef NODOCS
import qualified System.Log.Simple as Log
#endif

#ifndef NODOCS
import Control.DeepSeq
import Data.Aeson (decode)
import qualified Data.ByteString.Lazy.Char8 as L (pack)
import Data.String (fromString)
import qualified Data.Text as T

import qualified HDocs.Module as HDocs
import qualified HDocs.Haddock as HDocs

import qualified GHC
#endif

import qualified PackageConfig as P

import Data.LookupTable
#ifndef NODOCS
import HsDev.Error
import HsDev.Scan.Browse (packageConfigs, readPackage)
import HsDev.Tools.Base
#endif
import HsDev.Symbols
import HsDev.Tools.Ghc.Worker
import System.Directory.Paths

-- | Get docs for modules
hdocsy :: PackageDbStack -> [ModuleLocation] -> [String] -> GhcM [Map String String]
#ifndef NODOCS
hdocsy pdbs mlocs opts = (map $ force . HDocs.formatDocs) <$> docs' mlocs where
	docs' :: [ModuleLocation] -> GhcM [HDocs.ModuleDocMap]
	docs' ms = do
		haddockSession pdbs opts
		liftGhc $ hsdevLiftWith (ToolError "hdocs") $
			liftM (map snd) $ HDocs.readSourcesGhc opts $ map (view (moduleFile . path)) ms
#else
hdocsy _ _ _ = notSupported >> return mempty
#endif

-- | Get docs for module
hdocs :: PackageDbStack -> ModuleLocation -> [String] -> GhcM (Map String String)
#ifndef NODOCS
hdocs pdbs mloc opts = (force . HDocs.formatDocs) <$> docs' mloc where
	docs' :: ModuleLocation -> GhcM HDocs.ModuleDocMap
	docs' mloc' = do
		haddockSession pdbs opts
		liftGhc $ case mloc' of
			(FileModule fpath _) -> hsdevLiftWith (ToolError "hdocs") $ liftM snd $ HDocs.readSourceGhc opts (view path fpath)
			(InstalledModule _ _ mname _) -> do
				df <- GHC.getSessionDynFlags
				liftIO $ hsdevLiftWith (ToolError "hdocs") $ HDocs.moduleDocsF df (T.unpack mname)
			_ -> hsdevError $ ToolError "hdocs" $ "Can't get docs for: " ++ show mloc'
#else
hdocs _ _ _ = notSupported >> return mempty
#endif

-- | Get docs for package
hdocsPackage :: P.PackageConfig -> GhcM (Map Text (Map Text Text))
#ifndef NODOCS
hdocsPackage p = do
	ifaces <-
		liftIO . hsdevLiftWith (ToolError "hdocs") .
		liftM concat . mapM ((`mplus` return []) . HDocs.readInstalledInterfaces) $
		P.haddockInterfaces p
	let
		idocs = HDocs.installedInterfacesDocs ifaces
		iexports = M.fromList $ map (HDocs.exportsDocs idocs) ifaces
		docs = M.map HDocs.formatDocs iexports
		tdocs = M.map (M.map fromString . M.mapKeys fromString) . M.mapKeys fromString $ docs
	return $!! tdocs
#else
hdocsPackage _ = notSupported >> return mempty
#endif

-- | Get all docs
hdocsCabal :: PackageDbStack -> [String] -> GhcM [(ModulePackage, (Map Text (Map Text Text)))]
#ifndef NODOCS
hdocsCabal pdbs opts = do
	haddockSession pdbs opts
	pkgs <- packageConfigs
	forM pkgs $ \pkg -> do
		pkgDocs' <- hdocsPackage pkg
		return (readPackage pkg, pkgDocs')
#else
hdocsCabal _ _ = notSupported >> return mempty
#endif

-- | Set docs for module
setSymbolDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Symbol -> m Symbol
setSymbolDocs tbl d sym = do
	symDocs <- cacheInTableM tbl (symName, symMod) (return $ M.lookup symName d)
	return $ set symbolDocs symDocs sym
	where
		symName = view (symbolId . symbolName) sym
		symMod = view (symbolId . symbolModule . moduleName) sym

-- | Set docs for module symbols
setDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Module -> m Module
setDocs tbl d = mapMOf (moduleExports . each) setDoc >=> mapMOf (moduleScope . each . each) setDoc where
	setDoc = setSymbolDocs tbl d

-- | Set docs for modules
setModuleDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text (Map Text Text) -> Module -> m Module
setModuleDocs tbl docs m = maybe return (setDocs tbl) (M.lookup (view (moduleId . moduleName) m) docs) $ m

hdocsProcess :: String -> [String] -> IO (Maybe (Map String String))
#ifndef NODOCS
hdocsProcess mname opts = liftM (decode . L.pack . last . lines) $ runTool_ "hdocs" opts' where
	opts' = mname : concat [["-g", opt] | opt <- opts]
#else
hdocsProcess _ _ = return mempty
#endif

-- | Read docs for one module
readDocs :: Text -> [String] -> Path -> GhcM (Maybe (Map String String))
#ifndef NODOCS
readDocs mname opts fpath = do
	docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts [view path fpath]
	return $ fmap HDocs.formatDocs $ lookup (T.unpack mname) docs
#else
readDocs _ _ _ = notSupported >> return mempty
#endif

-- | Read docs for one module
readModuleDocs :: [String] -> Module -> GhcM (Maybe (Map String String))
#ifndef NODOCS
readModuleDocs opts m = case view (moduleId . moduleLocation) m of
	FileModule fpath _ -> withCurrentDirectory (sourceRoot_ (m ^. moduleId) ^. path) $ do
		readDocs (m ^. moduleId . moduleName) opts fpath
	_ -> hsdevError $ ModuleNotSource (view (moduleId . moduleLocation) m)
#else
readModuleDocs _ _ = notSupported >> return mempty
#endif

readProjectTargetDocs :: [String] -> Project -> [Path] -> GhcM (Map String (Map String String))
#ifndef NODOCS
readProjectTargetDocs opts proj fpaths = withCurrentDirectory (proj ^. projectPath . path) $ do
	docs <- liftGhc $ hsdevLift $ HDocs.readSourcesGhc opts (fpaths ^.. each . path)
	return $ M.map HDocs.formatDocs $ M.fromList docs
#else
readProjectTargetDocs _ _ _ = notSupported >> return mempty
#endif

#ifdef NODOCS
notSupported :: Log.MonadLog m => m ()
notSupported = Log.sendLog Log.Warning "compiled without hdocs support"
#endif

hdocsSupported :: Bool
#ifndef NODOCS
hdocsSupported = True
#else
hdocsSupported = False
#endif