diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index b2649ff0d3ddb2a04dd69f6e67372f2fbdaebe0c..d01264ca55ce6d751cb07e14a700c5c15ea88984 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -178,7 +178,7 @@ import Control.DeepSeq (force)
import GHC.Iface.Ext.Ast ( mkHieFile )
import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
-import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
+import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
#include "HsVersions.h"
@@ -438,8 +438,7 @@ extract_renamed_stuff mod_summary tc_result = do
putMsg dflags $ text "Got invalid scopes"
mapM_ (putMsg dflags) xs
-- Roundtrip testing
- nc <- readIORef $ hsc_NC hs_env
- (file', _) <- readHieFile nc out_file
+ file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file
case diffFile hieFile (hie_file_result file') of
[] ->
putMsg dflags $ text "Got no roundtrip errors"
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 9735f204dda558f81099cd80176eaec26be842fa..246e91894663844917363ac952082e30e546fda9 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -12,6 +12,7 @@ module GHC.Iface.Ext.Binary
, HieFileResult(..)
, hieMagic
, hieNameOcc
+ , NameCacheUpdater(..)
)
where
@@ -33,6 +34,7 @@ import GHC.Types.Unique.Supply ( takeUniqFromSupply )
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Utils.Misc
+import GHC.Iface.Env (NameCacheUpdater(..))
import qualified Data.Array as A
import Data.IORef
@@ -189,23 +191,23 @@ type HieHeader = (Integer, ByteString)
-- an existing `NameCache`. Allows you to specify
-- which versions of hieFile to attempt to read.
-- `Left` case returns the failing header versions.
-readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache))
-readHieFileWithVersion readVersion nc file = do
+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)
+readHieFileWithVersion readVersion ncu file = do
bh0 <- readBinMem file
(hieVersion, ghcVersion) <- readHieFileHeader file bh0
if readVersion (hieVersion, ghcVersion)
then do
- (hieFile, nc') <- readHieFileContents bh0 nc
- return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc')
+ hieFile <- readHieFileContents bh0 ncu
+ return $ Right (HieFileResult hieVersion ghcVersion hieFile)
else return $ Left (hieVersion, ghcVersion)
-- | Read a `HieFile` from a `FilePath`. Can use
-- an existing `NameCache`.
-readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache)
-readHieFile nc file = do
+readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult
+readHieFile ncu file = do
bh0 <- readBinMem file
@@ -219,8 +221,8 @@ readHieFile nc file = do
, show hieVersion
, "but got", show readHieVersion
]
- (hieFile, nc') <- readHieFileContents bh0 nc
- return $ (HieFileResult hieVersion ghcVersion hieFile, nc')
+ hieFile <- readHieFileContents bh0 ncu
+ return $ HieFileResult hieVersion ghcVersion hieFile
readBinLine :: BinHandle -> IO ByteString
readBinLine bh = BS.pack . reverse <$> loop []
@@ -254,24 +256,24 @@ readHieFileHeader file bh0 = do
]
return (readHieVersion, ghcVersion)
-readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache)
-readHieFileContents bh0 nc = do
+readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile
+readHieFileContents bh0 ncu = do
dict <- get_dictionary bh0
-- read the symbol table so we are capable of reading the actual data
- (bh1, nc') <- do
+ bh1 <- do
let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
(getDictFastString dict)
- (nc', symtab) <- get_symbol_table bh1
+ symtab <- get_symbol_table bh1
let bh1' = setUserData bh1
$ newReadState (getSymTabName symtab)
(getDictFastString dict)
- return (bh1', nc')
+ return bh1'
-- load the actual data
hiefile <- get bh1
- return (hiefile, nc')
+ return hiefile
where
get_dictionary bin_handle = do
dict_p <- get bin_handle
@@ -285,9 +287,9 @@ readHieFileContents bh0 nc = do
symtab_p <- get bh1
data_p' <- tellBin bh1
seekBin bh1 symtab_p
- (nc', symtab) <- getSymbolTable bh1 nc
+ symtab <- getSymbolTable bh1 ncu
seekBin bh1 data_p'
- return (nc', symtab)
+ return symtab
putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next = j_r,
@@ -309,13 +311,14 @@ putSymbolTable bh next_off symtab = do
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
mapM_ (putHieName bh) names
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable)
-getSymbolTable bh namecache = do
+getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
+getSymbolTable bh ncu = do
sz <- get bh
od_names <- replicateM sz (getHieName bh)
- let arr = A.listArray (0,sz-1) names
- (namecache', names) = mapAccumR fromHieName namecache od_names
- return (namecache', arr)
+ updateNameCache ncu $ \nc ->
+ let arr = A.listArray (0,sz-1) names
+ (nc', names) = mapAccumR fromHieName nc od_names
+ in (nc',arr)
getSymTabName :: SymbolTable -> BinHandle -> IO Name
getSymTabName st bh = do
diff --git a/testsuite/tests/hiefile/should_run/PatTypes.hs b/testsuite/tests/hiefile/should_run/PatTypes.hs
index 25803d0e478b01e2c9a2d4cbdc44ee71bc2990b2..9f181c857750ef214e835e8755c1331d3dc41775 100644
--- a/testsuite/tests/hiefile/should_run/PatTypes.hs
+++ b/testsuite/tests/hiefile/should_run/PatTypes.hs
@@ -57,7 +57,7 @@ main = do
libdir:_ <- getArgs
df <- dynFlagsForPrinting libdir
nc <- makeNc
- (hfr, nc') <- readHieFile nc "PatTypes.hie"
+ hfr <- readHieFile (NCU (\f -> pure $ snd $ f nc)) "PatTypes.hie"
let hf = hie_file_result hfr
forM_ [p1,p2,p3,p4] $ \point -> do
putStr $ "At " ++ show point ++ ", got type: "
diff --git a/utils/haddock b/utils/haddock
index c60995fe05d9cc267e892448604b8b96a705ccc7..97f301a63ea8461074bfaa1486eb798e4be65f15 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit c60995fe05d9cc267e892448604b8b96a705ccc7
+Subproject commit 97f301a63ea8461074bfaa1486eb798e4be65f15