Major refactoring

16 files changed, 249 insertions, 994 deletions

diff --git a/haddock.cabal b/haddock.cabal
index 8a8496b5..e97da9c0 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -23,10 +23,10 @@ ghc-options: -fglasgow-exts
 hs-source-dirs: src
 exposed-modules:
 	Distribution.Haddock
+  Haddock.Types
 other-modules:
   Haddock.InterfaceFile
   Haddock.Exception
-  Haddock.Types
 data-files:
 	html/haddock-DEBUG.css
 	html/haddock.css
@@ -76,23 +76,24 @@ main-is: Main.hs
 extensions: CPP, PatternGuards
 ghc-options: -fglasgow-exts
 other-modules:
-	Haddock.Utils.FastMutInt2
-	Haddock.Utils.BlockTable
-	Haddock.HaddockDB
-	Haddock.DevHelp
-	Haddock.HH
-	Haddock.HH2
-	Haddock.Hoogle
-	Haddock.Utils.Html
-	Haddock.ModuleTree
-	Haddock.Rename
-	Haddock.Types
-	Haddock.Utils
-	Haddock.Version
-	Haddock.Utils.Html
-	Haddock.Utils.GHC
-	Haddock.InterfaceFile        
-	Haddock.Exception
-	Haddock.Options
-	Haddock.Typecheck
-	Main
+  Haddock.Interface.Rename
+  Haddock.Interface.Create
+  Haddock.Utils.FastMutInt2
+  Haddock.Utils.BlockTable
+  Haddock.Utils.Html
+  Haddock.Utils
+  Haddock.Backends.HaddockDB
+  Haddock.Backends.DevHelp
+  Haddock.Backends.HH
+  Haddock.Backends.HH2
+  Haddock.Backends.Hoogle
+  Haddock.ModuleTree
+  Haddock.Types
+  Haddock.Version
+  Haddock.InterfaceFile        
+  Haddock.Exception
+  Haddock.Options
+  Haddock.GHC.Typecheck
+  Haddock.GHC.Utils
+  Haddock.GHC
+  Main
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
diff --git a/src/Main.hs b/src/Main.hs
index 8f3eda4e..c127f773 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,73 +10,35 @@
 module Main (main) where
 
 
-import Haddock.Html
-import Haddock.Hoogle
-import Haddock.Rename
+import Haddock.Packages
+import Haddock.Backends.Html
+import Haddock.Backends.Hoogle
+import Haddock.Interface
 import Haddock.Types hiding (NoLink)
-import Haddock.Utils
 import Haddock.Version
 import Haddock.InterfaceFile
 import Haddock.Exception
 import Haddock.Options
-import Haddock.Typecheck
-import Haddock.Packages
-import Haddock.Utils.GHC
+import Haddock.GHC
+import Haddock.Utils
 import Paths_haddock
 
-
-import Prelude hiding (catch)
-import Control.Exception     
 import Control.Monad
-import Control.Monad.Writer
-import Control.Arrow
-import Data.Char
-import Data.IORef
-import Data.Ord
-import Data.List
-import Data.Maybe
-import Data.Typeable
-import Data.Graph hiding (flattenSCC)
+import Control.Exception
+import Control.Exception
 import Data.Dynamic
-import Data.Foldable (foldlM)
-import System.Console.GetOpt 
-import System.Environment
-import System.Directory
-import System.FilePath
-import System.Cmd
-import System.Exit           
-import System.IO
-
+import Data.Maybe
+import Data.IORef
 import qualified Data.Map as Map
-import Data.Map (Map)
-
-import Distribution.InstalledPackageInfo
-import Distribution.Simple.Utils
-
+import System.IO
+import System.Exit
+import System.Environment
 
 import GHC
-import Outputable
-import SrcLoc
-import Name
-import Module
-import InstEnv
-import Class
-import TypeRep
-import Var hiding (varName)
-import TyCon
-import PrelNames
+import DynFlags
 import Bag
-import HscTypes
 import Util (handleDyn)
-import ErrUtils (printBagOfErrors)
-import UniqFM
-
-import FastString
-#define FSLIT(x) (mkFastString# (x#))
-
-import DynFlags hiding (Option)
-import Packages hiding (package) 
-import StaticFlags
+import ErrUtils
 
 
 --------------------------------------------------------------------------------
@@ -140,50 +102,48 @@ main = handleTopExceptions $ do
   -- parse command-line flags and handle some of them initially
   args <- getArgs
   (flags, fileArgs) <- parseHaddockOpts args
-  libDir <- handleFlags flags fileArgs
+  libDir <- handleEasyFlags flags fileArgs
   
   -- initialize GHC 
   restGhcFlags <- tryParseStaticFlags flags
-  (session, _) <- startGHC libDir
+  (session, _) <- startGhc libDir
 
-  -- parse and set the ghc flags
+  -- parse and set the GHC flags
   dynflags <- parseGhcFlags session restGhcFlags
   setSessionDynFlags session dynflags
 
-  -- get the -use-package packages, expose them to GHC,
-  -- and try to load their installed HaddockPackages
+  -- get the -use-package packages, load them in GHC,
+  -- and try to get the corresponding installed HaddockPackages
   let usePackages = [ pkg | Flag_UsePackage pkg <- flags ]
-  packages <- initAndReadPackages session usePackages
+  pkgInfos <- loadPackages session usePackages
+  packages <- getHaddockPackages pkgInfos 
 
   -- typecheck argument modules using GHC
   modules <- typecheckFiles session fileArgs
 
-  -- update the html references for rendering phase (global variable)
+  -- combine the link envs of the external packages into one
+  let extLinks = combineLinkEnvs packages
+
+  -- create the interfaces -- this is the core part of Haddock
+  let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags
+  mapM_ putStrLn messages
+
+  -- render the interfaces
   updateHTMLXRefs packages
+  render flags interfaces
 
-  -- combine the doc envs of the read packages into one
-  let env = combineDocEnvs packages
+  -- last but not least, dump the interface file!
+  dumpInterfaceFile homeLinks flags
 
-  -- TODO: continue to break up the run function into parts
-  run flags modules env
 
+-------------------------------------------------------------------------------
+-- Rendering
+-------------------------------------------------------------------------------
 
-startGHC :: String -> IO (Session, DynFlags)
-startGHC libDir = do
-  session <- newSession (Just libDir)
-  flags   <- getSessionDynFlags session
-  let flags' = dopt_set flags Opt_Haddock
-  let flags'' = flags' {
-      hscTarget = HscNothing,
-      ghcMode   = CompManager,
-      ghcLink   = NoLink
-    }
-  setSessionDynFlags session flags''
-  return (session, flags'')
 
- 
-run :: [Flag] -> [GhcModule] -> Map Name Name -> IO ()
-run flags modules extEnv = do
+-- | Render the interfaces with whatever backend is specified in the flags 
+render :: [Flag] -> [HaddockModule] -> IO ()
+render flags interfaces = do
   let
     title = case [str | Flag_Heading str <- flags] of
 		[] -> ""
@@ -229,23 +189,9 @@ run flags modules extEnv = do
 
   prologue <- getPrologue flags
 
-  let
-    -- run pass 1 on this data
-    (modMap, messages) = runWriter (pass1 modules flags) 
-
-    haddockMods = catMaybes [ Map.lookup (ghcModule m) modMap | m <- modules ]
-    homeEnv = buildGlobalDocEnv haddockMods
-    env = homeEnv `Map.union` extEnv
-    haddockMods' = attachInstances haddockMods
-    (haddockMods'', messages') = runWriter $ mapM (renameModule env) haddockMods'
-  
-  mapM_ putStrLn messages
-  mapM_ putStrLn messages'
-
   let 
-    visibleMods = [ m | m <- haddockMods'', OptHide `notElem` (hmod_options m) ]
-    packageName = (Just . packageIdString . modulePackageId . 
-                   hmod_mod . head) visibleMods
+    visibleMods = [ m | m <- interfaces, OptHide `notElem` (hmod_options m) ]
+    packageName = (Just . modulePkgStr . hmod_mod . head) visibleMods
  
   when (Flag_GenIndex `elem` flags) $ do
 	ppHtmlIndex odir title packageName maybe_html_help_format
@@ -269,23 +215,24 @@ run flags modules extEnv = do
                 maybe_contents_url maybe_index_url
     copyHtmlBits odir libdir css_file
 
-  let iface = InterfaceFile {
-        ifDocEnv  = homeEnv
---        ifModules = map hmod2interface visibleMods
-      }
-
-  case [str | Flag_DumpInterface str <- flags] of
-        [] -> return ()
-        fs -> let filename = (last fs) in 
-              writeInterfaceFile filename iface
-
 
 -------------------------------------------------------------------------------
--- Flags 
+-- Misc
 -------------------------------------------------------------------------------
 
 
-handleFlags flags fileArgs = do
+dumpInterfaceFile :: LinkEnv -> [Flag] -> IO ()
+dumpInterfaceFile homeLinks flags = 
+  case [str | Flag_DumpInterface str <- flags] of
+    [] -> return ()
+    fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
+  where 
+    ifaceFile = InterfaceFile {
+        ifLinkEnv  = homeLinks
+      }
+
+
+handleEasyFlags flags fileArgs = do
   usage <- getUsage
 
   when (Flag_Help    `elem` flags) (bye usage)
@@ -301,318 +248,12 @@ handleFlags flags fileArgs = do
     throwE ("-h cannot be used with --gen-index or --gen-contents")
 
   return ghcLibDir
-
-
--- | 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 :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM HaddockModule
-pass1data modData flags modMap = do
-
-  let mod = ghcModule modData
-
-  opts <- mkDocOpts (ghcMbDocOpts modData) mod
-
-  let group        = ghcGroup modData
-      entities     = (nubBy sameName . collectEntities) group
-      exports      = fmap (reverse . map unLoc) (ghcMbExports modData)
-      entityNames_ = entityNames entities
-      subNames     = allSubNames group
-      localNames   = entityNames_ ++ subNames
-      subMap       = mkSubMap group
-      expDeclMap   = mkDeclMap (ghcExportedNames modData) group
-      localDeclMap = mkDeclMap entityNames_ group
-      docMap       = mkDocMap group 
-      ignoreExps   = Flag_IgnoreAllExports `elem` flags
-
-  visibleNames <- mkVisibleNames mod modMap localNames (ghcNamesInScope modData) 
-                                 subMap exports opts localDeclMap 
-
-  exportItems <- mkExportItems modMap mod (ghcExportedNames modData)
-                               expDeclMap localDeclMap subMap entities 
-                               opts exports ignoreExps docMap 
-
-  -- prune the export list to just those declarations that have
-  -- documentation, if the 'prune' option is on.
-  let 
-    prunedExportItems
-      | OptPrune `elem` opts = pruneExportItems exportItems
-      | otherwise = exportItems
- 
-  return HM {
-    hmod_mod                = mod,
-    hmod_orig_filename      = ghcFilename modData,
-    hmod_info               = ghcHaddockModInfo modData,
-    hmod_doc                = ghcMbDoc modData,
-    hmod_rn_doc             = Nothing,
-    hmod_options            = opts,
-    hmod_locals             = localNames,
-    hmod_doc_map            = docMap,
-    hmod_rn_doc_map         = Map.empty,
-    hmod_sub_map            = subMap,
-    hmod_export_items       = prunedExportItems,
-    hmod_rn_export_items    = [], 
-    hmod_exports            = ghcExportedNames modData,
-    hmod_visible_exports    = visibleNames, 
-    hmod_exported_decl_map  = expDeclMap,
-    hmod_instances          = ghcInstances modData
-  }
-  where
-    mkDocOpts mbOpts mod = do
-      opts <- case mbOpts of 
-        Just opts -> processOptions opts
-        Nothing -> return []
-      let opts' = if Flag_HideModule (moduleString mod) `elem` flags 
-            then OptHide : opts
-            else opts      
-      return opts'
-
-
-sameName (DocEntity _) _ = False
-sameName (DeclEntity _) (DocEntity _) = False
-sameName (DeclEntity a) (DeclEntity b) = a == b
-
-
--- This map includes everything that can be exported separately,
--- that means: top declarations, class methods and record selectors
--- TODO: merge this with mkDeclMap and the extractXXX functions 
-mkDocMap :: HsGroup Name -> Map Name (HsDoc Name)
-mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs)
-  where
-    tyclds    = map unLoc (hs_tyclds group)
-    classes   = filter isClassDecl tyclds 
-    datadecls = filter isDataDecl tyclds
-    constrs   = [ con | d <- datadecls, L _ con <- tcdCons d ]
-    fields    = concat [ fields | RecCon fields <- map con_details constrs]
-
-    topDeclDocs   = collectDocs (collectEntities group)
-    classMethDocs = concatMap (collectDocs . collectClassEntities) classes
-
-    recordFieldDocs = [ (unLoc lname, doc) | 
-                        ConDeclField lname _ (Just (L _ doc)) <- fields ]
-
-
---------------------------------------------------------------------------------
--- Source code entities
---------------------------------------------------------------------------------
-
-
-data Entity = DocEntity (DocDecl Name) | DeclEntity Name
-data LEntity = Located Entity
-
-
-sortByLoc = map unLoc . sortBy (comparing getLoc)
-
-
--- | Collect all the entities in a class that can be documented. 
--- The entities are sorted by their SrcLoc.
-collectClassEntities tcd = sortByLoc (docs ++ meths ++ sigs)
-  where
-    docs = [ L l (DocEntity d) | L l d <- tcdDocs tcd ]
-    meths = 
-      let bindings = bagToList (tcdMeths tcd)
-          bindingName = unLoc . fun_id
-      in [ L l (DeclEntity (bindingName b)) | L l b <- bindings ] 
-    sigs = 
-      let sigName = fromJust . sigNameNoLoc 
-      in [ L l (DeclEntity (sigName sig)) | L l sig <- tcdSigs tcd ]  
-
-
--- | Collect all the entities in the source file that can be documented. 
--- The entities are sorted by their SrcLoc.
-collectEntities :: HsGroup Name -> [Entity]
-collectEntities group = sortByLoc (docs ++ declarations)
   where
-    docs = [ L l (DocEntity d) | L l d <- hs_docs group ]
-
-    declarations = [ L l (DeclEntity n) | (l, n) <- valds ++ tyclds ++ fords ]
-      where
-        valds = let ValBindsOut _ sigs = hs_valds group 
-             -- we just use the sigs here for now.
-             -- TODO: collect from the bindings as well 
-             -- (needed for docs to work for inferred entities)
-                in [ (l, fromJust (sigNameNoLoc s)) | L l s <- sigs ] 
-        tyclds = [ (l, tcdName t) | L l t <- hs_tyclds group ]
-        fords  = [ (l, forName f) | L l f <- hs_fords group ]  
-          where
-            forName (ForeignImport name _ _) = unLoc name
-            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
-
-
-collect :: Maybe Entity -> HsDoc Name -> [Entity] -> [(Name, HsDoc Name)]
-collect d doc_so_far [] =
-   case d of
-        Nothing -> []
-        Just d0  -> finishedDoc d0 doc_so_far []
-
-collect d doc_so_far (e:es) =
-  case e of
-    DocEntity (DocCommentNext str) ->
-      case d of
-        Nothing -> collect d (docAppend doc_so_far str) es
-        Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
-
-    DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es
-
-    _ -> case d of
-      Nothing -> collect (Just e) doc_so_far es
-      Just d0
-        | sameName d0 e -> collect d doc_so_far es  
-        | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)
-
-
-finishedDoc :: Entity -> HsDoc Name -> [(Name, HsDoc Name)] -> 
-               [(Name, HsDoc Name)]
-finishedDoc d DocEmpty rest = rest
-finishedDoc (DeclEntity name) doc rest = (name, doc) : rest
-finishedDoc _ _ rest = rest
-
-
--------------------------------------------------------------------------------
--- 
--------------------------------------------------------------------------------
-
-       
-allSubNames :: HsGroup Name -> [Name]
-allSubNames group = 
-  concat [ tail (map unLoc (tyClDeclNames tycld)) | L _ tycld <- hs_tyclds group ]
-
-
-mkSubMap :: HsGroup Name -> Map Name [Name]
-mkSubMap group = Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group,
- let name:subs = map unLoc (tyClDeclNames tycld) ]
-
-
-mkDeclMap :: [Name] -> HsGroup Name -> Map Name (LHsDecl Name) 
-mkDeclMap names group = Map.fromList [ (n,d)  | (n,Just d) <- maybeDecls ]
-  where 
-  maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ]
+    byeVersion = bye $
+      "Haddock version " ++ projectVersion ++ 
+      ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n"
 
 
-entityNames :: [Entity] -> [Name]
-entityNames entities = [ name | DeclEntity name <- entities ] 
-{-
-getValSig :: Name -> HsValBinds Name -> TypeEnv -> Maybe (LSig Name)
-getValSig name (ValBindsOut recsAndBinds _) typEnv = case matchingBinds of
-  [bind] -> -- OK we have found a binding that matches. Now look up the
-            -- type, even though it may be present in the ValBindsOut
-            let tything = lookupTypeEnv typeEnv name       
-  _ -> Nothing
-  where 
-    binds = snd $ unzip recsAndBinds 
-    matchingBinds = Bag.filter matchesName binds
-    matchesName (L _ bind) = fun_id bind == name
-getValSig _ _ _ = error "getValSig"
--}
-
-
-getDeclFromGroup :: HsGroup Name -> Name -> Maybe (LHsDecl Name)
-getDeclFromGroup group name = 
-  case catMaybes [ getDeclFromVals  (hs_valds  group), 
-                   getDeclFromTyCls (hs_tyclds group),
-                   getDeclFromFors  (hs_fords  group) ] of
-    [decl] -> Just decl
-    _ -> Nothing
-  where 
-    getDeclFromVals (ValBindsOut _ lsigs) = case matching of 
-      [lsig] -> Just (L (getLoc lsig) (SigD (unLoc lsig)))
-      _      -> Nothing
-     where 
-        matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name, 
-                     isNormal (unLoc lsig) ]
-        isNormal (TypeSig _ _) = True
-        isNormal _ = False
-
-    getDeclFromVals _ = error "getDeclFromVals: illegal input"
-
-{-    getDeclFromVals (ValBindsOut recsAndbinds _) = 
-      let binds = snd $ unzip recsAndBinds 
-          matchingBinds = Bag.filter matchesName binds
-          matchesName (L _ bind) = fun_id bind == name
-      in case matchingBinds of 
-        [bind] -> -- OK we have found a binding that matches. Now look up the
-                  -- type, even though it may be present in the ValBindsOut
-                  
-        _ -> Nothing
-     where 
-        matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name ]
-    getDeclFromVals _ = error "getDeclFromVals: illegal input"
-  -}    
-    getDeclFromTyCls ltycls = case matching of 
-      [ltycl] -> Just (L (getLoc ltycl) (TyClD (unLoc ltycl)))
-      _       -> Nothing
-      where
-        matching = [ ltycl | ltycl <- ltycls, 
-                     name `elem` map unLoc (tyClDeclNames (unLoc ltycl))]
- 
-    getDeclFromFors lfors = case matching of 
-      [for] -> Just (L (getLoc for) (ForD (unLoc for)))
-      _      -> Nothing
-      where
-        matching = [ for | for <- lfors, forName (unLoc for) == name ]
-        forName (ForeignExport n _ _) = unLoc n
-        forName (ForeignImport n _ _) = unLoc n
-
- 
-parseIfaceOption :: String -> (FilePath,FilePath)
-parseIfaceOption s = 
-  case break (==',') s of
-	(fpath,',':file) -> (fpath,file)
-	(file, _)        -> ("", file)
-
-	
 updateHTMLXRefs :: [HaddockPackage] -> IO ()
 updateHTMLXRefs packages = do
   writeIORef html_xrefs_ref (Map.fromList mapping)
@@ -631,452 +272,3 @@ getPrologue flags
 		Left err -> throwE err
 		Right doc -> return (Just doc)
 	_otherwise -> throwE "multiple -p/--prologue options"
-
-
--------------------------------------------------------------------------------
--- Phase 2
--------------------------------------------------------------------------------
-
-
-renameModule :: Map Name Name -> HaddockModule -> ErrMsgM HaddockModule
-renameModule renamingEnv mod =
-
-  -- first create the local env, where every name exported by this module
-  -- is mapped to itself, and everything else comes from the global renaming
-  -- env
-  let localEnv = foldl fn renamingEnv (hmod_visible_exports mod)
-        where fn env name = Map.insert name (nameSetMod name (hmod_mod mod)) env
-      
-      docs = Map.toList (hmod_doc_map mod)
-      renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') 
-
-      -- rename names in the exported declarations to point to things that
-      -- are closer to, or maybe even exported by, the current module.
-      (renamedExportItems, missingNames1)
-        = runRnFM localEnv (renameExportItems (hmod_export_items mod))
-
-      (rnDocMap, missingNames2) 
-        = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs))
-
-      (finalModuleDoc, missingNames3)
-        = runRnFM localEnv (renameMaybeDoc (hmod_doc mod))
-
-      -- combine the missing names and filter out the built-ins, which would
-      -- otherwise allways be missing. 
-      missingNames = nub $ filter isExternalName
-                    (missingNames1 ++ missingNames2 ++ missingNames3)
-
-      -- filter out certain built in type constructors using their string 
-      -- representation. TODO: use the Name constants from the GHC API.
-      strings = filter (`notElem` ["()", "[]", "(->)"]) 
-                (map (showSDoc . ppr) missingNames) 
-     
-  in do
-    -- report things that we couldn't link to. Only do this for non-hidden
-    -- modules.
-    when (OptHide `notElem` hmod_options mod && not (null strings)) $
-	  tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++ 
-		": could not find link destinations for:\n"++
-		"   " ++ concat (map (' ':) strings) ]
-
-    return $ mod { hmod_rn_doc = finalModuleDoc,
-                   hmod_rn_doc_map = rnDocMap,
-                   hmod_rn_export_items = renamedExportItems }
-
-
--- | Build the list of items that will become the documentation, from the
--- export list.  At this point, the list of ExportItems is in terms of
--- original names.
-mkExportItems
-  :: ModuleMap
-  -> Module			-- this module
-  -> [Name]			-- exported names (orig)
-  -> Map Name (LHsDecl Name) -- maps exported names to declarations
-  -> Map Name (LHsDecl Name) -- maps local names to declarations
-  -> Map Name [Name]	-- sub-map for this module
-  -> [Entity]	-- entities in the current module
-  -> [DocOption]
-  -> Maybe [IE Name]
-  -> Bool				-- --ignore-all-exports flag
-  -> Map Name (HsDoc Name)
-  -> ErrMsgM [ExportItem Name]
-
-mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_map entities
-              opts maybe_exps ignore_all_exports docMap
-  | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
-    = everything_local_exported
-  | Just specs <- maybe_exps = do 
-      exps <- mapM lookupExport specs
-      return (concat exps)
-  where
-    everything_local_exported =  -- everything exported
-      return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
-   
-    packageId = modulePackageId this_mod
-
-    lookupExport (IEVar x)             = declWith x
-    lookupExport (IEThingAbs t)        = declWith t
-    lookupExport (IEThingAll t)        = declWith t
-    lookupExport (IEThingWith t cs)    = declWith t
-    lookupExport (IEModuleContents m)  = fullContentsOf (mkModule packageId m)
-    lookupExport (IEGroup lev doc)     = return [ ExportGroup lev "" doc ]
-    lookupExport (IEDoc doc)           = return [ ExportDoc doc ] 
-    lookupExport (IEDocNamed str)
-	= do r <- findNamedDoc str entities
-	     case r of
-		Nothing -> return []
-		Just found -> return [ ExportDoc found ]
- 
-    declWith :: Name -> ErrMsgM [ ExportItem Name ]
-    declWith t
-	| (Just decl, maybeDoc) <- findDecl t
-        = return [ ExportDecl t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
-	| otherwise
-	= return []
-	where 
-              mdl = nameModule t
-	      subs = filter (`elem` exported_names) all_subs
-              all_subs | mdl == this_mod = Map.findWithDefault [] t sub_map
-		       | otherwise       = allSubsOfName mod_map t
-
-    fullContentsOf m  
-	| m == this_mod = return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
-	| otherwise = 
-	   case Map.lookup m mod_map of
-	     Just hmod
-		| OptHide `elem` hmod_options hmod
-			-> return (hmod_export_items hmod)
-		| otherwise -> return [ ExportModule m ]
-	     Nothing -> return [] -- already emitted a warning in visibleNames
-
-    findDecl :: Name -> (Maybe (LHsDecl Name), Maybe (HsDoc Name))
-    findDecl n | not (isExternalName n) = error "This shouldn't happen"
-    findDecl n 
-	| m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap)
-	| otherwise = 
-	   case Map.lookup m mod_map of
-		Just hmod -> (Map.lookup n (hmod_exported_decl_map hmod), 
-                              Map.lookup n (hmod_doc_map hmod))
-		Nothing -> (Nothing, Nothing)
-      where
-        m = nameModule n
-
-
-fullContentsOfThisModule :: Module -> [Entity] -> Map Name (LHsDecl Name) ->
-                            Map Name (HsDoc Name) -> [ExportItem Name]
-fullContentsOfThisModule module_ entities declMap docMap 
-  = catMaybes (map mkExportItem entities)
-  where 
-    mkExportItem (DocEntity (DocGroup lev doc)) = Just (ExportGroup lev "" doc)
-    mkExportItem (DeclEntity name) = fmap mkExport (Map.lookup name declMap) 
-      where mkExport decl = ExportDecl name decl (Map.lookup name docMap) []
-    mkExportItem _ = Nothing
-
-
--- | Sometimes the declaration we want to export is not the "main" declaration:
--- it might be an individual record selector or a class method.  In these
--- cases we have to extract the required declaration (and somehow cobble 
--- together a type signature for it...)
-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
-extractDecl name mdl decl
-  | Just n <- getMainDeclBinder (unLoc decl), n == name = decl
-  | otherwise  =  
-    case unLoc decl of
-      TyClD d | isClassDecl d -> 
-        let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name ] 
-        in case matches of 
-          [s0] -> let (n, tyvar_names) = name_and_tyvars d
-                      L pos sig = extractClassDecl n mdl tyvar_names s0
-                  in L pos (SigD sig)
-          _ -> error "internal: extractDecl" 
-      TyClD d | isDataDecl d -> 
-        let (n, tyvar_names) = name_and_tyvars d
-            L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d)
-        in L pos (SigD sig)
-      _ -> error "internal: extractDecl"
-  where
-    name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d))
-
-
-toTypeNoLoc :: Located Name -> LHsType Name
-toTypeNoLoc lname = noLoc (HsTyVar (unLoc lname))
-
-
-rmLoc :: Located a -> Located a
-rmLoc a = noLoc (unLoc a)
-
-
-extractClassDecl :: Name -> Module -> [Located Name] -> LSig Name -> LSig Name
-extractClassDecl c mdl tvs0 (L pos (TypeSig lname ltype)) = case ltype of
-  L _ (HsForAllTy exp tvs (L _ preds) ty) -> 
-    L pos (TypeSig lname (noLoc (HsForAllTy exp tvs (lctxt preds) ty)))
-  _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
-  where
-    lctxt preds = noLoc (ctxt preds)
-    ctxt preds = [noLoc (HsClassP c (map toTypeNoLoc tvs0))] ++ preds  
-
-extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl"
-
-
-extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name]
-              -> LSig Name
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
-
-extractRecSel nm mdl t tvs (L _ con : rest) =
-  case con_details con of
-    RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> 
-      L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty))))
-    _ -> extractRecSel nm mdl t tvs rest
- where 
-  matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, (unLoc n) == nm ]   
-  data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
-
-
--- Pruning
-pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
-pruneExportItems items = filter hasDoc items
-  where hasDoc (ExportDecl _ _ d _) = isJust d
-	hasDoc _ = True
-
-
--- | Gather a list of original names exported from this module
-mkVisibleNames :: Module 
-             -> ModuleMap  
-             -> [Name] 
-             -> [Name]
-             -> Map Name [Name]
-             -> Maybe [IE Name]
-             -> [DocOption]
-             -> Map Name (LHsDecl Name)
-             -> ErrMsgM [Name]
-
-mkVisibleNames mdl modMap localNames scope subMap maybeExps opts declMap 
-  -- if no export list, just return all local names 
-  | Nothing <- maybeExps         = return (filter hasDecl localNames)
-  | OptIgnoreExports `elem` opts = return localNames
-  | Just expspecs <- maybeExps = do
-      visibleNames <- mapM extract expspecs
-      return $ filter isNotPackageName (concat visibleNames)
- where
-  hasDecl name = isJust (Map.lookup name declMap)
-  isNotPackageName name = nameMod == mdl || isJust (Map.lookup nameMod modMap)
-    where nameMod = nameModule name
-
-  extract e = 
-   case e of
-    IEVar x -> return [x]
-    IEThingAbs t -> return [t]
-    IEThingAll t -> return (t : all_subs)
-	 where
-	      all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap
-		       | otherwise = allSubsOfName modMap t
-
-    IEThingWith t cs -> return (t : cs)
-	
-    IEModuleContents m
-	| mkModule (modulePackageId mdl) m == mdl -> return localNames 
-	| otherwise -> let m' = mkModule (modulePackageId mdl) m in
-	  case Map.lookup m' modMap of
-	    Just mod
-		| OptHide `elem` hmod_options mod ->
-		    return (filter (`elem` scope) (hmod_exports mod))
-		| otherwise -> return []
-	    Nothing
-		-> tell (exportModuleMissingErr mdl m') >> return []
-  
-    _ -> return []
-
-
-exportModuleMissingErr this mdl 
-  = ["Warning: in export list of " ++ show (moduleString this)
-	 ++ ": module not found: " ++ show (moduleString mdl)]
-
-
--- | For a given entity, find all the names it "owns" (ie. all the
--- constructors and field names of a tycon, or all the methods of a
--- class).
-allSubsOfName :: ModuleMap -> Name -> [Name]
-allSubsOfName mod_map name 
-  | isExternalName name =
-    case Map.lookup (nameModule name) mod_map of
-      Just hmod -> Map.findWithDefault [] name (hmod_sub_map hmod)
-      Nothing   -> []
-  | otherwise =  error $ "Main.allSubsOfName: unexpected unqual'd name"
-
-
--- | 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.
-buildGlobalDocEnv :: [HaddockModule] -> Map Name Name
-buildGlobalDocEnv 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 
-
-
--- Named documentation
-
-findNamedDoc :: String -> [Entity] -> ErrMsgM (Maybe (HsDoc Name))
-findNamedDoc name entities = search entities 
-	where search [] = do
-		tell ["Cannot find documentation for: $" ++ name]
-		return Nothing
-	      search ((DocEntity (DocCommentNamed name' doc)):rest) 
-			| name == name' = return (Just doc)
-		   	| otherwise = search rest
-	      search (_other_decl : rest) = search rest
-
-
--- Haddock options embedded in the source file
-
-processOptions_ str = let (opts, msg) = runWriter (processOptions str) 
-                      in print msg >> return opts 
-
-processOptions :: String -> ErrMsgM [DocOption]
-processOptions str = do
-  case break (== ',') str of
-    (this, ',':rest) -> do
-	opt <- parseOption this
-	opts <- processOptions rest
-	return (maybeToList opt ++ opts)
-    (this, _)
-	| all isSpace this -> return []
-	| otherwise -> do opt <- parseOption this; return (maybeToList opt)
-
-
-parseOption :: String -> ErrMsgM (Maybe DocOption)
-parseOption "hide" = return (Just OptHide)
-parseOption "prune" = return (Just OptPrune)
-parseOption "ignore-exports" = return (Just OptIgnoreExports)
-parseOption "not-home" = return (Just OptNotHome)
-parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing
-
-
--- | Simplified type for sorting types, ignoring qualification (not visible
--- in Haddock output) and unifying special tycons with normal ones.
-data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
-
-
-attachInstances :: [HaddockModule] -> [HaddockModule]
-attachInstances modules = map attach modules
-  where
-    instMap = fmap (map toHsInstHead . sortImage instHead) $ collectInstances modules
-    attach mod = mod { hmod_export_items = newItems }
-      where
-        newItems = map attachExport (hmod_export_items mod)
-
-        attachExport (ExportDecl n decl doc _) =
-          ExportDecl n decl doc (case Map.lookup n instMap of
-                                   Nothing -> []
-                                   Just instheads -> instheads)
-        attachExport otherExport = otherExport
-
-
-collectInstances
-   :: [HaddockModule]
-   -> Map Name [([TyVar], [PredType], Class, [Type])]  -- maps class/type names to instances
-
-collectInstances modules
-  = Map.fromListWith (flip (++)) tyInstPairs `Map.union`
-    Map.fromListWith (flip (++)) classInstPairs
-  where
-    allInstances = concat (map hmod_instances modules)
-    classInstPairs = [ (is_cls inst, [instanceHead inst]) | 
-                       inst <- allInstances ]
-    tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, 
-                    Just tycon <- nub (is_tcs inst) ]
-
-
-instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
-instHead (_, _, cls, args)
-  = (map argCount args, className cls, map simplify args)
-  where
-    argCount (AppTy t _) = argCount t + 1
-    argCount (TyConApp _ ts) = length ts
-    argCount (FunTy _ _ ) = 2
-    argCount (ForAllTy _ t) = argCount t
-    argCount (NoteTy _ t) = argCount t
-    argCount _ = 0
-
-    simplify (ForAllTy _ t) = simplify t
-    simplify (FunTy t1 t2) = 
-      SimpleType funTyConName [simplify t1, simplify t2]
-    simplify (AppTy t1 t2) = SimpleType s (args ++ [simplify t2])
-      where (SimpleType s args) = simplify t1
-    simplify (TyVarTy v) = SimpleType (tyVarName v) []
-    simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
-    simplify (NoteTy _ t) = simplify t
-    simplify _ = error "simplify"
-
-
--- sortImage f = sortBy (\x y -> compare (f x) (f y))
-sortImage :: Ord b => (a -> b) -> [a] -> [a]
-sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]
- where cmp_fst (x,_) (y,_) = compare x y
-
-
-funTyConName = mkWiredInName gHC_PRIM
-                        (mkOccNameFS tcName FSLIT("(->)"))
-                        funTyConKey
-                        (ATyCon funTyCon)       -- Relevant TyCon
-                        BuiltInSyntax
-
-
-toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts) 
-
-
---------------------------------------------------------------------------------
--- Type -> HsType conversion
---------------------------------------------------------------------------------
-
-
-toHsPred :: PredType -> HsPred Name 
-toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts)
-toHsPred (IParam n t) = HsIParam n (toLHsType t)
-
-
-toLHsType = noLoc . toHsType
-
- 
-toHsType :: Type -> HsType Name
-toHsType t = case t of 
-  TyVarTy v -> HsTyVar (tyVarName v) 
-  AppTy a b -> HsAppTy (toLHsType a) (toLHsType b)
-  TyConApp tc ts -> case ts of 
-    [] -> HsTyVar (tyConName tc)
-    _  -> app (tycon tc) ts
-  FunTy a b -> HsFunTy (toLHsType a) (toLHsType b) 
-  ForAllTy v t -> cvForAll [v] t 
-  PredTy p -> HsPredTy (toHsPred p) 
-  NoteTy _ t -> toHsType t
-  where
-    tycon tc = HsTyVar (tyConName tc)
-    app tc ts = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc (map toHsType ts)
-    cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t
-    cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t)
-    tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs
-
-
--- A monad which collects error messages
-
-type ErrMsg = String
-type ErrMsgM a = Writer [ErrMsg] a