Make header human readable

1 files changed, 77 insertions, 21 deletions

diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs
index c291296a21..6c72dca034 100644
--- a/compiler/hieFile/HieBin.hs
+++ b/compiler/hieFile/HieBin.hs
@@ -2,7 +2,7 @@
 Binary serialization for .hie files.
 -}
 {-# LANGUAGE ScopedTypeVariables #-}
-module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieHeader ) where
+module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where
 
 import Config                     ( cProjectVersion )
 import GhcPrelude
@@ -17,12 +17,14 @@ import Outputable
 import PrelInfo
 import SrcLoc
 import UniqSupply                 ( takeUniqFromSupply )
+import Util                       ( maybeRead )
 import Unique
 import UniqFM
 
 import qualified Data.Array as A
 import Data.IORef
 import Data.ByteString            ( ByteString )
+import qualified Data.ByteString  as BS
 import qualified Data.ByteString.Char8 as BSC
 import Data.List                  ( mapAccumR )
 import Data.Word                  ( Word8, Word32 )
@@ -71,15 +73,20 @@ initBinMemSize :: Int
 initBinMemSize = 1024*1024
 
 -- | The header for HIE files - Capital ASCII letters "HIE".
-hieHeader :: [Word8]
-hieHeader = [72,73,69]
+hieMagic :: [Word8]
+hieMagic = [72,73,69]
 
-hieHeaderLen :: Int
-hieHeaderLen = length hieHeader
+hieMagicLen :: Int
+hieMagicLen = length hieMagic
 
 ghcVersion :: ByteString
 ghcVersion = BSC.pack cProjectVersion
 
+putBinLine :: BinHandle -> ByteString -> IO ()
+putBinLine bh xs = do
+  mapM_ (putByte bh) $ BS.unpack xs
+  putByte bh 10 -- newline char
+
 -- | Write a `HieFile` to the given `FilePath`, with a proper header and
 -- symbol tables for `Name`s and `FastString`s
 writeHieFile :: FilePath -> HieFile -> IO ()
@@ -88,9 +95,9 @@ writeHieFile hie_file_path hiefile = do
 
   -- Write the header: hieHeader followed by the
   -- hieVersion and the GHC version used to generate this file
-  mapM_ (put_ bh0) hieHeader
-  put_ bh0 hieVersion
-  put_ bh0 ghcVersion
+  mapM_ (putByte bh0) hieMagic
+  putBinLine bh0 $ BSC.pack $ show hieVersion
+  putBinLine bh0 $ ghcVersion
 
   -- remember where the dictionary pointer will go
   dict_p_p <- tellBin bh0
@@ -152,6 +159,25 @@ data HieFileResult
   , hie_file_result :: HieFile
   }
 
+type HieHeader = (Integer, ByteString)
+
+-- | Read a `HieFile` from a `FilePath`. Can use
+-- 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
+  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')
+  else return $ Left (hieVersion, ghcVersion)
+
+
 -- | Read a `HieFile` from a `FilePath`. Can use
 -- an existing `NameCache`.
 readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache)
@@ -159,23 +185,53 @@ readHieFile nc file = do
 
   bh0 <- readBinMem file
 
-  -- Read the header
-  header <- replicateM hieHeaderLen (get bh0)
-  readHieVersion <- get bh0
-  ghcVersion <- (get bh0 :: IO ByteString)
-
-  -- Check if the header is valid
-  when (header /= hieHeader) $
-    panic $ unwords ["readHieFile: headers don't match: Expected"
-                    , show hieHeader
-                    , "but got", show header
-                    ]
+  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0
+
   -- Check if the versions match
   when (readHieVersion /= hieVersion) $
-    panic $ unwords ["readHieFile: hie file versions don't match: Expected"
+    panic $ unwords ["readHieFile: hie file versions don't match for file:"
+                    , file
+                    , "Expected"
                     , show hieVersion
                     , "but got", show readHieVersion
                     ]
+  (hieFile, nc') <- readHieFileContents bh0 nc
+  return $ (HieFileResult hieVersion ghcVersion hieFile, nc')
+
+readBinLine :: BinHandle -> IO ByteString
+readBinLine bh = BS.pack . reverse <$> loop []
+  where
+    loop acc = do
+      char <- get bh :: IO Word8
+      if char == 10 -- ASCII newline '\n'
+      then return acc
+      else loop (char : acc)
+
+readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
+readHieFileHeader file bh0 = do
+  -- Read the header
+  magic <- replicateM hieMagicLen (get bh0)
+  version <- BSC.unpack <$> readBinLine bh0
+  case maybeRead version of
+    Nothing ->
+      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"
+                      , show version
+                      ]
+    Just readHieVersion -> do
+      ghcVersion <- readBinLine bh0
+
+      -- Check if the header is valid
+      when (magic /= hieMagic) $
+        panic $ unwords ["readHieFileHeader: headers don't match for file:"
+                        , file
+                        , "Expected"
+                        , show hieMagic
+                        , "but got", show magic
+                        ]
+      return (readHieVersion, ghcVersion)
+
+readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache)
+readHieFileContents bh0 nc = do
 
   dict  <- get_dictionary bh0
 
@@ -191,7 +247,7 @@ readHieFile nc file = do
 
   -- load the actual data
   hiefile <- get bh1
-  return (HieFileResult hieVersion ghcVersion hiefile, nc')
+  return (hiefile, nc')
   where
     get_dictionary bin_handle = do
       dict_p <- get bin_handle