Major refactoring

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