Factor out typechecking phase into Haddock.Typecheck

1 files changed, 101 insertions, 187 deletions

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