{-# LANGUAGE CPP, OverloadedStrings, PackageImports #-}

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" GHC
#endif

import qualified "ghc" 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 :: PackageDbStack
-> [ModuleLocation] -> [String] -> GhcM [Map String String]
hdocsy PackageDbStack
_ [ModuleLocation]
_ [String]
_ = MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => m ()
notSupported MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> GhcM [Map String String] -> GhcM [Map String String]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Map String String] -> GhcM [Map String String]
forall (m :: * -> *) a. Monad m => a -> m a
return [Map String String]
forall a. Monoid a => a
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 :: PackageDbStack
-> ModuleLocation -> [String] -> GhcM (Map String String)
hdocs PackageDbStack
_ ModuleLocation
_ [String]
_ = MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => m ()
notSupported MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> GhcM (Map String String) -> GhcM (Map String String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map String String -> GhcM (Map String String)
forall (m :: * -> *) a. Monad m => a -> m a
return Map String String
forall a. Monoid a => a
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 :: PackageConfig -> GhcM (Map Text (Map Text Text))
hdocsPackage PackageConfig
_ = MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => m ()
notSupported MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> GhcM (Map Text (Map Text Text))
-> GhcM (Map Text (Map Text Text))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map Text (Map Text Text) -> GhcM (Map Text (Map Text Text))
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text (Map Text Text)
forall a. Monoid a => a
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 :: PackageDbStack
-> [String] -> GhcM [(ModulePackage, Map Text (Map Text Text))]
hdocsCabal PackageDbStack
_ [String]
_ = MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => m ()
notSupported MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> GhcM [(ModulePackage, Map Text (Map Text Text))]
-> GhcM [(ModulePackage, Map Text (Map Text Text))]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(ModulePackage, Map Text (Map Text Text))]
-> GhcM [(ModulePackage, Map Text (Map Text Text))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ModulePackage, Map Text (Map Text Text))]
forall a. Monoid a => a
mempty
#endif

-- | Set docs for module
setSymbolDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Symbol -> m Symbol
setSymbolDocs :: LookupTable (Text, Text) (Maybe Text)
-> Map Text Text -> Symbol -> m Symbol
setSymbolDocs LookupTable (Text, Text) (Maybe Text)
tbl Map Text Text
d Symbol
sym = do
	Maybe Text
symDocs <- LookupTable (Text, Text) (Maybe Text)
-> (Text, Text) -> m (Maybe Text) -> m (Maybe Text)
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
LookupTable k v -> k -> m v -> m v
cacheInTableM LookupTable (Text, Text) (Maybe Text)
tbl (Text
symName, Text
symMod) (Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
symName Map Text Text
d)
	Symbol -> m Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol -> m Symbol) -> Symbol -> m Symbol
forall a b. (a -> b) -> a -> b
$ ASetter Symbol Symbol (Maybe Text) (Maybe Text)
-> Maybe Text -> Symbol -> Symbol
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Symbol Symbol (Maybe Text) (Maybe Text)
Lens' Symbol (Maybe Text)
symbolDocs Maybe Text
symDocs Symbol
sym
	where
		symName :: Text
symName = Getting Text Symbol Text -> Symbol -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SymbolId -> Const Text SymbolId) -> Symbol -> Const Text Symbol
Lens' Symbol SymbolId
symbolId ((SymbolId -> Const Text SymbolId) -> Symbol -> Const Text Symbol)
-> ((Text -> Const Text Text) -> SymbolId -> Const Text SymbolId)
-> Getting Text Symbol Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> SymbolId -> Const Text SymbolId
Lens' SymbolId Text
symbolName) Symbol
sym
		symMod :: Text
symMod = Getting Text Symbol Text -> Symbol -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SymbolId -> Const Text SymbolId) -> Symbol -> Const Text Symbol
Lens' Symbol SymbolId
symbolId ((SymbolId -> Const Text SymbolId) -> Symbol -> Const Text Symbol)
-> ((Text -> Const Text Text) -> SymbolId -> Const Text SymbolId)
-> Getting Text Symbol Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleId -> Const Text ModuleId)
-> SymbolId -> Const Text SymbolId
Lens' SymbolId ModuleId
symbolModule ((ModuleId -> Const Text ModuleId)
 -> SymbolId -> Const Text SymbolId)
-> ((Text -> Const Text Text) -> ModuleId -> Const Text ModuleId)
-> (Text -> Const Text Text)
-> SymbolId
-> Const Text SymbolId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> ModuleId -> Const Text ModuleId
Lens' ModuleId Text
moduleName) Symbol
sym

-- | Set docs for module symbols
setDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text Text -> Module -> m Module
setDocs :: LookupTable (Text, Text) (Maybe Text)
-> Map Text Text -> Module -> m Module
setDocs LookupTable (Text, Text) (Maybe Text)
tbl Map Text Text
d = LensLike (WrappedMonad m) Module Module Symbol Symbol
-> (Symbol -> m Symbol) -> Module -> m Module
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf (([Symbol] -> WrappedMonad m [Symbol])
-> Module -> WrappedMonad m Module
Lens' Module [Symbol]
moduleExports (([Symbol] -> WrappedMonad m [Symbol])
 -> Module -> WrappedMonad m Module)
-> ((Symbol -> WrappedMonad m Symbol)
    -> [Symbol] -> WrappedMonad m [Symbol])
-> LensLike (WrappedMonad m) Module Module Symbol Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol -> WrappedMonad m Symbol)
-> [Symbol] -> WrappedMonad m [Symbol]
forall s t a b. Each s t a b => Traversal s t a b
each) Symbol -> m Symbol
setDoc (Module -> m Module) -> (Module -> m Module) -> Module -> m Module
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> LensLike (WrappedMonad m) Module Module Symbol Symbol
-> (Symbol -> m Symbol) -> Module -> m Module
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf ((Map Name [Symbol] -> WrappedMonad m (Map Name [Symbol]))
-> Module -> WrappedMonad m Module
Lens' Module (Map Name [Symbol])
moduleScope ((Map Name [Symbol] -> WrappedMonad m (Map Name [Symbol]))
 -> Module -> WrappedMonad m Module)
-> ((Symbol -> WrappedMonad m Symbol)
    -> Map Name [Symbol] -> WrappedMonad m (Map Name [Symbol]))
-> LensLike (WrappedMonad m) Module Module Symbol Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Symbol] -> WrappedMonad m [Symbol])
-> Map Name [Symbol] -> WrappedMonad m (Map Name [Symbol])
forall s t a b. Each s t a b => Traversal s t a b
each (([Symbol] -> WrappedMonad m [Symbol])
 -> Map Name [Symbol] -> WrappedMonad m (Map Name [Symbol]))
-> ((Symbol -> WrappedMonad m Symbol)
    -> [Symbol] -> WrappedMonad m [Symbol])
-> (Symbol -> WrappedMonad m Symbol)
-> Map Name [Symbol]
-> WrappedMonad m (Map Name [Symbol])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol -> WrappedMonad m Symbol)
-> [Symbol] -> WrappedMonad m [Symbol]
forall s t a b. Each s t a b => Traversal s t a b
each) Symbol -> m Symbol
setDoc where
	setDoc :: Symbol -> m Symbol
setDoc = LookupTable (Text, Text) (Maybe Text)
-> Map Text Text -> Symbol -> m Symbol
forall (m :: * -> *).
MonadIO m =>
LookupTable (Text, Text) (Maybe Text)
-> Map Text Text -> Symbol -> m Symbol
setSymbolDocs LookupTable (Text, Text) (Maybe Text)
tbl Map Text Text
d

-- | Set docs for modules
setModuleDocs :: MonadIO m => LookupTable (Text, Text) (Maybe Text) -> Map Text (Map Text Text) -> Module -> m Module
setModuleDocs :: LookupTable (Text, Text) (Maybe Text)
-> Map Text (Map Text Text) -> Module -> m Module
setModuleDocs LookupTable (Text, Text) (Maybe Text)
tbl Map Text (Map Text Text)
docs Module
m = (Module -> m Module)
-> (Map Text Text -> Module -> m Module)
-> Maybe (Map Text Text)
-> Module
-> m Module
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupTable (Text, Text) (Maybe Text)
-> Map Text Text -> Module -> m Module
forall (m :: * -> *).
MonadIO m =>
LookupTable (Text, Text) (Maybe Text)
-> Map Text Text -> Module -> m Module
setDocs LookupTable (Text, Text) (Maybe Text)
tbl) (Text -> Map Text (Map Text Text) -> Maybe (Map Text Text)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Getting Text Module Text -> Module -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const Text ModuleId) -> Module -> Const Text Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const Text ModuleId) -> Module -> Const Text Module)
-> ((Text -> Const Text Text) -> ModuleId -> Const Text ModuleId)
-> Getting Text Module Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> ModuleId -> Const Text ModuleId
Lens' ModuleId Text
moduleName) Module
m) Map Text (Map Text Text)
docs) (Module -> m Module) -> Module -> m Module
forall a b. (a -> b) -> a -> b
$ Module
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 :: String -> [String] -> IO (Maybe (Map String String))
hdocsProcess String
_ [String]
_ = Maybe (Map String String) -> IO (Maybe (Map String String))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Map String String)
forall a. Monoid a => a
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 :: Text -> [String] -> Text -> GhcM (Maybe (Map String String))
readDocs Text
_ [String]
_ Text
_ = MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => m ()
notSupported MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> GhcM (Maybe (Map String String))
-> GhcM (Maybe (Map String String))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Map String String) -> GhcM (Maybe (Map String String))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Map String String)
forall a. Monoid a => a
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 :: [String] -> Module -> GhcM (Maybe (Map String String))
readModuleDocs [String]
_ Module
_ = MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => m ()
notSupported MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> GhcM (Maybe (Map String String))
-> GhcM (Maybe (Map String String))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Map String String) -> GhcM (Maybe (Map String String))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Map String String)
forall a. Monoid a => a
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 :: [String]
-> Project -> [Text] -> GhcM (Map String (Map String String))
readProjectTargetDocs [String]
_ Project
_ [Text]
_ = MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => m ()
notSupported MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> GhcM (Map String (Map String String))
-> GhcM (Map String (Map String String))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map String (Map String String)
-> GhcM (Map String (Map String String))
forall (m :: * -> *) a. Monad m => a -> m a
return Map String (Map String String)
forall a. Monoid a => a
mempty
#endif

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

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