module Haskell.Docs.Haddock where
import Haskell.Docs.Cabal
import Haskell.Docs.Ghc
import Haskell.Docs.Types
import Control.Arrow
import Control.Exception (try,IOException)
import Control.Monad
import Data.Either
import Data.Function
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
searchIdent
:: Maybe PackageConfig
-> Identifier
-> Ghc (Either DocsException [IdentDoc])
searchIdent mprevious name =
do packages <- fmap (filterPrevious mprevious) (liftIO getAllPackages)
searchInPackages packages
Nothing
name
searchModuleIdent
:: Maybe PackageConfig
-> ModuleName
-> Identifier
-> Ghc (Either DocsException [IdentDoc])
searchModuleIdent mprevious mname name =
do result <- fmap (filterPrevious mprevious) (getPackagesByModule mname)
case result of
[] ->
return (Left NoFindModule)
[package] ->
searchWithPackage package (Just mname) name
packages ->
searchInPackages packages
(Just mname)
name
searchPackageModuleIdent
:: Maybe PackageConfig
-> PackageName
-> ModuleName
-> Identifier
-> Ghc (Either DocsException [IdentDoc])
searchPackageModuleIdent mprevious pname mname name =
do result <- fmap (filterPrevious mprevious) (getPackagesByModule mname)
case result of
[] -> return (Left NoFindModule)
packages ->
case find ((== pname) . PackageName . showPackageName . sourcePackageId) packages of
Nothing ->
return (Left NoModulePackageCombo)
Just package ->
searchWithPackage package (Just mname) name
filterPrevious exclude =
filter (maybe (const True)
(on (/=) sourcePackageId)
exclude)
searchInPackages
:: [PackageConfig]
-> Maybe ModuleName
-> Identifier
-> Ghc (Either a [IdentDoc])
searchInPackages packages mname name =
fmap (Right . concat . rights)
(mapM (\package -> searchWithPackage package mname name)
packages)
searchWithPackage
:: PackageConfig
-> Maybe 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 name)
(filter (maybe (const True)
(\n -> (==n) . moduleName . instMod)
mname)
(ifInstalledIfaces interfaceFile)))))
searchWithInterface
:: PackageConfig
-> Identifier
-> InstalledInterface
-> Ghc (Either DocsException [IdentDoc])
searchWithInterface package 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 (moduleName (instMod interface)) 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 [PackageConfig]
getPackagesByModule m =
do df <- getSessionDynFlags
return (either (const [])
(map fst)
(lookupModuleWithSuggestions df m))
getHaddockInterfacesByPackage :: PackageConfig -> Ghc [Either DocsException InterfaceFile]
getHaddockInterfacesByPackage =
liftIO .
mapM (fmap (either (Left . NoReadInterfaceFile) Right) . safelyReadFile freshNameCache) .
haddockInterfaces
where safelyReadFile cache p =
do result <- try (readInterfaceFile cache p)
case result of
Left (_::IOException) -> return (Left "Couldn't read file.")
Right r -> return r
descendSearch :: PackageConfig -> Identifier -> Name -> Ghc (Either DocsException [IdentDoc])
descendSearch package name qname = do
searchModuleIdent (Just package) (moduleName (nameModule qname)) name