Make Haddock build with GHC 6.8.2

5 files changed, 81 insertions, 20 deletions

diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 7d44d452..8b72c1ac 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -36,7 +36,11 @@ import System.IO             ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )
 import Data.Map              ( Map )
 import qualified Data.Map as Map hiding ( Map )
 
+#if __GLASGOW_HASKELL__ >= 609
 import GHC hiding ( NoLink, moduleInfo )
+#else
+import GHC hiding ( NoLink )
+#endif
 import Name
 import Module
 import PackageConfig
diff --git a/src/Haddock/GHC.hs b/src/Haddock/GHC.hs
index ff1c58e4..c53c3a83 100644
--- a/src/Haddock/GHC.hs
+++ b/src/Haddock/GHC.hs
@@ -30,16 +30,21 @@ import SrcLoc
 
 -- | Start a GHC session with the -haddock flag set. Also turn off 
 -- compilation and linking.  
+#if __GLASGOW_HASKELL__ >= 609 
 startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
 startGhc libDir flags ghcActs = do
   -- TODO: handle warnings?
-#if __GLASGOW_HASKELL__ >= 609 
   (restFlags, _) <- parseStaticFlags (map noLoc flags)
+  runGhc (Just libDir) $ do
+    dynflags  <- getSessionDynFlags
 #else
+startGhc :: String -> [String] -> IO (Session, DynFlags)
+startGhc libDir flags = do
   restFlags <- parseStaticFlags flags
+  session <- newSession (Just libDir)
+  dynflags <- getSessionDynFlags session
+  do
 #endif
-  runGhc (Just libDir) $ do
-    dynflags  <- getSessionDynFlags
     let dynflags' = dopt_set dynflags Opt_Haddock
     let dynflags'' = dynflags' {
         hscTarget = HscAsm,
@@ -47,8 +52,13 @@ startGhc libDir flags ghcActs = do
         ghcLink   = NoLink
       }
     dynflags''' <- parseGhcFlags dynflags'' restFlags flags
+#if __GLASGOW_HASKELL__ >= 609 
     setSessionDynFlags dynflags'''
     ghcActs dynflags'''
+#else
+    setSessionDynFlags session dynflags'''
+    return (session, dynflags''')
+#endif
 
 
 -- | Expose the list of packages to GHC. Then initialize GHC's package state
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index eb9aca69..73c08018 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -23,6 +23,7 @@ import Haddock.Options
 import Haddock.GHC.Utils
 import Haddock.GHC.Typecheck
 import Haddock.Exception
+import Haddock.Utils
 
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -35,17 +36,21 @@ import HscTypes ( msHsFilePath )
 import Digraph
 import BasicTypes
 import SrcLoc
-import MonadUtils ( liftIO )
 
 
 -- | Turn a topologically sorted list of module names/filenames into interfaces. Also
 -- return the home link environment created in the process, and any error messages.
+#if __GLASGOW_HASKELL__ >= 609
 createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv)
 createInterfaces modules externalLinks flags = do
-
   -- part 1, create interfaces
   interfaces <- createInterfaces' modules flags
-
+#else
+createInterfaces :: Session -> [String] -> LinkEnv -> [Flag] -> IO ([Interface], LinkEnv)
+createInterfaces session modules externalLinks flags = do
+  -- part 1, create interfaces
+  interfaces <- createInterfaces' session modules flags
+#endif
   -- part 2, build link environment
   let homeLinks = buildHomeLinks interfaces
       links     = homeLinks `Map.union` externalLinks
@@ -63,6 +68,7 @@ createInterfaces modules externalLinks flags = do
   return (interfaces'', homeLinks)  
 
 
+#if __GLASGOW_HASKELL__ >= 609
 createInterfaces' :: [String] -> [Flag] -> Ghc [Interface]
 createInterfaces' modules flags = do
   targets <- mapM (\f -> guessTarget f Nothing) modules
@@ -71,6 +77,23 @@ createInterfaces' modules flags = do
   let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
   (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
     interface <- processModule modsum flags modMap
+#else
+createInterfaces' :: Session -> [String] -> [Flag] -> IO [Interface]
+createInterfaces' session modules flags = do
+  targets <- mapM (\f -> guessTarget f Nothing) modules
+  setTargets session targets
+  mbGraph <- depanal session [] False
+  modgraph <- case mbGraph of
+    Just graph -> return graph
+    Nothing -> throwE "Failed to create dependecy graph"
+  let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
+  (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
+    interface <- processModule session modsum flags modMap
+#endif
+    return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
+    ) ([], Map.empty) orderedMods
+  return (reverse ifaces)
+
 {-    liftIO $ do
      putStrLn . ppModInfo $ ifaceInfo interface
      putStrLn . show $ fmap pretty (ifaceDoc interface)
@@ -84,9 +107,6 @@ createInterfaces' modules flags = do
      mapM (putStrLn . pretty) (ifaceInstances interface)
      mapM (\(a,b) -> putStrLn $ pretty a ++ pretty b)  (Map.toList $ ifaceSubMap interface)
      mapM (putStrLn . pretty) (ifaceInstances interface)-}
-    return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
-    ) ([], Map.empty) orderedMods
-  return (reverse ifaces)
 
 {-
 
@@ -106,6 +126,7 @@ ppExportItem (ExportModule mod) = pretty mod
 ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++ show d 
 -}
 
+#if __GLASGOW_HASKELL__ >= 609
 processModule :: ModSummary -> [Flag] -> ModuleMap -> Ghc Interface
 processModule modsum flags modMap = 
 
@@ -128,8 +149,20 @@ processModule modsum flags modMap =
        let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
        liftIO $ mapM_ putStrLn msg
        return interface
+#else
+processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> IO Interface
+processModule session modsum flags modMap = do
+  let filename = msHsFilePath modsum
+  mbMod <- checkAndLoadModule session modsum False
+  ghcMod <- case mbMod of
+    Just (CheckedModule a (Just b) (Just c) (Just d) _)
+      -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
+    _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
+  let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
+  mapM_ putStrLn msg
+  return interface
+#endif
 
- 
 -- | 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
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 226d3acc..9ad22431 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -15,6 +15,7 @@ module Haddock.InterfaceFile (
 
 import Haddock.DocName ()
 import Haddock.Types
+import Haddock.Utils
 
 import Data.List
 import Data.Word
@@ -37,7 +38,6 @@ import FastMutInt
 import HsDoc
 import FastString
 import Unique
-import MonadUtils ( MonadIO(..) )
 
 
 data InterfaceFile = InterfaceFile {
@@ -57,16 +57,7 @@ binaryInterfaceMagic = 0xD0Cface
 -- Instead of adding one, we add three to all version numbers
 -- when one of our own (stored) datatypes is changed. 
 binaryInterfaceVersion :: Word16
-#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2
 binaryInterfaceVersion = 2
-#endif
-#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 3
-binaryInterfaceVersion = 3
-#endif
-#if __GLASGOW_HASKELL__ >= 609
-binaryInterfaceVersion = 4
-#endif
-
 
 initBinMemSize :: Int
 initBinMemSize = 1024*1024
@@ -145,6 +136,8 @@ writeInterfaceFile filename iface = do
 
 type NameCacheAccessor m = (m NameCache, NameCache -> m ())
 
+
+#if __GLASGOW_HASKELL__ >= 609
 nameCacheFromGhc :: NameCacheAccessor Ghc
 nameCacheFromGhc = ( read_from_session , write_to_session )
   where
@@ -154,6 +147,16 @@ nameCacheFromGhc = ( read_from_session , write_to_session )
     write_to_session nc' = do
        ref <- withSession (return . hsc_NC)
        liftIO $ writeIORef ref nc'
+#else
+nameCacheFromGhc :: Session -> NameCacheAccessor IO
+nameCacheFromGhc session = ( read_from_session , write_to_session )
+  where
+    read_from_session = readIORef . hsc_NC =<< sessionHscEnv session
+    write_to_session nc' = do
+      ref <- liftM hsc_NC $ sessionHscEnv session
+      writeIORef ref nc'
+#endif
+
 
 freshNameCache :: NameCacheAccessor IO
 freshNameCache = ( create_fresh_nc , \_ -> return () )
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 5743cbe1..8fe64b30 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -36,6 +36,9 @@ module Haddock.Utils (
 
   -- * Binary extras
 --  FormatVersion, mkFormatVersion  
+  
+  -- * MTL stuff
+  MonadIO(..)
  ) where
 
 import Haddock.Types
@@ -64,6 +67,14 @@ import System.Exit ( exitWith, ExitCode(..) )
 import System.IO ( hPutStr, stderr )
 import System.IO.Unsafe	 ( unsafePerformIO )
 
+#if __GLASGOW_HASKELL__ >= 609
+import MonadUtils ( MonadIO(..) )
+#else
+class Monad m => MonadIO m where
+    liftIO :: IO a -> m a                                              
+instance MonadIO IO where liftIO = id
+#endif
+
 -- -----------------------------------------------------------------------------
 -- Some Utilities