{-
Binary serialization for .hie files.
-}
{- HLINT ignore -}
{-# LANGUAGE ScopedTypeVariables #-}
module Compat.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc,NameCacheUpdater(..)) where

import GHC.Settings               ( maybeRead )

import Config                     ( cProjectVersion )
import Binary
import BinIface                   ( getDictFastString )
import FastMutInt
import FastString                 ( FastString )
import Module                     ( Module )
import Name
import NameCache
import Outputable
import PrelInfo
import SrcLoc
import UniqSupply                 ( takeUniqFromSupply )
import Unique
import UniqFM
import IfaceEnv

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 )
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.
data HieName
  = ExternalName !Module !OccName !SrcSpan
  | LocalName !OccName !SrcSpan
  | KnownKeyName !Unique
  deriving (HieName -> HieName -> Bool
(HieName -> HieName -> Bool)
-> (HieName -> HieName -> Bool) -> Eq HieName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HieName -> HieName -> Bool
$c/= :: HieName -> HieName -> Bool
== :: HieName -> HieName -> Bool
$c== :: HieName -> HieName -> Bool
Eq)

instance Ord HieName where
  compare :: HieName -> HieName -> Ordering
compare (ExternalName Module
a OccName
b SrcSpan
c) (ExternalName Module
d OccName
e SrcSpan
f) = (Module, OccName, SrcSpan)
-> (Module, OccName, SrcSpan) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Module
a,OccName
b,SrcSpan
c) (Module
d,OccName
e,SrcSpan
f)
  compare (LocalName OccName
a SrcSpan
b) (LocalName OccName
c SrcSpan
d) = (OccName, SrcSpan) -> (OccName, SrcSpan) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (OccName
a,SrcSpan
b) (OccName
c,SrcSpan
d)
  compare (KnownKeyName Unique
a) (KnownKeyName Unique
b) = Unique -> Unique -> Ordering
nonDetCmpUnique Unique
a Unique
b
    -- Not actually non determinstic as it is a KnownKey
  compare ExternalName{} HieName
_ = Ordering
LT
  compare LocalName{} ExternalName{} = Ordering
GT
  compare LocalName{} HieName
_ = Ordering
LT
  compare KnownKeyName{} HieName
_ = Ordering
GT

instance Outputable HieName where
  ppr :: HieName -> SDoc
ppr (ExternalName Module
m OccName
n SrcSpan
sp) = String -> SDoc
text String
"ExternalName" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
m SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
n SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
sp
  ppr (LocalName OccName
n SrcSpan
sp) = String -> SDoc
text String
"LocalName" SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
n SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
sp
  ppr (KnownKeyName Unique
u) = String -> SDoc
text String
"KnownKeyName" SDoc -> SDoc -> SDoc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u

hieNameOcc :: HieName -> OccName
hieNameOcc :: HieName -> OccName
hieNameOcc (ExternalName Module
_ OccName
occ SrcSpan
_) = OccName
occ
hieNameOcc (LocalName OccName
occ SrcSpan
_) = OccName
occ
hieNameOcc (KnownKeyName Unique
u) =
  case Unique -> Maybe Name
lookupKnownKeyName Unique
u of
    Just Name
n -> Name -> OccName
nameOccName Name
n
    Maybe Name
Nothing -> String -> SDoc -> OccName
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"hieNameOcc:unknown known-key unique"
                        ((Char, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Unique -> (Char, Int)
unpkUnique Unique
u))


data HieSymbolTable = HieSymbolTable
  { HieSymbolTable -> FastMutInt
hie_symtab_next :: !FastMutInt
  , HieSymbolTable -> IORef (UniqFM (Int, HieName))
hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))
  }

data HieDictionary = HieDictionary
  { HieDictionary -> FastMutInt
hie_dict_next :: !FastMutInt -- The next index to use
  , HieDictionary -> IORef (UniqFM (Int, FastString))
hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
  }

initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = Int
1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024

-- | The header for HIE files - Capital ASCII letters "HIE".
hieMagic :: [Word8]
hieMagic :: [Word8]
hieMagic = [Word8
72,Word8
73,Word8
69]

hieMagicLen :: Int
hieMagicLen :: Int
hieMagicLen = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
hieMagic

ghcVersion :: ByteString
ghcVersion :: ByteString
ghcVersion = String -> ByteString
BSC.pack String
cProjectVersion

putBinLine :: BinHandle -> ByteString -> IO ()
putBinLine :: BinHandle -> ByteString -> IO ()
putBinLine BinHandle
bh ByteString
xs = do
  (Word8 -> IO ()) -> [Word8] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> Word8 -> IO ()
putByte BinHandle
bh) ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
xs
  BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
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 ()
writeHieFile :: String -> HieFile -> IO ()
writeHieFile String
hie_file_path HieFile
hiefile = do
  BinHandle
bh0 <- Int -> IO BinHandle
openBinMem Int
initBinMemSize

  -- Write the header: hieHeader followed by the
  -- hieVersion and the GHC version used to generate this file
  (Word8 -> IO ()) -> [Word8] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> Word8 -> IO ()
putByte BinHandle
bh0) [Word8]
hieMagic
  BinHandle -> ByteString -> IO ()
putBinLine BinHandle
bh0 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
hieVersion
  BinHandle -> ByteString -> IO ()
putBinLine BinHandle
bh0 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
ghcVersion

  -- remember where the dictionary pointer will go
  Bin (Bin Any)
dict_p_p <- BinHandle -> IO (Bin (Bin Any))
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh0
  BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh0 Bin (Bin Any)
dict_p_p

  -- remember where the symbol table pointer will go
  Bin (Bin Any)
symtab_p_p <- BinHandle -> IO (Bin (Bin Any))
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh0
  BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh0 Bin (Bin Any)
symtab_p_p

  -- Make some intial state
  FastMutInt
symtab_next <- IO FastMutInt
newFastMutInt
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
symtab_next Int
0
  IORef (UniqFM (Int, HieName))
symtab_map <- UniqFM (Int, HieName) -> IO (IORef (UniqFM (Int, HieName)))
forall a. a -> IO (IORef a)
newIORef UniqFM (Int, HieName)
forall elt. UniqFM elt
emptyUFM
  let hie_symtab :: HieSymbolTable
hie_symtab = HieSymbolTable :: FastMutInt -> IORef (UniqFM (Int, HieName)) -> HieSymbolTable
HieSymbolTable {
                      hie_symtab_next :: FastMutInt
hie_symtab_next = FastMutInt
symtab_next,
                      hie_symtab_map :: IORef (UniqFM (Int, HieName))
hie_symtab_map  = IORef (UniqFM (Int, HieName))
symtab_map }
  FastMutInt
dict_next_ref <- IO FastMutInt
newFastMutInt
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
dict_next_ref Int
0
  IORef (UniqFM (Int, FastString))
dict_map_ref <- UniqFM (Int, FastString) -> IO (IORef (UniqFM (Int, FastString)))
forall a. a -> IO (IORef a)
newIORef UniqFM (Int, FastString)
forall elt. UniqFM elt
emptyUFM
  let hie_dict :: HieDictionary
hie_dict = HieDictionary :: FastMutInt -> IORef (UniqFM (Int, FastString)) -> HieDictionary
HieDictionary {
                      hie_dict_next :: FastMutInt
hie_dict_next = FastMutInt
dict_next_ref,
                      hie_dict_map :: IORef (UniqFM (Int, FastString))
hie_dict_map  = IORef (UniqFM (Int, FastString))
dict_map_ref }

  -- put the main thing
  let bh :: BinHandle
bh = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh0 (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
newWriteState (HieSymbolTable -> BinHandle -> Name -> IO ()
putName HieSymbolTable
hie_symtab)
                                           (HieSymbolTable -> BinHandle -> Name -> IO ()
putName HieSymbolTable
hie_symtab)
                                           (HieDictionary -> BinHandle -> FastString -> IO ()
putFastString HieDictionary
hie_dict)
  BinHandle -> HieFile -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh HieFile
hiefile

  -- write the symtab pointer at the front of the file
  Bin Any
symtab_p <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
  BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
symtab_p_p Bin Any
symtab_p
  BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
symtab_p

  -- write the symbol table itself
  Int
symtab_next' <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
  UniqFM (Int, HieName)
symtab_map'  <- IORef (UniqFM (Int, HieName)) -> IO (UniqFM (Int, HieName))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Int, HieName))
symtab_map
  BinHandle -> Int -> UniqFM (Int, HieName) -> IO ()
putSymbolTable BinHandle
bh Int
symtab_next' UniqFM (Int, HieName)
symtab_map'

  -- write the dictionary pointer at the front of the file
  Bin Any
dict_p <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
  BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
dict_p_p Bin Any
dict_p
  BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p

  -- write the dictionary itself
  Int
dict_next <- FastMutInt -> IO Int
readFastMutInt FastMutInt
dict_next_ref
  UniqFM (Int, FastString)
dict_map  <- IORef (UniqFM (Int, FastString)) -> IO (UniqFM (Int, FastString))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Int, FastString))
dict_map_ref
  BinHandle -> Int -> UniqFM (Int, FastString) -> IO ()
putDictionary BinHandle
bh Int
dict_next UniqFM (Int, FastString)
dict_map

  -- and send the result to the file
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
hie_file_path)
  BinHandle -> String -> IO ()
writeBinMem BinHandle
bh String
hie_file_path
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

data HieFileResult
  = HieFileResult
  { HieFileResult -> Integer
hie_file_result_version :: Integer
  , HieFileResult -> ByteString
hie_file_result_ghc_version :: ByteString
  , HieFileResult -> HieFile
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) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)
readHieFileWithVersion :: (HieHeader -> Bool)
-> NameCacheUpdater
-> String
-> IO (Either HieHeader HieFileResult)
readHieFileWithVersion HieHeader -> Bool
readVersion NameCacheUpdater
ncu String
file = do
  BinHandle
bh0 <- String -> IO BinHandle
readBinMem String
file

  (Integer
hieVersion, ByteString
ghcVersion) <- String -> BinHandle -> IO HieHeader
readHieFileHeader String
file BinHandle
bh0

  if HieHeader -> Bool
readVersion (Integer
hieVersion, ByteString
ghcVersion)
  then do
    HieFile
hieFile <- BinHandle -> NameCacheUpdater -> IO HieFile
readHieFileContents BinHandle
bh0 NameCacheUpdater
ncu
    Either HieHeader HieFileResult
-> IO (Either HieHeader HieFileResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieHeader HieFileResult
 -> IO (Either HieHeader HieFileResult))
-> Either HieHeader HieFileResult
-> IO (Either HieHeader HieFileResult)
forall a b. (a -> b) -> a -> b
$ HieFileResult -> Either HieHeader HieFileResult
forall a b. b -> Either a b
Right (Integer -> ByteString -> HieFile -> HieFileResult
HieFileResult Integer
hieVersion ByteString
ghcVersion HieFile
hieFile)
  else Either HieHeader HieFileResult
-> IO (Either HieHeader HieFileResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieHeader HieFileResult
 -> IO (Either HieHeader HieFileResult))
-> Either HieHeader HieFileResult
-> IO (Either HieHeader HieFileResult)
forall a b. (a -> b) -> a -> b
$ HieHeader -> Either HieHeader HieFileResult
forall a b. a -> Either a b
Left (Integer
hieVersion, ByteString
ghcVersion)


-- | Read a `HieFile` from a `FilePath`. Can use
-- an existing `NameCache`.
readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult
readHieFile :: NameCacheUpdater -> String -> IO HieFileResult
readHieFile NameCacheUpdater
ncu String
file = do

  BinHandle
bh0 <- String -> IO BinHandle
readBinMem String
file

  (Integer
readHieVersion, ByteString
ghcVersion) <- String -> BinHandle -> IO HieHeader
readHieFileHeader String
file BinHandle
bh0

  -- Check if the versions match
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
readHieVersion Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
hieVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> a
panic (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"readHieFile: hie file versions don't match for file:"
                    , String
file
                    , String
"Expected"
                    , Integer -> String
forall a. Show a => a -> String
show Integer
hieVersion
                    , String
"but got", Integer -> String
forall a. Show a => a -> String
show Integer
readHieVersion
                    ]
  HieFile
hieFile <- BinHandle -> NameCacheUpdater -> IO HieFile
readHieFileContents BinHandle
bh0 NameCacheUpdater
ncu
  HieFileResult -> IO HieFileResult
forall (m :: * -> *) a. Monad m => a -> m a
return (HieFileResult -> IO HieFileResult)
-> HieFileResult -> IO HieFileResult
forall a b. (a -> b) -> a -> b
$ Integer -> ByteString -> HieFile -> HieFileResult
HieFileResult Integer
hieVersion ByteString
ghcVersion HieFile
hieFile

readBinLine :: BinHandle -> IO ByteString
readBinLine :: BinHandle -> IO ByteString
readBinLine BinHandle
bh = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> ([Word8] -> [Word8]) -> [Word8] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8]
forall a. [a] -> [a]
reverse ([Word8] -> ByteString) -> IO [Word8] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word8] -> IO [Word8]
loop []
  where
    loop :: [Word8] -> IO [Word8]
loop [Word8]
acc = do
      Word8
char <- BinHandle -> IO Word8
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Word8
      if Word8
char Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
10 -- ASCII newline '\n'
      then [Word8] -> IO [Word8]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word8]
acc
      else [Word8] -> IO [Word8]
loop (Word8
char Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
acc)

readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
readHieFileHeader :: String -> BinHandle -> IO HieHeader
readHieFileHeader String
file BinHandle
bh0 = do
  -- Read the header
  [Word8]
magic <- Int -> IO Word8 -> IO [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
hieMagicLen (BinHandle -> IO Word8
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh0)
  String
version <- ByteString -> String
BSC.unpack (ByteString -> String) -> IO ByteString -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO ByteString
readBinLine BinHandle
bh0
  case String -> Maybe Integer
forall a. Read a => String -> Maybe a
maybeRead String
version of
    Maybe Integer
Nothing ->
      String -> IO HieHeader
forall a. String -> a
panic (String -> IO HieHeader) -> String -> IO HieHeader
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"readHieFileHeader: hieVersion isn't an Integer:"
                      , String -> String
forall a. Show a => a -> String
show String
version
                      ]
    Just Integer
readHieVersion -> do
      ByteString
ghcVersion <- BinHandle -> IO ByteString
readBinLine BinHandle
bh0

      -- Check if the header is valid
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Word8]
magic [Word8] -> [Word8] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Word8]
hieMagic) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall a. String -> a
panic (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"readHieFileHeader: headers don't match for file:"
                        , String
file
                        , String
"Expected"
                        , [Word8] -> String
forall a. Show a => a -> String
show [Word8]
hieMagic
                        , String
"but got", [Word8] -> String
forall a. Show a => a -> String
show [Word8]
magic
                        ]
      HieHeader -> IO HieHeader
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
readHieVersion, ByteString
ghcVersion)

readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile
readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile
readHieFileContents BinHandle
bh0 NameCacheUpdater
ncu = do

  Dictionary
dict  <- BinHandle -> IO Dictionary
get_dictionary BinHandle
bh0

  -- read the symbol table so we are capable of reading the actual data
  BinHandle
bh1 <- do
      let bh1 :: BinHandle
bh1 = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh0 (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (String -> BinHandle -> IO Name
forall a. HasCallStack => String -> a
error String
"getSymtabName")
                                               (Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
      SymbolTable
symtab <- BinHandle -> IO SymbolTable
get_symbol_table BinHandle
bh1
      let bh1' :: BinHandle
bh1' = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh1
               (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (SymbolTable -> BinHandle -> IO Name
getSymTabName SymbolTable
symtab)
                              (Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
      BinHandle -> IO BinHandle
forall (m :: * -> *) a. Monad m => a -> m a
return BinHandle
bh1'

  -- load the actual data
  HieFile
hiefile <- BinHandle -> IO HieFile
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh1
  HieFile -> IO HieFile
forall (m :: * -> *) a. Monad m => a -> m a
return HieFile
hiefile
  where
    get_dictionary :: BinHandle -> IO Dictionary
get_dictionary BinHandle
bin_handle = do
      Bin Any
dict_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bin_handle
      Bin Any
data_p <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bin_handle
      BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bin_handle Bin Any
dict_p
      Dictionary
dict <- BinHandle -> IO Dictionary
getDictionary BinHandle
bin_handle
      BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bin_handle Bin Any
data_p
      Dictionary -> IO Dictionary
forall (m :: * -> *) a. Monad m => a -> m a
return Dictionary
dict

    get_symbol_table :: BinHandle -> IO SymbolTable
get_symbol_table BinHandle
bh1 = do
      Bin Any
symtab_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh1
      Bin Any
data_p'  <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh1
      BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh1 Bin Any
symtab_p
      SymbolTable
symtab <- BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable BinHandle
bh1 NameCacheUpdater
ncu
      BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh1 Bin Any
data_p'
      SymbolTable -> IO SymbolTable
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolTable
symtab

putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next :: HieDictionary -> FastMutInt
hie_dict_next = FastMutInt
j_r,
                              hie_dict_map :: HieDictionary -> IORef (UniqFM (Int, FastString))
hie_dict_map  = IORef (UniqFM (Int, FastString))
out_r}  BinHandle
bh FastString
f
  = do
    UniqFM (Int, FastString)
out <- IORef (UniqFM (Int, FastString)) -> IO (UniqFM (Int, FastString))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Int, FastString))
out_r
    let unique :: Unique
unique = FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
f
    case UniqFM (Int, FastString) -> Unique -> Maybe (Int, FastString)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (Int, FastString)
out Unique
unique of
        Just (Int
j, FastString
_)  -> BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j :: Word32)
        Maybe (Int, FastString)
Nothing -> do
           Int
j <- FastMutInt -> IO Int
readFastMutInt FastMutInt
j_r
           BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j :: Word32)
           FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
j_r (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
           IORef (UniqFM (Int, FastString))
-> UniqFM (Int, FastString) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM (Int, FastString))
out_r (UniqFM (Int, FastString) -> IO ())
-> UniqFM (Int, FastString) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM (Int, FastString)
-> Unique -> (Int, FastString) -> UniqFM (Int, FastString)
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM (Int, FastString)
out Unique
unique (Int
j, FastString
f)

putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()
putSymbolTable :: BinHandle -> Int -> UniqFM (Int, HieName) -> IO ()
putSymbolTable BinHandle
bh Int
next_off UniqFM (Int, HieName)
symtab = do
  BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
next_off
  let names :: [HieName]
names = Array Int HieName -> [HieName]
forall i e. Array i e -> [e]
A.elems ((Int, Int) -> [(Int, HieName)] -> Array Int HieName
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
A.array (Int
0,Int
next_offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (UniqFM (Int, HieName) -> [(Int, HieName)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM (Int, HieName)
symtab))
  (HieName -> IO ()) -> [HieName] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> HieName -> IO ()
putHieName BinHandle
bh) [HieName]
names

getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable BinHandle
bh NameCacheUpdater
ncu = do
  Int
sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
  [HieName]
od_names <- Int -> IO HieName -> IO [HieName]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
sz (BinHandle -> IO HieName
getHieName BinHandle
bh)
  NameCacheUpdater -> forall c. (NameCache -> (NameCache, c)) -> IO c
updateNameCache NameCacheUpdater
ncu ((NameCache -> (NameCache, SymbolTable)) -> IO SymbolTable)
-> (NameCache -> (NameCache, SymbolTable)) -> IO SymbolTable
forall a b. (a -> b) -> a -> b
$ \NameCache
nc ->
    let arr :: SymbolTable
arr = (Int, Int) -> [Name] -> SymbolTable
forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0,Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Name]
names
        (NameCache
nc', [Name]
names) = (NameCache -> HieName -> (NameCache, Name))
-> NameCache -> [HieName] -> (NameCache, [Name])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumR NameCache -> HieName -> (NameCache, Name)
fromHieName NameCache
nc [HieName]
od_names
        in (NameCache
nc',SymbolTable
arr)

getSymTabName :: SymbolTable -> BinHandle -> IO Name
getSymTabName :: SymbolTable -> BinHandle -> IO Name
getSymTabName SymbolTable
st BinHandle
bh = do
  Word32
i :: Word32 <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
  Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> IO Name) -> Name -> IO Name
forall a b. (a -> b) -> a -> b
$ SymbolTable
st SymbolTable -> Int -> Name
forall i e. Ix i => Array i e -> i -> e
A.! (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i)

putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
putName (HieSymbolTable FastMutInt
next IORef (UniqFM (Int, HieName))
ref) BinHandle
bh Name
name = do
  UniqFM (Int, HieName)
symmap <- IORef (UniqFM (Int, HieName)) -> IO (UniqFM (Int, HieName))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Int, HieName))
ref
  case UniqFM (Int, HieName) -> Name -> Maybe (Int, HieName)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (Int, HieName)
symmap Name
name of
    Just (Int
off, ExternalName Module
mod OccName
occ (UnhelpfulSpan FastString
_))
      | SrcSpan -> Bool
isGoodSrcSpan (Name -> SrcSpan
nameSrcSpan Name
name) -> do
      let hieName :: HieName
hieName = Module -> OccName -> SrcSpan -> HieName
ExternalName Module
mod OccName
occ (Name -> SrcSpan
nameSrcSpan Name
name)
      IORef (UniqFM (Int, HieName)) -> UniqFM (Int, HieName) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM (Int, HieName))
ref (UniqFM (Int, HieName) -> IO ()) -> UniqFM (Int, HieName) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM (Int, HieName)
-> Name -> (Int, HieName) -> UniqFM (Int, HieName)
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM (Int, HieName)
symmap Name
name (Int
off, HieName
hieName)
      BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
    Just (Int
off, LocalName OccName
_occ SrcSpan
span)
      | HieName -> Bool
notLocal (Name -> HieName
toHieName Name
name) Bool -> Bool -> Bool
|| Name -> SrcSpan
nameSrcSpan Name
name SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
span -> do
      IORef (UniqFM (Int, HieName)) -> UniqFM (Int, HieName) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM (Int, HieName))
ref (UniqFM (Int, HieName) -> IO ()) -> UniqFM (Int, HieName) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM (Int, HieName)
-> Name -> (Int, HieName) -> UniqFM (Int, HieName)
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM (Int, HieName)
symmap Name
name (Int
off, Name -> HieName
toHieName Name
name)
      BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
    Just (Int
off, HieName
_) -> BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
    Maybe (Int, HieName)
Nothing -> do
        Int
off <- FastMutInt -> IO Int
readFastMutInt FastMutInt
next
        FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
next (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        IORef (UniqFM (Int, HieName)) -> UniqFM (Int, HieName) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM (Int, HieName))
ref (UniqFM (Int, HieName) -> IO ()) -> UniqFM (Int, HieName) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM (Int, HieName)
-> Name -> (Int, HieName) -> UniqFM (Int, HieName)
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM (Int, HieName)
symmap Name
name (Int
off, Name -> HieName
toHieName Name
name)
        BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)

  where
    notLocal :: HieName -> Bool
    notLocal :: HieName -> Bool
notLocal LocalName{} = Bool
False
    notLocal HieName
_ = Bool
True


-- ** Converting to and from `HieName`'s

toHieName :: Name -> HieName
toHieName :: Name -> HieName
toHieName Name
name
  | Name -> Bool
isKnownKeyName Name
name = Unique -> HieName
KnownKeyName (Name -> Unique
nameUnique Name
name)
  | Name -> Bool
isExternalName Name
name = Module -> OccName -> SrcSpan -> HieName
ExternalName (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name)
                                       (Name -> OccName
nameOccName Name
name)
                                       (Name -> SrcSpan
nameSrcSpan Name
name)
  | Bool
otherwise = OccName -> SrcSpan -> HieName
LocalName (Name -> OccName
nameOccName Name
name) (Name -> SrcSpan
nameSrcSpan Name
name)

fromHieName :: NameCache -> HieName -> (NameCache, Name)
fromHieName :: NameCache -> HieName -> (NameCache, Name)
fromHieName NameCache
nc (ExternalName Module
mod OccName
occ SrcSpan
span) =
    let cache :: OrigNameCache
cache = NameCache -> OrigNameCache
nsNames NameCache
nc
    in case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache Module
mod OccName
occ of
         Just Name
name
           | Name -> SrcSpan
nameSrcSpan Name
name SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
span -> (NameCache
nc, Name
name)
           | Bool
otherwise ->
             let name' :: Name
name' = Name -> SrcSpan -> Name
setNameLoc Name
name SrcSpan
span
                 new_cache :: OrigNameCache
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache OrigNameCache
cache Module
mod OccName
occ Name
name'
             in ( NameCache
nc{ nsNames :: OrigNameCache
nsNames = OrigNameCache
new_cache }, Name
name' )
         Maybe Name
Nothing ->
           let (Unique
uniq, UniqSupply
us) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
nc)
               name :: Name
name       = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
span
               new_cache :: OrigNameCache
new_cache  = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache OrigNameCache
cache Module
mod OccName
occ Name
name
           in ( NameCache
nc{ nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us, nsNames :: OrigNameCache
nsNames = OrigNameCache
new_cache }, Name
name )
fromHieName NameCache
nc (LocalName OccName
occ SrcSpan
span) =
    let (Unique
uniq, UniqSupply
us) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
nc)
        name :: Name
name       = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
span
    in ( NameCache
nc{ nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us }, Name
name )
fromHieName NameCache
nc (KnownKeyName Unique
u) = case Unique -> Maybe Name
lookupKnownKeyName Unique
u of
    Maybe Name
Nothing -> String -> SDoc -> (NameCache, Name)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"fromHieName:unknown known-key unique"
                        ((Char, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Unique -> (Char, Int)
unpkUnique Unique
u))
    Just Name
n -> (NameCache
nc, Name
n)

-- ** Reading and writing `HieName`'s

putHieName :: BinHandle -> HieName -> IO ()
putHieName :: BinHandle -> HieName -> IO ()
putHieName BinHandle
bh (ExternalName Module
mod OccName
occ SrcSpan
span) = do
  BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
  BinHandle -> (Module, OccName, SrcSpan) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Module
mod, OccName
occ, SrcSpan
span)
putHieName BinHandle
bh (LocalName OccName
occName SrcSpan
span) = do
  BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
  BinHandle -> (OccName, SrcSpan) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (OccName
occName, SrcSpan
span)
putHieName BinHandle
bh (KnownKeyName Unique
uniq) = do
  BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
  BinHandle -> (Char, Int) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ((Char, Int) -> IO ()) -> (Char, Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Unique -> (Char, Int)
unpkUnique Unique
uniq

getHieName :: BinHandle -> IO HieName
getHieName :: BinHandle -> IO HieName
getHieName BinHandle
bh = do
  Word8
t <- BinHandle -> IO Word8
getByte BinHandle
bh
  case Word8
t of
    Word8
0 -> do
      (Module
modu, OccName
occ, SrcSpan
span) <- BinHandle -> IO (Module, OccName, SrcSpan)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      HieName -> IO HieName
forall (m :: * -> *) a. Monad m => a -> m a
return (HieName -> IO HieName) -> HieName -> IO HieName
forall a b. (a -> b) -> a -> b
$ Module -> OccName -> SrcSpan -> HieName
ExternalName Module
modu OccName
occ SrcSpan
span
    Word8
1 -> do
      (OccName
occ, SrcSpan
span) <- BinHandle -> IO (OccName, SrcSpan)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      HieName -> IO HieName
forall (m :: * -> *) a. Monad m => a -> m a
return (HieName -> IO HieName) -> HieName -> IO HieName
forall a b. (a -> b) -> a -> b
$ OccName -> SrcSpan -> HieName
LocalName OccName
occ SrcSpan
span
    Word8
2 -> do
      (Char
c,Int
i) <- BinHandle -> IO (Char, Int)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      HieName -> IO HieName
forall (m :: * -> *) a. Monad m => a -> m a
return (HieName -> IO HieName) -> HieName -> IO HieName
forall a b. (a -> b) -> a -> b
$ Unique -> HieName
KnownKeyName (Unique -> HieName) -> Unique -> HieName
forall a b. (a -> b) -> a -> b
$ Char -> Int -> Unique
mkUnique Char
c Int
i
    Word8
_ -> String -> IO HieName
forall a. String -> a
panic String
"HieBin.getHieName: invalid tag"