diff options
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.hs | 91 | ||||
-rw-r--r-- | src/Haddock/InterfaceFile.hs | 2 | ||||
-rw-r--r-- | src/Haddock/Options.hs | 3 | ||||
-rw-r--r-- | src/Haddock/Packages.hs | 89 | ||||
-rw-r--r-- | src/Haddock/Syntax/Rename.hs (renamed from src/Haddock/Rename.hs) | 5 | ||||
-rw-r--r-- | src/Haddock/Types.hs | 32 |
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 |