module Haskell.Docs.Haddock where
import Haskell.Docs.Ghc
import Haskell.Docs.Types
import Control.Arrow
import Control.Monad
import Data.Either
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Documentation.Haddock
import GHC hiding (verbosity)
import GhcMonad (liftIO)
import Name
import PackageConfig
import Packages
search :: Maybe PackageConfig
-> Maybe PackageName
-> ModuleName
-> Identifier
-> Ghc (Either DocsException [IdentDoc])
search mprevious mpname mname name = do
result <- getPackagesByModule mname
case result of
Left{} ->
return (Left NoFindModule)
Right [package] ->
searchWithPackage package mname name
Right packages ->
case mpname of
Nothing -> do
fmap (Right . concat . rights)
(mapM (\package -> searchWithPackage package mname name)
(filter (not . isPrevious) packages))
Just pname -> do
case find ((== pname) . PackageName . showPackageName . sourcePackageId) packages of
Nothing ->
return (Left NoModulePackageCombo)
Just package ->
searchWithPackage package mname name
where isPrevious m =
Just (sourcePackageId m) == fmap sourcePackageId mprevious
searchWithPackage
:: PackageConfig
-> ModuleName
-> Identifier
-> Ghc (Either DocsException [IdentDoc])
searchWithPackage package mname name = do
interfaceFiles <- getHaddockInterfacesByPackage package
case (lefts interfaceFiles,rights interfaceFiles) of
([],[]) -> return (Left NoInterfaceFiles)
(errs@(_:_),_) -> return (Left (NoParseInterfaceFiles errs))
(_,files) ->
fmap (Right . concat)
(forM files
(\interfaceFile ->
fmap (concat . rights)
(mapM (searchWithInterface package mname name)
(filter ((==mname) . moduleName . instMod)
(ifInstalledIfaces interfaceFile)))))
searchWithInterface
:: PackageConfig
-> ModuleName
-> Identifier
-> InstalledInterface
-> Ghc (Either DocsException [IdentDoc])
searchWithInterface package mname name interface =
case find ((==name) . Identifier . getOccString) (instExports interface) of
Nothing ->
return (Left NoFindNameInExports)
Just{} ->
case M.lookup (unIdentifier name) (interfaceNameMap interface) of
Nothing ->
case lookup (unIdentifier name) (map (getOccString &&& id) (instExports interface)) of
Just subname
| moduleName (nameModule subname) /= moduleName (instMod interface) ->
descendSearch package name subname
_ ->
return (Left NoFindNameInInterface)
Just d ->
do mi <- findIdentifier mname name
margs <- lookupArgsDocs interface name
return
(Right
[IdentDoc (sourcePackageId package)
d
mi
margs])
interfaceNameMap :: InstalledInterface -> Map String (Doc String)
#if MIN_VERSION_haddock(2,10,0)
interfaceNameMap iface =
M.fromList (map (second (fmap getOccString) . first getOccString)
(M.toList (instDocMap iface)))
#else
interfaceNameMap iface =
M.fromList (map (second (fmap getOccString . maybe DocEmpty id . fst) . first getOccString)
(M.toList (instDocMap iface)))
#endif
interfaceArgMap :: InstalledInterface -> Map String (Map Int (Doc Name))
#if MIN_VERSION_haddock(2,10,0)
interfaceArgMap iface =
M.fromList (map (first getOccString) (M.toList (instArgMap iface)))
#else
interfaceArgMap iface = M.fromList (map (second (const M.empty) . first getOccString)
(M.toList (instDocMap iface)))
#endif
lookupArgsDocs :: InstalledInterface -> Identifier -> Ghc (Maybe [(Int, Doc String)])
lookupArgsDocs interface name = do
case M.lookup (unIdentifier name) (interfaceArgMap interface) of
Nothing -> return Nothing
Just argMap ->
return (Just (map (second (fmap getOccString)) (M.toList argMap)))
getPackagesByModule :: ModuleName -> Ghc (Either [Module] [PackageConfig])
getPackagesByModule m =
do df <- getSessionDynFlags
return (fmap (map fst) (lookupModuleWithSuggestions df m))
getHaddockInterfacesByPackage :: PackageConfig -> Ghc [Either DocsException InterfaceFile]
getHaddockInterfacesByPackage =
liftIO .
mapM (fmap (either (Left . NoReadInterfaceFile) Right) . readInterfaceFile freshNameCache) .
haddockInterfaces
descendSearch :: PackageConfig -> Identifier -> Name -> Ghc (Either DocsException [IdentDoc])
descendSearch package name qname = do
search (Just package) Nothing (moduleName (nameModule qname)) name