1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
--
module Haddock.Packages (
HaddockPackage(..),
getHaddockPackages,
getHaddockPackages',
combineLinkEnvs
) where
import Haddock.Types
import Haddock.Exception
import Haddock.InterfaceFile
import qualified Distribution.Haddock as D
import Data.Maybe
import qualified Data.Map as Map
import Control.Monad
import Control.Exception
import System.Directory
import GHC
import DynFlags
import Module
import Packages
-- | This structure represents the installed Haddock information for a
-- package. This is basically the contents of the .haddock file, the path
-- to the html files and the list of modules in the package
data HaddockPackage = HaddockPackage {
pdModules :: [Module],
pdLinkEnv :: LinkEnv,
pdHtmlPath :: FilePath
}
getHaddockPackages' :: [(FilePath, FilePath)] -> IO [HaddockPackage]
getHaddockPackages' pairs = do
mbPackages <- mapM tryReadIface pairs
return (catMaybes mbPackages)
where
-- try to get a HaddockPackage, warn if we can't
tryReadIface (html, iface) = do
eIface <- D.readInterfaceFile iface
case eIface of
Left err -> do
putStrLn ("Warning: Cannot read " ++ iface ++ ":")
putStrLn (" " ++ show err)
putStrLn "Skipping this interface."
return Nothing
Right iface -> return $ Just $
HaddockPackage (ifModules iface) (ifLinkEnv iface) html
-- | Try to read the installed Haddock information for the given packages,
-- if it exists. Print a warning on stdout if it couldn't be found for a
-- package.
getHaddockPackages :: [InstalledPackageInfo] -> IO [HaddockPackage]
getHaddockPackages pkgInfos = liftM catMaybes $ mapM tryGetPackage pkgInfos
where
-- try to get a HaddockPackage, warn if we can't
tryGetPackage pkgInfo =
(getPackage pkgInfo >>= return . Just)
`catchDyn`
(\(e::HaddockException) -> do
let pkgName = showPackageId (package pkgInfo)
putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":")
putStrLn (" " ++ show e)
return Nothing
)
-- | Try to read a HaddockPackage structure for a package
getPackage :: InstalledPackageInfo -> IO HaddockPackage
getPackage pkgInfo = do
html <- getHtml pkgInfo
ifacePath <- getIface pkgInfo
iface <- readInterfaceFile ifacePath
return $ HaddockPackage {
pdModules = ifModules iface,
pdLinkEnv = ifLinkEnv iface,
pdHtmlPath = html
}
-- | Recreate exposed modules from an InstalledPackageInfo
packageModules :: InstalledPackageInfo -> [Module]
packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames
where
moduleNames = map mkModuleName (exposedModules pkgInfo)
pkgId = mkPackageId . package
-- | Get the Haddock HTML directory path for a package
getHtml :: InstalledPackageInfo -> IO FilePath
getHtml pkgInfo = case haddockHTMLs pkgInfo of
(path:_) | not (null path) -> do
dirExists <- doesDirectoryExist path
if dirExists then return path else throwE $
"HTML directory " ++ path ++ " does not exist."
_ -> throwE "No Haddock documentation installed."
-- | Get the Haddock interface path for a package
getIface :: InstalledPackageInfo -> IO FilePath
getIface pkgInfo = case haddockInterfaces pkgInfo of
(file:_) | not (null file) -> do
fileExists <- doesFileExist file
if fileExists then return file else throwE $
"Interface file " ++ file ++ " does not exist."
_ -> throwE "No Haddock interface installed."
-- | Build one big link env out of a list of packages. If multiple packages
-- export the same (original) name, we just pick one of the packages as the
-- documentation site.
combineLinkEnvs :: [HaddockPackage] -> LinkEnv
combineLinkEnvs packages = Map.unions (map pdLinkEnv packages)
|
