Fix and enforce validation of header for .hie files

Implements #16686

automatically generate hieVersion from ghc version

5 files changed, 79 insertions, 29 deletions

diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
index 5634c0cf6a..74abd8f8e6 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -1,3 +1,6 @@
+{-
+Main functions for .hie file generation
+-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -20,7 +23,6 @@ import BooleanFormula
 import Class                      ( FunDep )
 import CoreUtils                  ( exprType )
 import ConLike                    ( conLikeName )
-import Config                     ( cProjectVersion )
 import Desugar                    ( deSugarExpr )
 import FieldLabel
 import HsSyn
@@ -41,7 +43,6 @@ import HieUtils
 
 import qualified Data.Array as A
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BSC
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Data                  ( Data, Typeable )
@@ -97,9 +98,7 @@ mkHieFile ms ts rs = do
   let Just src_file = ml_hs_file $ ms_location ms
   src <- liftIO $ BS.readFile src_file
   return $ HieFile
-      { hie_version = curHieVersion
-      , hie_ghc_version = BSC.pack cProjectVersion
-      , hie_hs_file = src_file
+      { hie_hs_file = src_file
       , hie_module = ms_mod ms
       , hie_types = arr
       , hie_asts = asts'
diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs
index 2734a9fce9..c291296a21 100644
--- a/compiler/hieFile/HieBin.hs
+++ b/compiler/hieFile/HieBin.hs
@@ -1,8 +1,11 @@
+{-
+Binary serialization for .hie files.
+-}
 {-# LANGUAGE ScopedTypeVariables #-}
-module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where
+module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieHeader ) where
 
+import Config                     ( cProjectVersion )
 import GhcPrelude
-
 import Binary
 import BinIface                   ( getDictFastString )
 import FastMutInt
@@ -19,12 +22,16 @@ import UniqFM
 
 import qualified Data.Array as A
 import Data.IORef
+import Data.ByteString            ( ByteString )
+import qualified Data.ByteString.Char8 as BSC
 import Data.List                  ( mapAccumR )
-import Data.Word                  ( Word32 )
-import Control.Monad              ( replicateM )
+import Data.Word                  ( Word8, Word32 )
+import Control.Monad              ( replicateM, when )
 import System.Directory           ( createDirectoryIfMissing )
 import System.FilePath            ( takeDirectory )
 
+import HieTypes
+
 -- | `Name`'s get converted into `HieName`'s before being written into @.hie@
 -- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
 -- these two types.
@@ -63,10 +70,28 @@ data HieDictionary = HieDictionary
 initBinMemSize :: Int
 initBinMemSize = 1024*1024
 
-writeHieFile :: Binary a => FilePath -> a -> IO ()
+-- | The header for HIE files - Capital ASCII letters "HIE".
+hieHeader :: [Word8]
+hieHeader = [72,73,69]
+
+hieHeaderLen :: Int
+hieHeaderLen = length hieHeader
+
+ghcVersion :: ByteString
+ghcVersion = BSC.pack cProjectVersion
+
+-- | Write a `HieFile` to the given `FilePath`, with a proper header and
+-- symbol tables for `Name`s and `FastString`s
+writeHieFile :: FilePath -> HieFile -> IO ()
 writeHieFile hie_file_path hiefile = do
   bh0 <- openBinMem initBinMemSize
 
+  -- 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
+
   -- remember where the dictionary pointer will go
   dict_p_p <- tellBin bh0
   put_ bh0 dict_p_p
@@ -105,7 +130,7 @@ writeHieFile hie_file_path hiefile = do
   symtab_map'  <- readIORef symtab_map
   putSymbolTable bh symtab_next' symtab_map'
 
-  -- write the dictionary pointer at the fornt of the file
+  -- write the dictionary pointer at the front of the file
   dict_p <- tellBin bh
   putAt bh dict_p_p dict_p
   seekBin bh dict_p
@@ -120,10 +145,38 @@ writeHieFile hie_file_path hiefile = do
   writeBinMem bh hie_file_path
   return ()
 
-readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache)
+data HieFileResult
+  = HieFileResult
+  { hie_file_result_version :: Integer
+  , hie_file_result_ghc_version :: ByteString
+  , hie_file_result :: HieFile
+  }
+
+-- | Read a `HieFile` from a `FilePath`. Can use
+-- an existing `NameCache`.
+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache)
 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
+                    ]
+  -- Check if the versions match
+  when (readHieVersion /= hieVersion) $
+    panic $ unwords ["readHieFile: hie file versions don't match: Expected"
+                    , show hieVersion
+                    , "but got", show readHieVersion
+                    ]
+
   dict  <- get_dictionary bh0
 
   -- read the symbol table so we are capable of reading the actual data
@@ -138,7 +191,7 @@ readHieFile nc file = do
 
   -- load the actual data
   hiefile <- get bh1
-  return (hiefile, nc')
+  return (HieFileResult hieVersion ghcVersion hiefile, nc')
   where
     get_dictionary bin_handle = do
       dict_p <- get bin_handle
diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs
index 7896cf7720..ffdfe431d3 100644
--- a/compiler/hieFile/HieDebug.hs
+++ b/compiler/hieFile/HieDebug.hs
@@ -1,3 +1,6 @@
+{-
+Functions to validate and check .hie file ASTs generated by GHC.
+-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
diff --git a/compiler/hieFile/HieTypes.hs b/compiler/hieFile/HieTypes.hs
index 1b1d8c5275..7f500a7453 100644
--- a/compiler/hieFile/HieTypes.hs
+++ b/compiler/hieFile/HieTypes.hs
@@ -1,3 +1,8 @@
+{-
+Types for the .hie file format are defined here.
+
+For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
+-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE TypeSynonymInstances #-}
@@ -7,6 +12,7 @@ module HieTypes where
 
 import GhcPrelude
 
+import Config
 import Binary
 import FastString                 ( FastString )
 import IfaceType
@@ -28,8 +34,8 @@ import Control.Applicative        ( (<|>) )
 type Span = RealSrcSpan
 
 -- | Current version of @.hie@ files
-curHieVersion :: Word8
-curHieVersion = 0
+hieVersion :: Integer
+hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
 
 {- |
 GHC builds up a wealth of information about Haskell source as it compiles it.
@@ -48,13 +54,7 @@ Besides saving compilation cycles, @.hie@ files also offer a more stable
 interface than the GHC API.
 -}
 data HieFile = HieFile
-    { hie_version :: Word8
-    -- ^ version of the HIE format
-
-    , hie_ghc_version :: ByteString
-    -- ^ Version of GHC that produced this file
-
-    , hie_hs_file :: FilePath
+    { hie_hs_file :: FilePath
     -- ^ Initial Haskell source file path
 
     , hie_module :: Module
@@ -74,11 +74,8 @@ data HieFile = HieFile
     , hie_hs_src :: ByteString
     -- ^ Raw bytes of the initial Haskell source
     }
-
 instance Binary HieFile where
   put_ bh hf = do
-    put_ bh $ hie_version hf
-    put_ bh $ hie_ghc_version hf
     put_ bh $ hie_hs_file hf
     put_ bh $ hie_module hf
     put_ bh $ hie_types hf
@@ -93,8 +90,6 @@ instance Binary HieFile where
     <*> get bh
     <*> get bh
     <*> get bh
-    <*> get bh
-    <*> get bh
 
 
 {-
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 674afc9f47..ef67ae0bdc 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -174,7 +174,7 @@ import Data.Set (Set)
 
 import HieAst           ( mkHieFile )
 import HieTypes         ( getAsts, hie_asts )
-import HieBin           ( readHieFile, writeHieFile )
+import HieBin           ( readHieFile, writeHieFile , hie_file_result)
 import HieDebug         ( diffFile, validateScopes )
 
 #include "HsVersions.h"
@@ -427,7 +427,7 @@ extract_renamed_stuff mod_summary tc_result = do
               -- Roundtrip testing
               nc <- readIORef $ hsc_NC hs_env
               (file', _) <- readHieFile nc out_file
-              case diffFile hieFile file' of
+              case diffFile hieFile (hie_file_result file') of
                 [] ->
                   putMsg dflags $ text "Got no roundtrip errors"
                 xs -> do