Add some modules that I forgot to add earlier

4 files changed, 1224 insertions, 0 deletions

diff --git a/src/Haddock/GHC.hs b/src/Haddock/GHC.hs
new file mode 100644
index 00000000..b4b9dd3f
--- /dev/null
+++ b/src/Haddock/GHC.hs
@@ -0,0 +1,108 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.GHC (
+  startGhc,
+  loadPackages,
+  tryParseStaticFlags,
+  parseGhcFlags,
+  module Haddock.GHC.Typecheck,
+  module Haddock.GHC.Utils
+) where
+
+
+import Haddock.GHC.Typecheck
+import Haddock.GHC.Utils
+import Haddock.Exception
+import Haddock.Options
+
+import Data.Foldable (foldlM)
+import Data.Maybe
+import Control.Monad
+
+import GHC
+import DynFlags hiding (Option)
+import Packages hiding (package)
+import StaticFlags
+
+
+-- | Start a GHC session with the -haddock flag set. Also turn off 
+-- compilation and linking.  
+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'')
+
+
+-- | 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, return its InstalledPackageInfo. 
+
+loadPackages :: Session -> [String] -> IO [InstalledPackageInfo]
+
+-- 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).
+
+loadPackages 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
+  (dfs'', 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 ]
+
+  -- get InstalledPackageInfos for each package
+  let pkgInfos = map (getPackageDetails (pkgState dfs'')) matchingPackages
+
+  return pkgInfos
+  where
+    handleParse (Just pkg) = return (pkgName pkg)
+    handleParse Nothing = throwE "Could not parse package identifier"
+
+
+-- | 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'
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
new file mode 100644
index 00000000..51c531e1
--- /dev/null
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -0,0 +1,134 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Interface.AttachInstances (attachInstances) where
+
+
+import Haddock.Types
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List
+
+import GHC
+import Name
+import SrcLoc
+import InstEnv
+import Class
+import TypeRep
+import Var hiding (varName)
+import TyCon
+import PrelNames
+import HscTypes
+import FastString
+#define FSLIT(x) (mkFastString# (x#))
+
+
+attachInstances :: [Interface] -> [Interface]
+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
+
+
+-- | 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)
+
+
+collectInstances
+   :: [Interface]
+   -> 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
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
new file mode 100644
index 00000000..161b2851
--- /dev/null
+++ b/src/Haddock/Interface/Create.hs
@@ -0,0 +1,578 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Interface.Create (createInterface) where
+
+
+import Haddock.Types
+import Haddock.Options
+import Haddock.GHC.Utils
+import Haddock.Utils
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List
+import Data.Maybe
+import Data.Char
+import Data.Ord
+import Control.Monad.Writer
+
+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 Bag
+import HscTypes
+import Util (handleDyn)
+import ErrUtils (printBagOfErrors)
+import FastString
+#define FSLIT(x) (mkFastString# (x#))
+
+
+type LookupMod = (Module -> Maybe Interface)
+
+
+-- | Process the data in the GhcModule to produce an interface.
+-- To do this, we need access to already processed modules in the topological
+-- sort. That's what's in the module map.
+createInterface :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM Interface
+createInterface ghcMod flags modMap = do
+
+  let mod = ghcModule ghcMod
+
+  opts <- mkDocOpts (ghcMbDocOpts ghcMod) flags mod
+
+  let group        = ghcGroup ghcMod
+      entities     = (nubBy sameName . getTopEntities) group
+      exports      = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
+      entityNames_ = entityNames entities
+      subNames     = allSubNames group
+      localNames   = entityNames_ ++ subNames
+      subMap       = mkSubMap group
+      expDeclMap   = mkDeclMap (ghcExportedNames ghcMod) group
+      localDeclMap = mkDeclMap entityNames_ group
+      docMap       = mkDocMap group 
+      ignoreExps   = Flag_IgnoreAllExports `elem` flags
+      lookupMod m  = Map.lookup mod modMap
+
+  visibleNames <- mkVisibleNames mod lookupMod localNames 
+                                 (ghcNamesInScope ghcMod) 
+                                 subMap exports opts localDeclMap 
+
+  exportItems <- mkExportItems lookupMod mod (ghcExportedNames ghcMod)
+                               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 Interface {
+    hmod_mod                = mod,
+    hmod_orig_filename      = ghcFilename ghcMod,
+    hmod_info               = ghcHaddockModInfo ghcMod,
+    hmod_doc                = ghcMbDoc ghcMod,
+    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 ghcMod,
+    hmod_visible_exports    = visibleNames, 
+    hmod_exported_decl_map  = expDeclMap,
+    hmod_instances          = ghcInstances ghcMod
+  }
+
+
+-------------------------------------------------------------------------------
+-- Doc options
+--
+-- Haddock options that are embedded in the source file
+-------------------------------------------------------------------------------
+
+
+mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
+mkDocOpts mbOpts flags 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'
+
+
+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 = tell ["Unrecognised option: " ++ other] >> return Nothing
+
+
+--------------------------------------------------------------------------------
+-- Source code entities
+-- 
+-- An entity is a Haskell declaration or a Haddock comment. We need to extract
+-- entities out of classes and top levels since we need them in the interface. 
+--------------------------------------------------------------------------------
+
+
+data Entity = DocEntity (DocDecl Name) | DeclEntity Name
+data LEntity = Located Entity
+
+sameName (DocEntity _) _ = False
+sameName (DeclEntity _) (DocEntity _) = False
+sameName (DeclEntity a) (DeclEntity b) = a == b
+
+
+sortByLoc = map unLoc . sortBy (comparing getLoc)
+
+
+-- | Get all the entities in a class. The entities are sorted by their 
+-- SrcLoc.
+getClassEntities 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 ]  
+
+
+-- | Get all the top level entities in a module. The entities are sorted by
+-- their SrcLoc.
+getTopEntities :: HsGroup Name -> [Entity]
+getTopEntities 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
+--
+-- To be able to attach the right Haddock comment to the right declaration,
+-- we sort the entities by their SrcLoc and "collect" the docs for each 
+-- declaration.
+--------------------------------------------------------------------------------
+
+
+-- | 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
+
+
+-------------------------------------------------------------------------------
+-- 
+-------------------------------------------------------------------------------
+
+
+-- 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 (getTopEntities group)
+    classMethDocs = concatMap (collectDocs . getClassEntities) classes
+
+    recordFieldDocs = [ (unLoc lname, doc) | 
+                        ConDeclField lname _ (Just (L _ doc)) <- fields ]
+
+       
+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 ]
+
+
+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
+
+
+-- | 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
+  :: LookupMod
+  -> 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 lookupMod 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 lookupMod t
+
+    fullContentsOf m  
+	| m == this_mod = return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
+	| otherwise = 
+	   case lookupMod m 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 lookupMod m 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 
+             -> LookupMod
+             -> [Name] 
+             -> [Name]
+             -> Map Name [Name]
+             -> Maybe [IE Name]
+             -> [DocOption]
+             -> Map Name (LHsDecl Name)
+             -> ErrMsgM [Name]
+
+mkVisibleNames mdl lookupMod 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 (lookupMod nameMod)
+    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 lookupMod 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 lookupMod m' 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 :: LookupMod -> Name -> [Name]
+allSubsOfName lookupMod name 
+  | isExternalName name =
+    case lookupMod (nameModule name) of
+      Just hmod -> Map.findWithDefault [] name (hmod_sub_map hmod)
+      Nothing   -> []
+  | otherwise =  error $ "Main.allSubsOfName: unexpected unqual'd name"
+
+
+-- 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
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
new file mode 100644
index 00000000..a0b92fab
--- /dev/null
+++ b/src/Haddock/Interface/Rename.hs
@@ -0,0 +1,404 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Interface.Rename (renameInterface) where
+
+
+import Haddock.Types
+import Haddock.GHC.Utils
+
+import GHC hiding (NoLink)
+import Name
+import BasicTypes
+import SrcLoc 
+import Bag (emptyBag)
+import Outputable
+
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map hiding ( Map )
+import Prelude hiding (mapM)
+import Data.Traversable (mapM)
+import Control.Arrow
+import Control.Monad hiding (mapM)
+import Control.Monad.Writer hiding (mapM)
+
+
+renameInterface :: LinkEnv -> Interface -> ErrMsgM Interface
+renameInterface 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 }
+
+
+--------------------------------------------------------------------------------
+-- Monad for renaming
+--
+-- The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in 
+-- the environment.
+--------------------------------------------------------------------------------
+
+
+newtype GenRnM n a = 
+  RnM { unRn :: (n -> (Bool, DocName))	-- name lookup function
+             -> (a,[n])
+      }
+
+type RnM a = GenRnM Name a
+
+instance Monad (GenRnM n) where
+  (>>=) = thenRn
+  return = returnRn   
+
+returnRn :: a -> GenRnM n a
+returnRn a   = RnM (\_ -> (a,[]))
+thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
+m `thenRn` k = RnM (\lkp -> case unRn m lkp of 
+				(a,out1) -> case unRn (k a) lkp of
+						(b,out2) -> (b,out1++out2))
+
+getLookupRn :: RnM (Name -> (Bool, DocName))
+getLookupRn = RnM (\lkp -> (lkp,[]))
+outRn :: Name -> RnM ()
+outRn name = RnM (\_ -> ((),[name]))
+
+lookupRn :: (DocName -> a) -> Name -> RnM a
+lookupRn and_then name = do
+  lkp <- getLookupRn
+  case lkp name of
+	(False,maps_to) -> do outRn name; return (and_then maps_to)
+	(True, maps_to) -> return (and_then maps_to)
+
+newtype OrdName = MkOrdName Name
+
+instance Eq OrdName where
+  (MkOrdName a) == (MkOrdName b) = a == b
+
+instance Ord OrdName where
+  (MkOrdName a) `compare` (MkOrdName b) = nameOccName a `compare` nameOccName b
+
+runRnFM :: LinkEnv -> RnM a -> (a,[Name])
+runRnFM env rn = unRn rn lkp 
+  where 
+    lkp n = case Map.lookup (MkOrdName n) ordEnv of
+      Nothing -> (False, NoLink n) 
+      Just (MkOrdName q)  -> (True, Link q)
+
+    ordEnv = Map.fromList . map (MkOrdName *** MkOrdName) . Map.toList $ env
+
+
+--------------------------------------------------------------------------------
+-- Renaming
+--------------------------------------------------------------------------------
+
+
+keep n = NoLink n
+keepL (L loc n) = L loc (NoLink n)
+
+
+rename = lookupRn id 
+renameL (L loc name) = return . L loc =<< rename name
+
+
+renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
+renameExportItems items = mapM renameExportItem items
+
+
+renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
+renameMaybeDoc mbDoc = mapM renameDoc mbDoc
+
+
+renameLDoc (L loc doc) = return . L loc =<< renameDoc doc
+
+
+renameDoc :: HsDoc Name -> RnM (HsDoc DocName)
+renameDoc doc = case doc of
+  DocEmpty -> return DocEmpty
+  DocAppend a b -> do
+    a' <- renameDoc a
+    b' <- renameDoc b
+    return (DocAppend a' b')
+  DocString str -> return (DocString str)
+  DocParagraph doc -> do
+    doc' <- renameDoc doc
+    return (DocParagraph doc')
+  DocIdentifier ids -> do
+    lkp <- getLookupRn
+    case [ n | (True, n) <- map lkp ids ] of
+      ids'@(_:_) -> return (DocIdentifier ids')
+      [] -> return (DocIdentifier (map NoLink ids))
+  DocModule str -> return (DocModule str)
+  DocEmphasis doc -> do
+    doc' <- renameDoc doc
+    return (DocEmphasis doc')
+  DocMonospaced doc -> do
+    doc' <- renameDoc doc
+    return (DocMonospaced doc')
+  DocUnorderedList docs -> do
+    docs' <- mapM renameDoc docs
+    return (DocUnorderedList docs')
+  DocOrderedList docs -> do
+    docs' <- mapM renameDoc docs
+    return (DocOrderedList docs')
+  DocDefList docs -> do
+    docs' <- mapM (\(a,b) -> do
+      a' <- renameDoc a
+      b' <- renameDoc b
+      return (a',b')) docs
+    return (DocDefList docs')  
+  DocCodeBlock doc -> do
+    doc' <- renameDoc doc
+    return (DocCodeBlock doc')
+  DocURL str -> return (DocURL str) 
+  DocAName str -> return (DocAName str)
+
+
+renameLPred (L loc p) = return . L loc =<< renamePred p
+
+
+renamePred :: HsPred Name -> RnM (HsPred DocName)
+renamePred (HsClassP name types) = do
+  name'  <- rename name 
+  types' <- mapM renameLType types
+  return (HsClassP name' types')
+renamePred (HsIParam (IPName name) t) = do
+  name' <- rename name
+  t'    <- renameLType t
+  return (HsIParam (IPName name') t')
+
+
+renameLType (L loc t) = return . L loc =<< renameType t
+
+
+renameType t = case t of 
+  HsForAllTy expl tyvars lcontext ltype -> do
+    tyvars'   <- mapM renameLTyVarBndr tyvars
+    lcontext' <- renameLContext lcontext 
+    ltype'    <- renameLType ltype
+    return (HsForAllTy expl tyvars' lcontext' ltype')
+
+  HsTyVar n -> return . HsTyVar =<< rename n
+  HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+  
+  HsAppTy a b -> do
+    a' <- renameLType a
+    b' <- renameLType b
+    return (HsAppTy a' b')
+
+  HsFunTy a b -> do     
+    a' <- renameLType a
+    b' <- renameLType b
+    return (HsFunTy a' b')
+
+  HsListTy t -> return . HsListTy =<< renameLType t
+  HsPArrTy t -> return . HsPArrTy =<< renameLType t
+
+  HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+
+  HsOpTy a (L loc op) b -> do
+    op' <- rename op
+    a'  <- renameLType a
+    b'  <- renameLType b
+    return (HsOpTy a' (L loc op') b')
+
+  HsParTy t -> return . HsParTy =<< renameLType t
+
+  HsNumTy n -> return (HsNumTy n)
+
+  HsPredTy p -> return . HsPredTy =<< renamePred p
+
+  HsKindSig t k -> do
+    t' <- renameLType t
+    return (HsKindSig t' k)
+
+  HsDocTy t doc -> do
+    t' <- renameLType t
+    doc' <- renameLDoc doc
+    return (HsDocTy t' doc')
+
+  _ -> error "renameType"
+
+
+renameLTyVarBndr (L loc tv) = do
+  name' <- rename (hsTyVarName tv)
+  return $ L loc (replaceTyVarName tv name')
+
+    
+renameLContext (L loc context) = do
+  context' <- mapM renameLPred context
+  return (L loc context')
+
+
+renameInstHead :: InstHead Name -> RnM (InstHead DocName)
+renameInstHead (preds, className, types) = do
+  preds' <- mapM renamePred preds
+  className' <- rename className
+  types' <- mapM renameType types
+  return (preds', className', types')
+
+
+renameLDecl (L loc d) = return . L loc =<< renameDecl d
+
+
+renameDecl d = case d of
+  TyClD d -> do
+    d' <- renameTyClD d
+    return (TyClD d')
+  SigD s -> do
+    s' <- renameSig s
+    return (SigD s')
+  ForD d -> do
+    d' <- renameForD d
+    return (ForD d')
+  _ -> error "renameDecl"
+
+
+renameTyClD d = case d of
+  ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported
+ -- ForeignType name a b -> do
+ --   name' <- renameL name
+ --   return (ForeignType name' a b)
+
+  TyData x lcontext lname ltyvars _ k cons _ -> do
+    lcontext' <- renameLContext lcontext
+    ltyvars'  <- mapM renameLTyVarBndr ltyvars
+    cons'     <- mapM renameLCon cons
+    -- I don't think we need the derivings, so we return Nothing
+    -- We skip the type patterns too. TODO: find out what they are :-)
+    return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing) 
+ 
+  TySynonym lname ltyvars typat ltype -> do
+    ltyvars' <- mapM renameLTyVarBndr ltyvars
+    ltype'   <- renameLType ltype
+    -- We skip type patterns here as well.
+    return (TySynonym (keepL lname) ltyvars' Nothing ltype')
+
+  ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do
+    lcontext' <- renameLContext lcontext
+    ltyvars'  <- mapM renameLTyVarBndr ltyvars
+    lfundeps' <- mapM renameLFunDep lfundeps 
+    lsigs'    <- mapM renameLSig lsigs
+    -- we don't need the default methods or the already collected doc entities
+    -- we skip the ATs for now.
+    return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] [])
+ 
+  where
+    renameLCon (L loc con) = return . L loc =<< renameCon con
+    renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do
+      ltyvars'  <- mapM renameLTyVarBndr ltyvars
+      lcontext' <- renameLContext lcontext
+      details'  <- renameDetails details
+      restype'  <- renameResType restype
+      mbldoc'   <- mapM renameLDoc mbldoc
+      return (ConDecl (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc') 
+
+    renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
+    renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+    renameDetails (InfixCon a b) = do
+      a' <- renameLType a
+      b' <- renameLType b
+      return (InfixCon a' b')
+
+    renameField (ConDeclField name t doc) = do
+      t'   <- renameLType t
+      doc' <- mapM renameLDoc doc
+      return (ConDeclField (keepL name) t' doc')
+
+    renameResType (ResTyH98) = return ResTyH98
+    renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+    renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys))
+   
+    renameLSig (L loc sig) = return . L loc =<< renameSig sig
+
+      
+renameSig sig = case sig of 
+  TypeSig (L loc name) ltype -> do 
+    ltype' <- renameLType ltype
+    return (TypeSig (L loc (keep name)) ltype')
+{-  SpecSig lname ltype x -> do
+    lname' <- renameL lname
+    ltype' <- renameLType ltype
+    return (SpecSig lname' ltype' x)
+  InlineSig lname x -> do
+    lname' <- renameL lname
+    return (InlineSig lname' x)   
+  SpecInstSig t -> return . SpecInstSig =<< renameLType t
+  FixSig fsig -> return . FixSig =<< renameFixitySig fsig
+  where
+    renameFixitySig (FixitySig lname x) = do
+      lname' <- renameL lname
+      return (FixitySig lname' x)
+-}
+
+
+renameForD (ForeignImport lname ltype x) = do
+  ltype' <- renameLType ltype
+  return (ForeignImport (keepL lname) ltype' x)
+renameForD (ForeignExport lname ltype x) = do
+  ltype' <- renameLType ltype
+  return (ForeignExport (keepL lname) ltype' x)
+
+
+renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
+renameExportItem item = case item of 
+  ExportModule mod -> return (ExportModule mod)
+  ExportGroup lev id doc -> do
+    doc' <- renameDoc doc
+    return (ExportGroup lev id doc')
+  ExportDecl x decl doc instances -> do
+    decl' <- renameLDecl decl
+    doc'  <- mapM renameDoc doc
+    instances' <- mapM renameInstHead instances
+    return (ExportDecl x decl' doc' instances')
+  ExportNoDecl x y subs -> do
+    y'    <- lookupRn id y
+    subs' <- mapM (lookupRn id) subs
+    return (ExportNoDecl x y' subs')
+  ExportDoc doc -> do
+    doc' <- renameDoc doc
+    return (ExportDoc doc')