aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/InterfaceFile.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/InterfaceFile.hs')
-rw-r--r--src/Haddock/InterfaceFile.hs72
1 files changed, 38 insertions, 34 deletions
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 7f2fd6f4..93d6fe4c 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -114,47 +114,51 @@ writeInterfaceFile filename iface = do
-- snd send the result to the file
writeBinMem bh filename
return ()
+
-readInterfaceFile :: FilePath -> IO InterfaceFile
+readInterfaceFile :: FilePath -> IO (Either String InterfaceFile)
readInterfaceFile filename = do
bh <- readBinMem filename
- magic <- get bh
- when (magic /= binaryInterfaceMagic) $ throwE $
- "Magic number mismatch: couldn't load interface file: " ++ filename
-
+ magic <- get bh
version <- get bh
- when (version /= binaryInterfaceVersion) $ throwE $
- "Interface file is of wrong version: " ++ filename
- -- get the dictionary
- dict_p <- get bh
- data_p <- tellBin bh
- seekBin bh dict_p
- dict <- getDictionary bh
- seekBin bh data_p
-
- -- initialise the user-data field of bh
- ud <- newReadState dict
- bh <- return (setUserData bh ud)
+ case () of
+ _ | magic /= binaryInterfaceMagic -> return . Left $
+ "Magic number mismatch: couldn't load interface file: " ++ filename
+ | version /= binaryInterfaceVersion -> return . Left $
+ "Interface file is of wrong version: " ++ filename
+ | otherwise -> do
+
+ -- get the dictionary
+ dict_p <- get bh
+ data_p <- tellBin bh
+ seekBin bh dict_p
+ dict <- getDictionary bh
+ seekBin bh data_p
+
+ -- initialise the user-data field of bh
+ ud <- newReadState dict
+ bh <- return (setUserData bh ud)
- -- get the symbol table
- symtab_p <- get bh
- data_p <- tellBin bh
- seekBin bh symtab_p
- -- (construct an empty name cache)
- u <- mkSplitUniqSupply 'a' -- ??
- let nc = initNameCache u []
- (_, symtab) <- getSymbolTable bh nc
- seekBin bh data_p
-
- -- set the symbol table
- let ud = getUserData bh
- bh <- return $! setUserData bh ud{ud_symtab = symtab}
-
- -- load the actual data
- iface <- get bh
- return iface
+ -- get the symbol table
+ symtab_p <- get bh
+ data_p <- tellBin bh
+ seekBin bh symtab_p
+ -- (construct an empty name cache)
+ u <- mkSplitUniqSupply 'a' -- ??
+ let nc = initNameCache u []
+ (_, symtab) <- getSymbolTable bh nc
+ seekBin bh data_p
+
+ -- set the symbol table
+ let ud = getUserData bh
+ bh <- return $! setUserData bh ud{ud_symtab = symtab}
+
+ -- load the actual data
+ iface <- get bh
+ return (Right iface)
+
-------------------------------------------------------------------------------
-- Symbol table