Factor out typechecking phase into Haddock.Typecheck

5 files changed, 268 insertions, 212 deletions

diff --git a/src/Haddock/Html.hs b/src/Haddock/Html.hs
index 79a2625f..74aa4e34 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 00000000..088ee8a1
--- /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 a7f5f8a9..52618c30 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 8393cbb2..3ac90d77 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 7223b8f6..e7b52e4d 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