Finalize support for links to other packages

3 files changed, 113 insertions, 51 deletions

diff --git a/src/Haddock/Rename.hs b/src/Haddock/Rename.hs
index 6ba07215..5ac711cb 100644
--- a/src/Haddock/Rename.hs
+++ b/src/Haddock/Rename.hs
@@ -12,6 +12,7 @@ module Haddock.Rename (
 import Haddock.Types
 
 import GHC hiding ( NoLink )
+import Name
 import BasicTypes
 import SrcLoc 
 import Bag ( emptyBag )
@@ -20,6 +21,7 @@ import Data.Map ( Map )
 import qualified Data.Map as Map hiding ( Map )
 import Prelude hiding ( mapM )
 import Data.Traversable ( mapM )
+import Control.Arrow
 
 -- -----------------------------------------------------------------------------
 -- Monad for renaming
@@ -58,14 +60,22 @@ lookupRn and_then name = do
 	(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 :: Map Name Name -> RnM a -> (a,[Name])
 runRnFM env rn = unRn rn lkp 
-  where lkp n = case Map.lookup n env of
-		  Nothing -> (False, NoLink n) 
-		  Just q  -> (True,  Link q)
+  where 
+    lkp n = case Map.lookup (MkOrdName n) ordEnv of
+      Nothing -> (False, NoLink n) 
+      Just (MkOrdName q)  -> (True, Link q)
 
-runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n])
-runRn lkp rn = unRn rn lkp
+    ordEnv = Map.fromList . map (MkOrdName *** MkOrdName) . Map.toList $ env
 
 -- -----------------------------------------------------------------------------
 -- Renaming 
diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs
index b6fb54d4..4799734e 100644
--- a/src/Haddock/Utils/GHC.hs
+++ b/src/Haddock/Utils/GHC.hs
@@ -7,6 +7,9 @@ import HsSyn
 import SrcLoc
 import HscTypes
 import Outputable
+import Packages
+import UniqFM
+import Name
 
 getMainDeclBinder :: HsDecl name -> Maybe name
 getMainDeclBinder (TyClD d) = Just (tcdName d)
@@ -24,3 +27,13 @@ getMainDeclBinder _ = Nothing
 --modInfoMod  = mi_module . minf_iface 
 
 trace_ppr x y = trace (showSDoc (ppr x)) y
+
+-- names
+
+nameSetMod n newMod = 
+  mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)
+
+nameSetPkg pkgId n = 
+  mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod)) 
+	               (nameOccName n) (nameSrcSpan n)
+  where mod = nameModule n
diff --git a/src/Main.hs b/src/Main.hs
index d8af437c..ce1b6814 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -23,6 +23,7 @@ import Prelude hiding ( catch )
 import Control.Exception     
 import Control.Monad
 import Control.Monad.Writer  ( Writer, runWriter, tell )
+import Control.Arrow
 import Data.Char             ( isSpace )
 import Data.IORef            ( writeIORef )
 import Data.Ord
@@ -37,7 +38,7 @@ import Data.Foldable         ( foldlM )
 import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), 
                                ArgDescr(..) )
 import System.Environment    ( getArgs )
-import System.Directory      ( doesDirectoryExist )
+import System.Directory
 import System.FilePath
 import System.Cmd            ( system )
 import System.Exit           
@@ -66,6 +67,7 @@ import HscTypes
 import Util                  ( handleDyn )
 import ErrUtils              ( printBagOfErrors )
 import BasicTypes
+import UniqFM
 
 import FastString
 #define FSLIT(x) (mkFastString# (x#))
@@ -128,28 +130,45 @@ main = handleTopExceptions $ do
   args <- getArgs
   prog <- getProgramName
 
-  -- parse flags and handle some of them initially
+  -- parse command-line flags and handle some of them initially
   (flags, fileArgs) <- parseHaddockOpts args
   libDir <- handleFlags flags fileArgs
   
   -- initialize GHC 
   restGhcFlags <- tryParseStaticFlags flags
-  (session, dynflags) <- startGHC libDir
-  dynflags' <- parseGhcFlags dynflags restGhcFlags
-  setSessionDynFlags session dynflags'
+  (session, _) <- startGHC libDir
 
-  -- load package data (from .haddock-files), typecheck input files and create 
-  -- the module -> html mapping
-  packages <- getPackages session dynflags' flags
+  -- get the -use-package packages, and expose them to ghc
+  usePackages <- getUsePackages flags session
+
+  -- parse and set the ghc flags
+  dynflags <- parseGhcFlags session restGhcFlags
+  setSessionDynFlags session dynflags
+
+  -- init and get the package dependencies 
+  (_, depPackages) <- initPackages dynflags
+  let depPkgs = map (fromJust . unpackPackageId) depPackages
+
+  -- compute the exposed packages
+  let exposedPackages = [ mkPackageId pkg | pkg <- depPkgs, 
+                          pkgName pkg `elem` usePackages ]
+
+  -- get the .haddock interface file and html path for the exposed packages
+  packages <- getPackages session exposedPackages
+
+  -- load, parse and typecheck the target modules and their dependencies
   modules  <- sortAndCheckModules session fileArgs
+
+  -- update the html references for rendering phase (global variable)
   updateHTMLXRefs packages
 
-  -- combine the doc envs of the external packages into one
+  -- combine the doc envs of the exposed packages into one
   let env = packagesDocEnv packages
 
   -- TODO: continue to break up the run function into parts
   run flags modules env
 
+
 handleFlags flags fileArgs = do
   prog <- getProgramName
   let byeUsage = bye (usageInfo (usageHeader prog) (options False))
@@ -168,6 +187,36 @@ handleFlags flags fileArgs = do
 
   return ghcLibDir
 
+
+-- | Handle the -use-package flags
+-- 
+-- Returns the names of the packages (without version number), if parsing
+-- succeeded.
+--
+-- It would be better to try to get the "exposed" packages from GHC instead.
+-- This would make the -use-package flag unnecessary. But currently it 
+-- seems all you can get from the GHC api is all packages that are linked in 
+-- (i.e the closure of the exposed packages).
+getUsePackages :: [Flag] -> Session -> IO [String]
+getUsePackages flags session = do
+
+  -- get the packages from the commandline flags
+  let packages = [ pkg | Flag_UsePackage pkg <- flags ]
+
+  -- expose these packages 
+  -- (makes "-use-package pkg" equal to "-g '-package pkg'")
+
+  dfs <- getSessionDynFlags session
+  let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage packages }
+  setSessionDynFlags session dfs'
+
+  -- try to parse these packages into PackageIndentifiers
+
+  mapM (handleParse . unpackPackageId . stringToPackageId) packages
+  where
+    handleParse (Just pkg) = return (pkgName pkg)
+    handleParse Nothing = throwE "Could not parse package identifier"
+
 --------------------------------------------------------------------------------
 -- Flags 
 --------------------------------------------------------------------------------
@@ -178,8 +227,10 @@ tryParseStaticFlags flags = do
   let ghcFlags = [ str | Flag_GhcFlag str <- flags ]
   parseStaticFlags ghcFlags
 
--- | Try to parse and set dynamic GHC flags
-parseGhcFlags dflags ghcFlags = foldlM parseFlag dflags (map words 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
@@ -307,15 +358,14 @@ startGHC :: String -> IO (Session, DynFlags)
 startGHC libDir = do
   session <- newSession (Just libDir)
   flags   <- getSessionDynFlags session
-  flags'  <- liftM fst (initPackages flags)
-  let flags'' = dopt_set flags' Opt_Haddock 
-  setSessionDynFlags session flags'' {
+  let flags' = dopt_set flags Opt_Haddock
+  let flags'' = flags' {
       hscTarget = HscNothing,
       ghcMode   = CompManager,
       ghcLink   = NoLink
     }
-  flags''' <- getSessionDynFlags session
-  return (session, flags''')
+  setSessionDynFlags session flags''
+  return (session, flags'')
 
 
 -- | Get the sorted graph of all loaded modules and their dependencies
@@ -763,7 +813,8 @@ parseIfaceOption s =
 	(file, _)        -> ("", file)
 	
 updateHTMLXRefs :: [PackageData] -> IO ()
-updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping)
+updateHTMLXRefs packages = do
+  writeIORef html_xrefs_ref (Map.fromList mapping)
   where
     mapping = [ (mod, html) | 
                 (PackageData mods _ html) <- packages, mod <- mods ] 
@@ -1070,9 +1121,6 @@ buildGlobalDocEnv modules
 			 n (nameSetMod n modName) env
 	keep_new env n = Map.insert n (nameSetMod n modName) env 
 
-nameSetMod n newMod = mkExternalName (nameUnique n) newMod (nameOccName n)
-                      (nameSrcSpan n)
-
 -- -----------------------------------------------------------------------------
 -- Named documentation
 
@@ -1248,51 +1296,42 @@ getHtml pkgInfo = case haddockHTMLs pkgInfo of
 -- | Get the Haddock interface path for a package
 getIface :: InstalledPackageInfo -> IO FilePath
 getIface pkgInfo = case haddockInterfaces pkgInfo of
-  (path:_) | not (null path) -> do
-    dirExists <- doesDirectoryExist path
-    if dirExists then return path else throwE $
-       "Interface directory " ++ path ++ " does not exist."
+  (file:_) | not (null file) -> do
+    fileExists <- doesFileExist file
+    if fileExists then return file else throwE $
+       "Interface file " ++ file ++ " does not exist."
   _ -> throwE "No Haddock interface installed."
 
 -- | Try to create a PackageData structure for a package
 getPackage :: Session -> InstalledPackageInfo -> IO PackageData 
 getPackage session pkgInfo = do
+
   html <- getHtml pkgInfo
-  iface <- getIface pkgInfo
-  iface <- readInterfaceFile iface
+  ifacePath <- getIface pkgInfo
+  iface <- readInterfaceFile ifacePath
   
-  let modules = packageModules pkgInfo
-
-  -- try to get a ModuleInfo struct for each module
-  mbModInfos <- moduleInfo session modules
-  modInfos <- case mbModInfos of 
-    Just x -> return x
-    Nothing -> throwE "Could not get ModuleInfo for all exposed modules." 
-
-  --let modInfos' = sortPackageModules modInfos
+  let docEnv  = ifDocEnv iface
+      modules = packageModules pkgInfo
 
   return $ PackageData {
     pdModules  = modules,
-    pdDocEnv   = ifDocEnv iface,
+    pdDocEnv   = docEnv,
     pdHtmlPath = html
   } 
        
 -- | Try to create a PackageData for each package in the session except for 
 -- rts. Print a warning on stdout if a PackageData could not be created.
-getPackages :: Session -> DynFlags -> [Flag] -> IO [PackageData]
-getPackages session dynflags flags = do
+getPackages :: Session -> [PackageId] -> IO [PackageData]
+getPackages session packages = do
 
   -- get InstalledPackageInfos for every package in the session
-  pkgInfos <- getPreloadPackagesAnd dynflags []
-
-  -- return a list of those packages that we could create PackageDatas for 
-  let pkgInfos' = filter notRTS pkgInfos
-  liftM catMaybes $ mapM tryGetPackage pkgInfos'
+  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 and html path
+  liftM catMaybes $ mapM tryGetPackage pkgInfos
   where
-    -- no better way to do this?
-    notRTS p = pkgName (package p) /= packageIdString rtsPackageId  
-
     -- try to get a PackageData, warn if we can't
     tryGetPackage pkgInfo = 
         (getPackage session pkgInfo >>= return . Just)