Port Haddock.Interface to new GHC API.

This required one bigger change: 'readInterfaceFile' used to take an
optional 'Session' argument.  This was used to optionally update the
name cache of an existing GHC session.  This does not work with the
new GHC API, because an active session requires the function to return
a 'GhcMonad' action, but this is not possible if no session is
provided.

The solution is to use an argument of functions for reading and
updating the name cache and to make the function work for any monad
that embeds IO, so it's result type can adapt to the calling context.

While refactoring, I tried to make the code a little more
self-documenting, mostly turning comments into function names.

1 files changed, 60 insertions, 42 deletions

diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 6d96ffa5..226d3acc 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -8,7 +8,7 @@
 
 module Haddock.InterfaceFile (
   InterfaceFile(..),
-  readInterfaceFile,
+  readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
   writeInterfaceFile
 ) where
 
@@ -37,6 +37,7 @@ import FastMutInt
 import HsDoc
 import FastString
 import Unique
+import MonadUtils ( MonadIO(..) )
 
 
 data InterfaceFile = InterfaceFile {
@@ -142,16 +143,42 @@ writeInterfaceFile filename iface = do
   writeBinMem bh filename
   return ()
 
+type NameCacheAccessor m = (m NameCache, NameCache -> m ())
+
+nameCacheFromGhc :: NameCacheAccessor Ghc
+nameCacheFromGhc = ( read_from_session , write_to_session )
+  where
+    read_from_session = do
+       ref <- withSession (return . hsc_NC)
+       liftIO $ readIORef ref
+    write_to_session nc' = do
+       ref <- withSession (return . hsc_NC)
+       liftIO $ writeIORef ref nc'
+
+freshNameCache :: NameCacheAccessor IO
+freshNameCache = ( create_fresh_nc , \_ -> return () )
+  where
+    create_fresh_nc = do
+       u  <- mkSplitUniqSupply 'a' -- ??
+       return (initNameCache u [])
 
 -- | Read a Haddock (@.haddock@) interface file. Return either an 
--- 'InterfaceFile' or an error message. If given a GHC 'Session', the function
--- registers all read names in the name cache of the session.
-readInterfaceFile :: Maybe Session -> FilePath -> IO (Either String InterfaceFile)
-readInterfaceFile mbSession filename = do
-  bh0 <- readBinMem filename
+-- 'InterfaceFile' or an error message.
+--
+-- This function can be called in two ways.  Within a GHC session it will
+-- update the use and update the session's name cache.  Outside a GHC session
+-- a new empty name cache is used.  The function is therefore generic in the
+-- monad being used.  The exact monad is whichever monad the first
+-- argument, the getter and setter of the name cache, requires.
+--
+readInterfaceFile :: MonadIO m =>
+                     NameCacheAccessor m
+                  -> FilePath -> m (Either String InterfaceFile)
+readInterfaceFile (get_name_cache, set_name_cache) filename = do
+  bh0 <- liftIO $ readBinMem filename
 
-  magic   <- get bh0
-  version <- get bh0
+  magic   <- liftIO $ get bh0
+  version <- liftIO $ get bh0
 
   case () of
     _ | magic /= binaryInterfaceMagic -> return . Left $
@@ -160,49 +187,40 @@ readInterfaceFile mbSession filename = do
       "Interface file is of wrong version: " ++ filename
       | otherwise -> do
 
-      -- get the dictionary
-      dict_p <- get bh0
-      data_p <- tellBin bh0
-      seekBin bh0 dict_p
-      dict <- getDictionary bh0
-      seekBin bh0 data_p
+      dict  <- get_dictionary bh0
+      bh1   <- init_handle_user_data bh0 dict
 
-      -- initialise the user-data field of bh0
-      ud <- newReadState dict
-      bh1 <- return (setUserData bh0 ud)
-
-      -- get the name cache from ghc if we have a ghc session,
-      -- otherwise create a new one
-      (theNC, mbRef) <- case mbSession of
-        Just session -> do
-          ref <- withSession session (return . hsc_NC)
-          nc <- readIORef ref
-          return (nc, Just ref)
-        Nothing -> do
-          -- construct an empty name cache
-          u  <- mkSplitUniqSupply 'a' -- ??
-          return (initNameCache u [], Nothing)
-
-      -- get the symbol table
-      symtab_p <- get bh1
-      data_p'  <- tellBin bh1
-      seekBin bh1 symtab_p
-      (nc', symtab) <- getSymbolTable bh1 theNC
-      seekBin bh1 data_p'
-
-      -- write back the new name cache if we have a ghc session
-      case mbRef of
-        Just ref -> writeIORef ref nc'
-        Nothing  -> return ()
+      theNC <- get_name_cache
+      (nc', symtab) <- get_symbol_table bh1 theNC
+      set_name_cache nc'
 
       -- set the symbol table
       let ud' = getUserData bh1
       bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab}
 
       -- load the actual data
-      iface <- get bh2
+      iface <- liftIO $ get bh2
       return (Right iface)
+ where
+   get_dictionary bin_handle = liftIO $ do
+      dict_p <- get bin_handle
+      data_p <- tellBin bin_handle
+      seekBin bin_handle dict_p
+      dict <- getDictionary bin_handle
+      seekBin bin_handle data_p
+      return dict
+
+   init_handle_user_data bin_handle dict = liftIO $ do
+      ud <- newReadState dict
+      return (setUserData bin_handle ud)
 
+   get_symbol_table bh1 theNC = liftIO $ do
+      symtab_p <- get bh1
+      data_p'  <- tellBin bh1
+      seekBin bh1 symtab_p
+      (nc', symtab) <- getSymbolTable bh1 theNC
+      seekBin bh1 data_p'
+      return (nc', symtab)
 
 -------------------------------------------------------------------------------
 -- Symbol table