aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
authorDavid Waern <unknown>2007-08-29 22:40:23 +0000
committerDavid Waern <unknown>2007-08-29 22:40:23 +0000
commit658e79eddf0ac941d2719ec0a3aea58f42ef1277 (patch)
tree649135576118781ddc77896f81289df5b5699cec /src/Haddock
parentc9746ad9a53e84c3a46ff8fd77f0fb3656ca7697 (diff)
Major refactoring
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Backends/DevHelp.hs (renamed from src/Haddock/DevHelp.hs)2
-rw-r--r--src/Haddock/Backends/HH.hs (renamed from src/Haddock/HH.hs)2
-rw-r--r--src/Haddock/Backends/HH2.hs (renamed from src/Haddock/HH2.hs)4
-rw-r--r--src/Haddock/Backends/HaddockDB.hs (renamed from src/Haddock/HaddockDB.hs)2
-rw-r--r--src/Haddock/Backends/Hoogle.hs (renamed from src/Haddock/Hoogle.hs)2
-rw-r--r--src/Haddock/Backends/Html.hs (renamed from src/Haddock/Html.hs)18
-rw-r--r--src/Haddock/GHC/Typecheck.hs (renamed from src/Haddock/Typecheck.hs)21
-rw-r--r--src/Haddock/GHC/Utils.hs (renamed from src/Haddock/Utils/GHC.hs)5
-rw-r--r--src/Haddock/Interface.hs91
-rw-r--r--src/Haddock/InterfaceFile.hs2
-rw-r--r--src/Haddock/Options.hs3
-rw-r--r--src/Haddock/Packages.hs89
-rw-r--r--src/Haddock/Syntax/Rename.hs (renamed from src/Haddock/Rename.hs)5
-rw-r--r--src/Haddock/Types.hs32
14 files changed, 170 insertions, 108 deletions
diff --git a/src/Haddock/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs
index 3401a7b4..9441d4a9 100644
--- a/src/Haddock/DevHelp.hs
+++ b/src/Haddock/Backends/DevHelp.hs
@@ -4,7 +4,7 @@
-- (c) Simon Marlow 2003
--
-module Haddock.DevHelp(ppDevHelpFile) where
+module Haddock.Backends.DevHelp (ppDevHelpFile) where
import Haddock.ModuleTree
import Haddock.Types
diff --git a/src/Haddock/HH.hs b/src/Haddock/Backends/HH.hs
index dc8f37e0..6cb5491d 100644
--- a/src/Haddock/HH.hs
+++ b/src/Haddock/Backends/HH.hs
@@ -4,7 +4,7 @@
-- (c) Simon Marlow 2003
--
-module Haddock.HH(ppHHContents, ppHHIndex, ppHHProject) where
+module Haddock.Backends.HH (ppHHContents, ppHHIndex, ppHHProject) where
ppHHContents = error "not yet"
ppHHIndex = error "not yet"
diff --git a/src/Haddock/HH2.hs b/src/Haddock/Backends/HH2.hs
index 7f88ed51..685be3ad 100644
--- a/src/Haddock/HH2.hs
+++ b/src/Haddock/Backends/HH2.hs
@@ -4,7 +4,9 @@
-- (c) Simon Marlow 2003
--
-module Haddock.HH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where
+
+module Haddock.Backends.HH2 (ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where
+
ppHH2Contents = error "not yet"
ppHH2Index = error "not yet"
diff --git a/src/Haddock/HaddockDB.hs b/src/Haddock/Backends/HaddockDB.hs
index 6341c6c4..9be79c27 100644
--- a/src/Haddock/HaddockDB.hs
+++ b/src/Haddock/Backends/HaddockDB.hs
@@ -4,7 +4,7 @@
-- (c) Simon Marlow 2003
--
-module Haddock.HaddockDB (ppDocBook) where
+module Haddock.Backends.HaddockDB (ppDocBook) where
{-
import HaddockTypes
diff --git a/src/Haddock/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 618d6eb3..d93c055b 100644
--- a/src/Haddock/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -7,7 +7,7 @@
-- Write out Hoogle compatible documentation
-- http://www.haskell.org/hoogle/
-module Haddock.Hoogle (
+module Haddock.Backends.Hoogle (
ppHoogle
) where
diff --git a/src/Haddock/Html.hs b/src/Haddock/Backends/Html.hs
index 74aa4e34..b49bf213 100644
--- a/src/Haddock/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -4,17 +4,19 @@
-- (c) Simon Marlow 2003
--
-module Haddock.Html (
- ppHtml, copyHtmlBits,
- ppHtmlIndex, ppHtmlContents,
- ppHtmlHelpFiles
- ) where
+
+module Haddock.Backends.Html (
+ ppHtml, copyHtmlBits,
+ ppHtmlIndex, ppHtmlContents,
+ ppHtmlHelpFiles
+) where
+
import Prelude hiding (div)
-import Haddock.DevHelp
-import Haddock.HH
-import Haddock.HH2
+import Haddock.Backends.DevHelp
+import Haddock.Backends.HH
+import Haddock.Backends.HH2
import Haddock.ModuleTree
import Haddock.Types
import Haddock.Version
diff --git a/src/Haddock/Typecheck.hs b/src/Haddock/GHC/Typecheck.hs
index 088ee8a1..e8e291ad 100644
--- a/src/Haddock/Typecheck.hs
+++ b/src/Haddock/GHC/Typecheck.hs
@@ -5,15 +5,14 @@
--
-module Haddock.Typecheck (
- GhcModule(..),
+module Haddock.GHC.Typecheck (
typecheckFiles
) where
import Haddock.Exception
import Haddock.Utils.GHC
-
+import Haddock.Types
import Data.Maybe
import Control.Monad
@@ -23,22 +22,6 @@ import BasicTypes
import SrcLoc
--- | This data structure collects all the information we want about a home
--- package module that we can get from GHC's typechecker
-data GhcModule = GhcModule {
- ghcModule :: Module,
- ghcFilename :: FilePath,
- ghcMbDocOpts :: Maybe String,
- ghcHaddockModInfo :: HaddockModInfo Name,
- ghcMbDoc :: Maybe (HsDoc Name),
- ghcGroup :: HsGroup Name,
- ghcMbExports :: Maybe [LIE Name],
- ghcExportedNames :: [Name],
- ghcNamesInScope :: [Name],
- ghcInstances :: [Instance]
-}
-
-
typecheckFiles :: Session -> [FilePath] -> IO [GhcModule]
typecheckFiles session files = do
checkedMods <- sortAndCheckModules session files
diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/GHC/Utils.hs
index 3ac90d77..8e70057f 100644
--- a/src/Haddock/Utils/GHC.hs
+++ b/src/Haddock/GHC/Utils.hs
@@ -5,7 +5,7 @@
--
-module Haddock.Utils.GHC where
+module Haddock.GHC.Utils where
import Debug.Trace
@@ -47,6 +47,9 @@ mkModuleNoPkg :: String -> Module
mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
+modulePkgStr = packageIdString . modulePackageId
+
+
-- misc
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
new file mode 100644
index 00000000..aed4af34
--- /dev/null
+++ b/src/Haddock/Interface.hs
@@ -0,0 +1,91 @@
+-------------------------------------------------------------------------------
+-- Haddock.Interface
+--
+-- Here we build the actual module interfaces. By interface we mean the
+-- information which is used to render a Haddock page for a module. Parts of
+-- this information is also stored in the interface files.
+--
+-- The HaddockModule structure holds the interface data as well as
+-- intermediate information needed during its creation.
+-------------------------------------------------------------------------------
+
+
+module Haddock.Interface (
+ createInterfaces
+) where
+
+
+import Haddock.Interface.Create
+import Haddock.Interface.AttachInstances
+import Haddock.Interface.Rename
+import Haddock.Types
+import Haddock.Options
+import Haddock.GHC.Utils
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List
+import Control.Monad.Writer
+import Control.Monad
+
+import Name
+
+
+-- | Turn a topologically sorted list of GhcModules into interfaces. Also
+-- return the home link environment created in the process, and any error
+-- messages.
+createInterfaces :: [GhcModule] -> LinkEnv -> [Flag] ->
+ ([HaddockModule], LinkEnv, [ErrMsg])
+createInterfaces modules extLinks flags = (interfaces, homeLinks, messages)
+ where
+ ((interfaces, homeLinks), messages) = runWriter $ do
+ -- part 1, create the interfaces
+ interfaces <- createInterfaces' modules flags
+ -- part 2, attach the instances
+ let interfaces' = attachInstances interfaces
+ -- part 3, rename the interfaces
+ renameInterfaces interfaces' extLinks
+
+
+createInterfaces' :: [GhcModule] -> [Flag] -> ErrMsgM [HaddockModule]
+createInterfaces' modules flags = do
+ resultMap <- foldM addInterface Map.empty modules
+ return (Map.elems resultMap)
+ where
+ addInterface :: ModuleMap -> GhcModule -> ErrMsgM ModuleMap
+ addInterface map mod = do
+ interface <- createInterface mod flags map
+ return $ Map.insert (hmod_mod interface) interface map
+
+
+renameInterfaces :: [HaddockModule] -> LinkEnv ->
+ ErrMsgM ([HaddockModule], LinkEnv)
+renameInterfaces interfaces externalLinks = do
+ let homeLinks = buildHomeLinks interfaces
+ let links = homeLinks `Map.union` externalLinks
+ interfaces' <- mapM (renameInterface links) interfaces
+ return (interfaces', homeLinks)
+
+-- | Build a mapping which for each original name, points to the "best"
+-- place to link to in the documentation. For the definition of
+-- "best", we use "the module nearest the bottom of the dependency
+-- graph which exports this name", not including hidden modules. When
+-- there are multiple choices, we pick a random one.
+--
+-- The interfaces are passed in in topologically sorted order, but we start
+-- by reversing the list so we can do a foldl.
+buildHomeLinks :: [HaddockModule] -> LinkEnv
+buildHomeLinks modules = foldl upd Map.empty (reverse modules)
+ where
+ upd old_env mod
+ | OptHide `elem` hmod_options mod = old_env
+ | OptNotHome `elem` hmod_options mod =
+ foldl' keep_old old_env exported_names
+ | otherwise = foldl' keep_new old_env exported_names
+ where
+ exported_names = hmod_visible_exports mod
+ modName = hmod_mod mod
+
+ keep_old env n = Map.insertWith (\new old -> old) n
+ (nameSetMod n modName) env
+ keep_new env n = Map.insert n (nameSetMod n modName) env
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 246c6dba..228efa71 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -45,7 +45,7 @@ data InterfaceMod = InterfaceMod {
}
data InterfaceFile = InterfaceFile {
- ifDocEnv :: DocEnv
+ ifLinkEnv :: LinkEnv
-- ifModules :: [InterfaceMod]
}
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 2b459f8d..c330f35e 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -132,6 +132,5 @@ options backwardsCompat =
Option [] ["use-package"] (ReqArg Flag_UsePackage "PACKAGE")
"the modules being processed depend on PACKAGE",
Option ['g'] [] (ReqArg Flag_GhcFlag "FLAGS + ARGS")
- ("send a flag to the Glasgow Haskell Compiler (use quotation to "
- ++ "pass arguments to the flag)")
+ ("send a flag to GHC")
]
diff --git a/src/Haddock/Packages.hs b/src/Haddock/Packages.hs
index 18383c4c..c2de11b4 100644
--- a/src/Haddock/Packages.hs
+++ b/src/Haddock/Packages.hs
@@ -7,8 +7,8 @@
module Haddock.Packages (
HaddockPackage(..),
- initAndReadPackages,
- combineDocEnvs
+ getHaddockPackages,
+ combineLinkEnvs
) where
@@ -33,68 +33,22 @@ import Packages
-- to the html files and the list of modules in the package
data HaddockPackage = HaddockPackage {
pdModules :: [Module],
- pdDocEnv :: DocEnv,
+ pdLinkEnv :: LinkEnv,
pdHtmlPath :: FilePath
}
--- | Expose the list of packages to GHC. Then initialize GHC's package state
--- and get the name of the actually loaded packages matching the supplied
--- list of packages. The matching packages might be newer versions of the
--- supplied ones. For each matching package, try to read its installed Haddock
--- information.
---
--- It would be better to try to get the "in scope" packages from GHC instead.
--- This would make the -use-package flag unnecessary. But currently it
--- seems all you can get from the GHC api is all packages that are linked in
--- (i.e the closure of the "in scope" packages).
-initAndReadPackages :: Session -> [String] -> IO [HaddockPackage]
-initAndReadPackages session pkgStrs = do
-
- -- expose the packages
-
- dfs <- getSessionDynFlags session
- let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage pkgStrs }
- setSessionDynFlags session dfs'
-
- -- try to parse the packages and get their names, without versions
- pkgNames <- mapM (handleParse . unpackPackageId . stringToPackageId) pkgStrs
-
- -- init GHC's package state
- (_, depPackages) <- initPackages dfs'
-
- -- compute the pkgIds of the loaded packages matching the
- -- supplied ones
-
- let depPkgs = map (fromJust . unpackPackageId) depPackages
- matchingPackages = [ mkPackageId pkg | pkg <- depPkgs,
- pkgName pkg `elem` pkgNames ]
-
- -- read the Haddock information for the matching packages
- getPackages session matchingPackages
- where
- handleParse (Just pkg) = return (pkgName pkg)
- handleParse Nothing = throwE "Could not parse package identifier"
-
-
--- | Try to create a HaddockPackage for each package.
--- Print a warning on stdout if a HaddockPackage could not be created.
-getPackages :: Session -> [PackageId] -> IO [HaddockPackage]
-getPackages session packages = do
-
- -- get InstalledPackageInfos for each package
- dynflags <- getSessionDynFlags session
- let pkgInfos = map (getPackageDetails (pkgState dynflags)) packages
-
- -- try to read the installed haddock information (.haddock interface file and
- -- html path) for the packages
- liftM catMaybes $ mapM tryGetPackage pkgInfos
+-- | 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 session pkgInfo >>= return . Just)
+ (getPackage pkgInfo >>= return . Just)
`catchDyn`
- (\(e::HaddockException) -> do
+ (\(e::HaddockException) -> do
let pkgName = showPackageId (package pkgInfo)
putStrLn ("Warning: Cannot use package " ++ pkgName ++ ":")
putStrLn (" " ++ show e)
@@ -102,20 +56,17 @@ getPackages session packages = do
)
--- | Try to create a HaddockPackage structure for a package
-getPackage :: Session -> InstalledPackageInfo -> IO HaddockPackage
-getPackage session pkgInfo = do
+-- | Try to read a HaddockPackage structure for a package
+getPackage :: InstalledPackageInfo -> IO HaddockPackage
+getPackage pkgInfo = do
- html <- getHtml pkgInfo
+ html <- getHtml pkgInfo
ifacePath <- getIface pkgInfo
- iface <- readInterfaceFile ifacePath
+ iface <- readInterfaceFile ifacePath
- let docEnv = ifDocEnv iface
- modules = packageModules pkgInfo
-
return $ HaddockPackage {
- pdModules = modules,
- pdDocEnv = docEnv,
+ pdModules = packageModules pkgInfo,
+ pdLinkEnv = ifLinkEnv iface,
pdHtmlPath = html
}
@@ -148,8 +99,8 @@ getIface pkgInfo = case haddockInterfaces pkgInfo of
_ -> throwE "No Haddock interface installed."
--- | Build one big doc env out of a list of packages. If multiple packages
+-- | 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.
-combineDocEnvs :: [HaddockPackage] -> DocEnv
-combineDocEnvs packages = Map.unions (map pdDocEnv packages)
+combineLinkEnvs :: [HaddockPackage] -> LinkEnv
+combineLinkEnvs packages = Map.unions (map pdLinkEnv packages)
diff --git a/src/Haddock/Rename.hs b/src/Haddock/Syntax/Rename.hs
index 5ac711cb..81dfb1cc 100644
--- a/src/Haddock/Rename.hs
+++ b/src/Haddock/Syntax/Rename.hs
@@ -4,11 +4,13 @@
-- (c) Simon Marlow 2003
--
-module Haddock.Rename (
+
+module Haddock.Syntax.Rename (
runRnFM, -- the monad (instance of Monad)
renameDoc, renameMaybeDoc, renameExportItems,
) where
+
import Haddock.Types
import GHC hiding ( NoLink )
@@ -23,6 +25,7 @@ import Prelude hiding ( mapM )
import Data.Traversable ( mapM )
import Control.Arrow
+
-- -----------------------------------------------------------------------------
-- Monad for renaming
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index b1ce11f1..44e8d7fd 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -8,9 +8,11 @@
module Haddock.Types where
+import Data.Map
+import Control.Monad.Writer
+
import GHC hiding (NoLink)
import Outputable
-import Data.Map
data DocOption
@@ -75,7 +77,7 @@ data ExportItem name
type InstHead name = ([HsPred name], name, [HsType name])
type ModuleMap = Map Module HaddockModule
type DocMap = Map Name (HsDoc DocName)
-type DocEnv = Map Name Name
+type LinkEnv = Map Name Name
data DocName = Link Name | NoLink Name
@@ -86,6 +88,26 @@ instance Outputable DocName where
ppr (NoLink n) = ppr n
+-- | Information about a home package module that we get from GHC's typechecker
+data GhcModule = GhcModule {
+ ghcModule :: Module,
+ ghcFilename :: FilePath,
+ ghcMbDocOpts :: Maybe String,
+ ghcHaddockModInfo :: HaddockModInfo Name,
+ ghcMbDoc :: Maybe (HsDoc Name),
+ ghcGroup :: HsGroup Name,
+ ghcMbExports :: Maybe [LIE Name],
+ ghcExportedNames :: [Name],
+ ghcNamesInScope :: [Name],
+ ghcInstances :: [Instance]
+}
+
+
+-- | This is the data used to render a Haddock page for a module - it is the
+-- "interface" of the module. The core of Haddock lies in creating this
+-- structure (see Haddock.Interface).
+--
+-- The structure also holds intermediate data needed during its creation.
data HaddockModule = HM {
-- | A value to identify the module
@@ -151,3 +173,9 @@ data DocMarkup id a = Markup {
markupURL :: String -> a,
markupAName :: String -> a
}
+
+
+-- A monad which collects error messages
+
+type ErrMsg = String
+type ErrMsgM a = Writer [ErrMsg] a