diff --git a/haddock.cabal b/haddock.cabal
index 87881708bd2e59360f2fc53aef8a1b995f3f3292..8a8496b50394b5e7ae54b61015b8dae5ad8a7e7f 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -94,4 +94,5 @@ other-modules:
Haddock.InterfaceFile
Haddock.Exception
Haddock.Options
+ Haddock.Typecheck
Main
diff --git a/src/Haddock/Html.hs b/src/Haddock/Html.hs
index 79a2625fcd44fae484cc189766a75708dbe2373b..74aa4e3463994e3b08bfe92a8fdf354fdfbc945c 100644
--- a/src/Haddock/Html.hs
+++ b/src/Haddock/Html.hs
@@ -17,8 +17,9 @@ import Haddock.HH
import Haddock.HH2
import Haddock.ModuleTree
import Haddock.Types
-import Haddock.Utils
import Haddock.Version
+import Haddock.Utils
+import Haddock.Utils.GHC
import Haddock.Utils.Html
import qualified Haddock.Utils.Html as Html
diff --git a/src/Haddock/Typecheck.hs b/src/Haddock/Typecheck.hs
new file mode 100644
index 0000000000000000000000000000000000000000..088ee8a10940b71921bc6b7c1ee4a9e84aaf6d96
--- /dev/null
+++ b/src/Haddock/Typecheck.hs
@@ -0,0 +1,123 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Typecheck (
+ GhcModule(..),
+ typecheckFiles
+) where
+
+
+import Haddock.Exception
+import Haddock.Utils.GHC
+
+
+import Data.Maybe
+import Control.Monad
+import GHC
+import Digraph
+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
+ return (map mkGhcModule checkedMods)
+
+
+-- | Get the sorted graph of all loaded modules and their dependencies
+getSortedModuleGraph :: Session -> IO [(Module, FilePath)]
+getSortedModuleGraph session = do
+ mbModGraph <- depanal session [] True
+ moduleGraph <- case mbModGraph of
+ Just mg -> return mg
+ Nothing -> throwE "Failed to load all modules"
+ let
+ getModFile = fromJust . ml_hs_file . ms_location
+ sortedGraph = topSortModuleGraph False moduleGraph Nothing
+ sortedModules = concatMap flattenSCC sortedGraph
+ modsAndFiles = [ (ms_mod modsum, getModFile modsum) |
+ modsum <- sortedModules ]
+ return modsAndFiles
+
+
+type CheckedMod = (Module, FilePath, FullyCheckedMod)
+
+
+type FullyCheckedMod = (ParsedSource,
+ RenamedSource,
+ TypecheckedSource,
+ ModuleInfo)
+
+
+-- TODO: make it handle cleanup
+sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod]
+sortAndCheckModules session files = do
+
+ -- load all argument files
+
+ targets <- mapM (\f -> guessTarget f Nothing) files
+ setTargets session targets
+
+ -- compute the dependencies and load them as well
+
+ allMods <- getSortedModuleGraph session
+ targets' <- mapM (\(_, f) -> guessTarget f Nothing) allMods
+ setTargets session targets'
+
+ flag <- load session LoadAllTargets
+ when (failed flag) $
+ throwE "Failed to load all needed modules"
+
+ -- typecheck the argument modules
+
+ let argMods = filter ((`elem` files) . snd) allMods
+
+ checkedMods <- forM argMods $ \(mod, file) -> do
+ mbMod <- checkModule session (moduleName mod) False
+ case mbMod of
+ Just (CheckedModule a (Just b) (Just c) (Just d) _)
+ -> return (mod, file, (a,b,c,d))
+ _ -> throwE ("Failed to check module: " ++ moduleString mod)
+
+ return checkedMods
+
+
+-- | Dig out what we want from the typechecker output
+mkGhcModule :: CheckedMod -> GhcModule
+mkGhcModule (mod, file, checkedMod) = GhcModule {
+ ghcModule = mod,
+ ghcFilename = file,
+ ghcMbDocOpts = mbOpts,
+ ghcHaddockModInfo = info,
+ ghcMbDoc = mbDoc,
+ ghcGroup = group,
+ ghcMbExports = mbExports,
+ ghcExportedNames = modInfoExports modInfo,
+ ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo,
+ ghcInstances = modInfoInstances modInfo
+}
+ where
+ HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed
+ (group, _, mbExports, mbDoc, info) = renamed
+ (parsed, renamed, _, modInfo) = checkedMod
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index a7f5f8a9f23f0341a4da070ff0073c286408942d..52618c30f5c13db39116b1c866589a7ed9fef541 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -20,8 +20,7 @@ module Haddock.Utils (
-- * Miscellaneous utilities
getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
- isConSym, isVarSym, nameOccString, moduleString, mkModuleNoPkg,
-
+
-- * HTML cross reference mapping
html_xrefs_ref,
@@ -231,18 +230,6 @@ escapeStr = flip escapeString unreserved
escapeStr = escapeURIString isUnreserved
#endif
--- there should be a better way to check this using the GHC API
-isConSym n = head (nameOccString n) == ':'
-isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar
- where fstChar = head (nameOccString n)
-
-nameOccString = occNameString . nameOccName
-
-moduleString :: Module -> String
-moduleString = moduleNameString . moduleName
-
-mkModuleNoPkg :: String -> Module
-mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
-----------------------------------------------------------------------------
-- HTML cross references
diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs
index 8393cbb2e2236c194792508c42364528dc0f1237..3ac90d7797fdd0bd71f8c31343281eb93048695a 100644
--- a/src/Haddock/Utils/GHC.hs
+++ b/src/Haddock/Utils/GHC.hs
@@ -4,9 +4,12 @@
-- (c) Simon Marlow 2003
--
+
module Haddock.Utils.GHC where
+
import Debug.Trace
+import Data.Char
import GHC
import HsSyn
@@ -17,6 +20,42 @@ import Packages
import UniqFM
import Name
+
+-- names
+
+nameOccString = occNameString . nameOccName
+
+
+nameSetMod n newMod =
+ mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)
+
+
+nameSetPkg pkgId n =
+ mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod))
+ (nameOccName n) (nameSrcSpan n)
+ where mod = nameModule n
+
+
+-- modules
+
+
+moduleString :: Module -> String
+moduleString = moduleNameString . moduleName
+
+
+mkModuleNoPkg :: String -> Module
+mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
+
+
+-- misc
+
+
+-- there should be a better way to check this using the GHC API
+isConSym n = head (nameOccString n) == ':'
+isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar
+ where fstChar = head (nameOccString n)
+
+
getMainDeclBinder :: HsDecl name -> Maybe name
getMainDeclBinder (TyClD d) = Just (tcdName d)
getMainDeclBinder (ValD d)
@@ -28,18 +67,10 @@ getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing
getMainDeclBinder _ = Nothing
+
-- To keep if if minf_iface is re-introduced
--modInfoName = moduleName . mi_module . minf_iface
--modInfoMod = mi_module . minf_iface
-trace_ppr x y = trace (showSDoc (ppr x)) y
--- names
-
-nameSetMod n newMod =
- mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)
-
-nameSetPkg pkgId n =
- mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod))
- (nameOccName n) (nameSrcSpan n)
- where mod = nameModule n
+trace_ppr x y = trace (showSDoc (ppr x)) y
diff --git a/src/Main.hs b/src/Main.hs
index 7223b8f6aed1cde8035fbe270604609c81f31383..e7b52e4dc9a8ec5b842e3379088bd81bca98c876 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -19,6 +19,7 @@ import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Exception
import Haddock.Options
+import Haddock.Typecheck
import Haddock.Utils.GHC
import Paths_haddock
@@ -55,7 +56,6 @@ import Distribution.Simple.Utils
import GHC
import Outputable
import SrcLoc
-import Digraph
import Name
import Module
import InstEnv
@@ -68,7 +68,6 @@ import Bag
import HscTypes
import Util (handleDyn)
import ErrUtils (printBagOfErrors)
-import BasicTypes
import UniqFM
import FastString
@@ -129,9 +128,9 @@ handleGhcExceptions inner =
) inner
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
-- Top-level
---------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
main :: IO ()
@@ -165,7 +164,7 @@ main = handleTopExceptions $ do
packages <- getPackages session exposedPackages
-- typechecking
- modules <- sortAndCheckModules session fileArgs
+ modules <- typecheckFiles session fileArgs
-- update the html references for rendering phase (global variable)
updateHTMLXRefs packages
@@ -177,84 +176,6 @@ main = handleTopExceptions $ do
run flags modules env
-handleFlags flags fileArgs = do
- usage <- getUsage
-
- when (Flag_Help `elem` flags) (bye usage)
- when (Flag_Version `elem` flags) byeVersion
- when (null fileArgs) (bye usage)
-
- let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of
- [] -> throwE "no GHC lib dir specified"
- xs -> last xs
-
- when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
- && Flag_Html `elem` flags) $
- throwE ("-h cannot be used with --gen-index or --gen-contents")
-
- return ghcLibDir
-
-
--- | Handle the -use-package flags
---
--- Returns the names of the packages (without version number), if parsing
--- succeeded.
---
--- It would be better to try to get the "exposed" 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 exposed packages).
-getUsePackages :: [Flag] -> Session -> IO [String]
-getUsePackages flags session = do
-
- -- get the packages from the commandline flags
- let packages = [ pkg | Flag_UsePackage pkg <- flags ]
-
- -- expose these packages
- -- (makes "-use-package pkg" equal to "-g '-package pkg'")
-
- dfs <- getSessionDynFlags session
- let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage packages }
- setSessionDynFlags session dfs'
-
- -- try to parse these packages into PackageIndentifiers
-
- mapM (handleParse . unpackPackageId . stringToPackageId) packages
- where
- handleParse (Just pkg) = return (pkgName pkg)
- handleParse Nothing = throwE "Could not parse package identifier"
-
-
--------------------------------------------------------------------------------
--- Flags
--------------------------------------------------------------------------------
-
-
--- | Filter out the GHC specific flags and try to parse and set them as static
--- flags. Return a list of flags that couldn't be parsed.
-tryParseStaticFlags flags = do
- let ghcFlags = [ str | Flag_GhcFlag str <- flags ]
- parseStaticFlags ghcFlags
-
-
--- | Try to parse dynamic GHC flags
-parseGhcFlags session ghcFlags = do
- dflags <- getSessionDynFlags session
- foldlM parseFlag dflags (map words ghcFlags)
- where
- -- try to parse a flag as either a dynamic or static GHC flag
- parseFlag dynflags ghcFlag = do
- (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag
- when (rest == ghcFlag) $
- throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag))
- return dynflags'
-
-
-byeVersion =
- bye ("Haddock version " ++ projectVersion ++
- ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n")
-
-
startGHC :: String -> IO (Session, DynFlags)
startGHC libDir = do
session <- newSession (Just libDir)
@@ -268,57 +189,8 @@ startGHC libDir = do
setSessionDynFlags session flags''
return (session, flags'')
-
--- | Get the sorted graph of all loaded modules and their dependencies
-getSortedModuleGraph :: Session -> IO [(Module, FilePath)]
-getSortedModuleGraph session = do
- mbModGraph <- depanal session [] True
- moduleGraph <- case mbModGraph of
- Just mg -> return mg
- Nothing -> throwE "Failed to load all modules"
- let
- getModFile = fromJust . ml_hs_file . ms_location
- sortedGraph = topSortModuleGraph False moduleGraph Nothing
- sortedModules = concatMap flattenSCC sortedGraph
- modsAndFiles = [ (ms_mod modsum, getModFile modsum) |
- modsum <- sortedModules ]
- return modsAndFiles
-
-
--- TODO: make it handle cleanup
-sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod]
-sortAndCheckModules session files = do
-
- -- load all argument files
-
- targets <- mapM (\f -> guessTarget f Nothing) files
- setTargets session targets
-
- -- compute the dependencies and load them as well
-
- allMods <- getSortedModuleGraph session
- targets' <- mapM (\(_, f) -> guessTarget f Nothing) allMods
- setTargets session targets'
-
- flag <- load session LoadAllTargets
- when (failed flag) $
- throwE "Failed to load all needed modules"
-
- -- typecheck the argument modules
-
- let argMods = filter ((`elem` files) . snd) allMods
-
- checkedMods <- forM argMods $ \(mod, file) -> do
- mbMod <- checkModule session (moduleName mod) False
- case mbMod of
- Just (CheckedModule a (Just b) (Just c) (Just d) _)
- -> return (mod, file, (a,b,c,d))
- _ -> throwE ("Failed to check module: " ++ moduleString mod)
-
- return checkedMods
-
-
-run :: [Flag] -> [CheckedMod] -> Map Name Name -> IO ()
+
+run :: [Flag] -> [GhcModule] -> Map Name Name -> IO ()
run flags modules extEnv = do
let
title = case [str | Flag_Heading str <- flags] of
@@ -366,12 +238,10 @@ run flags modules extEnv = do
prologue <- getPrologue flags
let
- -- collect the data from GHC that we need for each home module
- ghcModuleData = map moduleDataGHC modules
-- run pass 1 on this data
- (modMap, messages) = runWriter (pass1 ghcModuleData flags)
+ (modMap, messages) = runWriter (pass1 modules flags)
- haddockMods = catMaybes [ Map.lookup mod modMap | (mod,_,_) <- modules ]
+ haddockMods = catMaybes [ Map.lookup (ghcModule m) modMap | m <- modules ]
homeEnv = buildGlobalDocEnv haddockMods
env = homeEnv `Map.union` extEnv
haddockMods' = attachInstances haddockMods
@@ -418,55 +288,105 @@ run flags modules extEnv = do
writeInterfaceFile filename iface
-type CheckedMod = (Module, FilePath, FullyCheckedMod)
+-------------------------------------------------------------------------------
+-- Flags
+-------------------------------------------------------------------------------
+
-type FullyCheckedMod = (ParsedSource,
- RenamedSource,
- TypecheckedSource,
- ModuleInfo)
+handleFlags flags fileArgs = do
+ usage <- getUsage
+ when (Flag_Help `elem` flags) (bye usage)
+ when (Flag_Version `elem` flags) byeVersion
+ when (null fileArgs) (bye usage)
--- | This data structure collects all the information we need about a home
--- package module
-data ModuleDataGHC = ModuleDataGHC {
- 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]
-}
+ let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of
+ [] -> throwE "no GHC lib dir specified"
+ xs -> last xs
+ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
+ && Flag_Html `elem` flags) $
+ throwE ("-h cannot be used with --gen-index or --gen-contents")
--- | Dig out what we want from the GHC API without altering anything
-moduleDataGHC :: CheckedMod -> ModuleDataGHC
-moduleDataGHC (mod, file, checkedMod) = ModuleDataGHC {
- ghcModule = mod,
- ghcFilename = file,
- ghcMbDocOpts = mbOpts,
- ghcHaddockModInfo = info,
- ghcMbDoc = mbDoc,
- ghcGroup = group,
- ghcMbExports = mbExports,
- ghcExportedNames = modInfoExports modInfo,
- ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo,
- ghcInstances = modInfoInstances modInfo
-}
+ return ghcLibDir
+
+
+-- | Handle the -use-package flags
+--
+-- Returns the names of the packages (without version number), if parsing
+-- succeeded.
+--
+-- It would be better to try to get the "exposed" 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 exposed packages).
+getUsePackages :: [Flag] -> Session -> IO [String]
+getUsePackages flags session = do
+
+ -- get the packages from the commandline flags
+ let packages = [ pkg | Flag_UsePackage pkg <- flags ]
+
+ -- expose these packages
+ -- (makes "-use-package pkg" equal to "-g '-package pkg'")
+
+ dfs <- getSessionDynFlags session
+ let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage packages }
+ setSessionDynFlags session dfs'
+
+ -- try to parse these packages into PackageIndentifiers
+
+ mapM (handleParse . unpackPackageId . stringToPackageId) packages
where
- HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed
- (group, _, mbExports, mbDoc, info) = renamed
- (parsed, renamed, _, modInfo) = checkedMod
+ handleParse (Just pkg) = return (pkgName pkg)
+ handleParse Nothing = throwE "Could not parse package identifier"
--- | Massage the data in ModuleDataGHC to produce something closer to what
+-- | Filter out the GHC specific flags and try to parse and set them as static
+-- flags. Return a list of flags that couldn't be parsed.
+tryParseStaticFlags flags = do
+ let ghcFlags = [ str | Flag_GhcFlag str <- flags ]
+ parseStaticFlags ghcFlags
+
+
+-- | Try to parse dynamic GHC flags
+parseGhcFlags session ghcFlags = do
+ dflags <- getSessionDynFlags session
+ foldlM parseFlag dflags (map words ghcFlags)
+ where
+ -- try to parse a flag as either a dynamic or static GHC flag
+ parseFlag dynflags ghcFlag = do
+ (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag
+ when (rest == ghcFlag) $
+ throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag))
+ return dynflags'
+
+
+byeVersion =
+ bye ("Haddock version " ++ projectVersion ++
+ ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n")
+
+
+-------------------------------------------------------------------------------
+-- Phase 1
+-------------------------------------------------------------------------------
+
+
+-- | Produce a map of HaddockModules with information that is close to
+-- renderable. What is lacking after this pass are the renamed export items.
+pass1 :: [GhcModule] -> [Flag] -> ErrMsgM ModuleMap
+pass1 modules flags = foldM produceAndInsert Map.empty modules
+ where
+ produceAndInsert modMap modData = do
+ resultMod <- pass1data modData flags modMap
+ let key = ghcModule modData
+ return (Map.insert key resultMod modMap)
+
+
+-- | Massage the data in GhcModule to produce something closer to what
-- we want to render. To do this, we need access to modules before this one
-- in the topological sort, to which we have already done this conversion.
-- That's what's in the ModuleMap.
-pass1data :: ModuleDataGHC -> [Flag] -> ModuleMap -> ErrMsgM HaddockModule
+pass1data :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM HaddockModule
pass1data modData flags modMap = do
let mod = ghcModule modData
@@ -528,17 +448,6 @@ pass1data modData flags modMap = do
return opts'
--- | Produce a map of HaddockModules with information that is close to
--- renderable. What is lacking after this pass are the renamed export items.
-pass1 :: [ModuleDataGHC] -> [Flag] -> ErrMsgM ModuleMap
-pass1 modules flags = foldM produceAndInsert Map.empty modules
- where
- produceAndInsert modMap modData = do
- resultMod <- pass1data modData flags modMap
- let key = ghcModule modData
- return (Map.insert key resultMod modMap)
-
-
sameName (DocEntity _) _ = False
sameName (DeclEntity _) (DocEntity _) = False
sameName (DeclEntity a) (DeclEntity b) = a == b
@@ -610,6 +519,11 @@ collectEntities group = sortByLoc (docs ++ declarations)
forName (ForeignExport name _ _) = unLoc name
+--------------------------------------------------------------------------------
+-- Collect docs
+--------------------------------------------------------------------------------
+
+
-- | Collect the docs and attach them to the right name
collectDocs :: [Entity] -> [(Name, HsDoc Name)]
collectDocs entities = collect Nothing DocEmpty entities