ghc-hie (empty) → 0.0.0
raw patch · 15 files changed
+4728/−0 lines, 15 filesdep +QuickCheckdep +arraydep +base
Dependencies added: QuickCheck, array, base, bytestring, containers, deepseq, directory, filepath, ghc, ghc-boot, hspec, process, temporary, transformers
Files
- LICENSE +19/−0
- ghc-hie.cabal +89/−0
- src/GHC/Iface/Ext/Binary.hs +70/−0
- src/GHC/Iface/Ext/Binary/GHC912.hs +154/−0
- src/GHC/Iface/Ext/Binary/Header.hs +67/−0
- src/GHC/Iface/Ext/Binary/Instances.hs +203/−0
- src/GHC/Iface/Ext/Binary/Utils.hs +2092/−0
- src/GHC/Iface/Ext/Compat.hs +7/−0
- src/GHC/Iface/Ext/Debug.hs +160/−0
- src/GHC/Iface/Ext/Types.hs +865/−0
- src/GHC/Iface/Ext/Utils.hs +605/−0
- test/GHC/Iface/Ext/BinarySpec.hs +151/−0
- test/GHC/Iface/Ext/Upstream.hs +179/−0
- test/SmokeSpec.hs +66/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2025 Simon Hengel <sol@typeful.net>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ ghc-hie.cabal view
@@ -0,0 +1,89 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name: ghc-hie+version: 0.0.0+synopsis: HIE-file parsing machinery that supports multiple versions of GHC+category: Development+homepage: https://github.com/sol/ghc-hie#readme+bug-reports: https://github.com/sol/ghc-hie/issues+author: Simon Hengel <sol@typeful.net>+maintainer: Simon Hengel <sol@typeful.net>+copyright: (c) 2025 Simon Hengel+license: MIT+license-file: LICENSE+build-type: Simple++source-repository head+ type: git+ location: https://github.com/sol/ghc-hie++library+ exposed-modules:+ GHC.Iface.Ext.Binary+ GHC.Iface.Ext.Debug+ GHC.Iface.Ext.Types+ GHC.Iface.Ext.Utils+ other-modules:+ GHC.Iface.Ext.Binary.GHC912+ GHC.Iface.Ext.Binary.Header+ GHC.Iface.Ext.Binary.Instances+ GHC.Iface.Ext.Binary.Utils+ GHC.Iface.Ext.Compat+ hs-source-dirs:+ src+ ghc-options: -Wall -O2+ build-depends:+ array+ , base ==4.*+ , bytestring+ , containers+ , deepseq+ , directory+ , filepath+ , ghc ==9.10.1 || ==9.10.2 || ==9.12.1 || ==9.12.2+ , ghc-boot+ , transformers+ default-language: GHC2021++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ GHC.Iface.Ext.Binary+ GHC.Iface.Ext.Binary.GHC912+ GHC.Iface.Ext.Binary.Header+ GHC.Iface.Ext.Binary.Instances+ GHC.Iface.Ext.Binary.Utils+ GHC.Iface.Ext.Compat+ GHC.Iface.Ext.Debug+ GHC.Iface.Ext.Types+ GHC.Iface.Ext.Utils+ GHC.Iface.Ext.BinarySpec+ GHC.Iface.Ext.Upstream+ SmokeSpec+ hs-source-dirs:+ src+ test+ ghc-options: -Wall -O2+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ QuickCheck+ , array+ , base ==4.*+ , bytestring+ , containers+ , deepseq+ , directory+ , filepath+ , ghc ==9.10.1 || ==9.10.2 || ==9.12.1 || ==9.12.2+ , ghc-boot+ , hspec ==2.*+ , process+ , temporary+ , transformers+ default-language: GHC2021
+ src/GHC/Iface/Ext/Binary.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+module GHC.Iface.Ext.Binary (+ readHieFile+, readHieFileEither+, HieHeader+, HieFileResult(..)+, extractSourceFileName+) where++import Data.List (intercalate)+import Data.ByteString (ByteString)++import GHC.Types.Name.Cache++import GHC.Iface.Ext.Types++import GHC.Iface.Ext.Binary.Utils+import GHC.Iface.Ext.Binary.GHC912 qualified as HieFile+import GHC.Iface.Ext.Binary.Header (HieHeader, readHieFileHeader)+import GHC.Iface.Ext.Binary.Header qualified as Header++supported :: [Integer]+supported = supported910 ++ supported912++supported910 :: [Integer]+supported910 = [9081 .. 9084] ++ [9101 .. 9102]++supported912 :: [Integer]+supported912 = [9121 .. 9122]++-- | Read a `HieFile` from a `FilePath`. Can use an existing `NameCache`.+readHieFile :: NameCache -> FilePath -> IO HieFileResult+readHieFile name_cache file = readHie (unsupportedVersion file) id name_cache file++extractSourceFileName :: FilePath -> IO FilePath+extractSourceFileName file = readBinMem file >>= Header.extractSourceFileName++unsupportedVersion :: FilePath -> HieHeader -> IO a+unsupportedVersion file = fail . unsupportedVersionError file++unsupportedVersionError :: FilePath -> HieHeader -> String+unsupportedVersionError file (show -> version, _) =+ "Unsupported HIE version " <> version <> " for file " <> file <> ", supported versions: " <> supportedVersions+ where+ supportedVersions :: String+ supportedVersions = intercalate ", " . reverse $ map show supported++-- | Read a `HieFile` from a `FilePath`. Can use an existing `NameCache`.+-- `Left` case returns the failing header versions.+readHieFileEither :: NameCache -> FilePath -> IO (Either HieHeader HieFileResult)+readHieFileEither = readHie (return . Left) Right++readHie :: (HieHeader -> IO a) -> (HieFileResult -> a) -> NameCache -> FilePath -> IO a+readHie left right name_cache file = do+ bh0 <- readBinMem file+ header@(version, ghcVersion) <- readHieFileHeader file bh0+ let hieFileResult = right . HieFileResult version ghcVersion+ if+ | version `elem` supported910 -> hieFileResult <$> HieFile.readHieFile910 bh0 name_cache+ | version `elem` supported912 -> hieFileResult <$> HieFile.readHieFile912 bh0 name_cache+ | otherwise -> left header+{-# INLINE readHie #-}++data HieFileResult = HieFileResult {+ hie_file_result_version :: Integer+, hie_file_result_ghc_version :: ByteString+, hie_file_result :: HieFile+}
+ src/GHC/Iface/Ext/Binary/GHC912.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE BlockArguments #-}+module GHC.Iface.Ext.Binary.GHC912 (+ readHieFile910+, readHieFile912+) where++import Data.Typeable+import Prelude hiding (span, mod)++import GHC.Builtin.Utils+import GHC.Iface.Ext.Binary.Utils+import GHC.Iface.Ext.Types+import GHC.Types.Name+import GHC.Types.Name.Cache+import GHC.Types.Unique+import GHC.Utils.Outputable hiding (char)+import GHC.Utils.Panic+import GHC.Types.Avail (AvailInfo)+import GHC.Unit.Module (Module)+import GHC.Types.SrcLoc++import Data.Array (Array)+import qualified Data.Array as A+import qualified Data.Array.IO as A+import qualified Data.Array.Unsafe as A+import Data.Word ( Word32 )+import Data.ByteString (ByteString)+import Control.Monad++readHieFile910 :: ReadBinHandle -> NameCache -> IO HieFile+readHieFile910 bh0 name_cache = do+ dict_p <- get bh0+ symtab_p <- get bh0+ readHieFile dict_p symtab_p (const mempty) bh0 name_cache++readHieFile912 :: ReadBinHandle -> NameCache -> IO HieFile+readHieFile912 bh0 name_cache = do+ dict_p <- makeAbsoluteBin <$> getRelBin bh0+ symtab_p <- makeAbsoluteBin <$> getRelBin bh0+ readHieFile dict_p symtab_p get bh0 name_cache++initReadNameTable :: Module -> NameCache -> IO (ReaderTable Name)+initReadNameTable currentModule cache = do+ return $+ ReaderTable+ { getTable = \bh -> getSymbolTable currentModule bh cache+ , mkReaderFromTable = \tbl -> mkReader (getSymTabName tbl)+ }++readHieFile :: Bin () -> Bin () -> (ReadBinHandle -> IO NameEntityInfo) -> ReadBinHandle -> NameCache -> IO HieFile+readHieFile dict_p symtab_p getNameEntityInfo bh0 name_cache = do++ fsReaderTable <- initFastStringReaderTable+ bh_dict <- get_dictionary dict_p fsReaderTable bh0++ file <- get @FilePath bh_dict+ currentModule <- get @Module bh_dict++ nameReaderTable <- initReadNameTable currentModule name_cache+ bh_symtab <- get_dictionary symtab_p nameReaderTable bh_dict++ -- load the actual data+ HieFile file currentModule+ <$> get @(Array TypeIndex HieTypeFlat) bh_symtab+ <*> get @(HieASTs TypeIndex) bh_symtab+ <*> get @([AvailInfo]) bh_symtab+ <*> get @ByteString bh_symtab+ <*> getNameEntityInfo bh_symtab+ where+ get_dictionary :: forall a. Typeable a => Bin () -> ReaderTable a -> ReadBinHandle -> IO ReadBinHandle+ get_dictionary p tbl bin_handle = withRestore do+ seekBinReader bin_handle p+ fsTable :: SymbolTable a <- getTable tbl bin_handle+ let+ fsReader :: BinaryReader a+ fsReader = mkReaderFromTable tbl fsTable++ bhFs :: ReadBinHandle+ bhFs = addReaderToUserData fsReader bin_handle+ pure bhFs++ withRestore :: IO a -> IO a+ withRestore action = do+ backup <- tellBinReader bh0+ action <* seekBinReader bh0 backup++getSymbolTable :: Module -> ReadBinHandle -> NameCache -> IO (SymbolTable Name)+getSymbolTable currentModule bh name_cache = do+ sz <- get bh+ mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)+ forM_ [0..(sz-1)] $ \i -> do+ od_name <- getHieName bh+ name <- fromHieName currentModule name_cache od_name+ A.writeArray mut_arr i name+ A.unsafeFreeze mut_arr++getSymTabName :: SymbolTable Name -> ReadBinHandle -> IO Name+getSymTabName st bh = do+ i :: Word32 <- get bh+ return $ st A.! (fromIntegral i)++-- ** Converting to and from `HieName`'s++fromHieName :: Module -> NameCache -> HieName -> IO Name+fromHieName currentModule nc hie_name = do++ case hie_name of+ ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do+ case lookupOrigNameCache cache mod occ of+ Just old_name -> case nameSrcSpan old_name of+ UnhelpfulSpan {} -> update+ RealSrcSpan {}+ | mod == currentModule -> update+ | otherwise -> keep+ where+ new_name = mkExternalName uniq mod occ span+ new_cache = extendOrigNameCache cache mod occ new_name+ uniq = nameUnique old_name++ update = pure (new_cache, new_name)+ keep = pure (cache, old_name)++ Nothing -> do+ uniq <- takeUniqFromNameCache nc+ let name = mkExternalName uniq mod occ span+ new_cache = extendOrigNameCache cache mod occ name+ pure (new_cache, name)++ LocalName occ span -> do+ uniq <- takeUniqFromNameCache nc+ -- don't update the NameCache for local names+ pure $ mkInternalName uniq occ span++ KnownKeyName u -> case lookupKnownKeyName u of+ Nothing -> pprPanic "fromHieName:unknown known-key unique"+ (ppr u)+ Just n -> pure n++-- ** Reading and writing `HieName`'s++getHieName :: ReadBinHandle -> IO HieName+getHieName bh = do+ t <- getByte bh+ case t of+ 0 -> do+ (modu, occ, span) <- get bh+ return $ ExternalName modu occ $ unBinSrcSpan span+ 1 -> do+ (occ, span) <- get bh+ return $ LocalName occ $ unBinSrcSpan span+ 2 -> do+ (c,i) <- get bh+ return $ KnownKeyName $ mkUnique c i+ _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag"
+ src/GHC/Iface/Ext/Binary/Header.hs view
@@ -0,0 +1,67 @@+module GHC.Iface.Ext.Binary.Header (+ extractSourceFileName+, HieHeader+, readHieFileHeader+) where++import Control.Monad+import Data.Word+import Data.ByteString (ByteString, pack)+import Data.ByteString.Internal (w2c)+import GHC.Settings.Utils (maybeRead)++import GHC.Iface.Ext.Binary.Utils++hieMagic :: [Word8]+hieMagic = [72,73,69]++hieMagicLen :: Int+hieMagicLen = 3++newline :: Word8+newline = 10++extractSourceFileName :: ReadBinHandle -> IO FilePath+extractSourceFileName bh0 = do+ advance bh0 hieMagicLen+ skipLine+ skipLine+ advance bh0 8+ get @FilePath bh0+ where+ skipLine :: IO ()+ skipLine = do+ c <- get @Word8 bh0+ if c == newline+ then return ()+ else skipLine++type HieHeader = (Integer, ByteString)++readHieFileHeader :: FilePath -> ReadBinHandle -> IO HieHeader+readHieFileHeader file bh0 = do+ magic <- replicateM hieMagicLen (get bh0)+ version <- map w2c <$> takeLine+ case maybeRead version of+ Nothing -> do+ fail $ "readHieFileHeader: hieVersion isn't an Integer: " <> show version+ Just hieVersion -> do+ ghcVersion <- pack <$> takeLine+ when (magic /= hieMagic) . fail $ unwords [+ "readHieFileHeader: headers don't match for file:"+ , file+ , "Expected"+ , show hieMagic+ , "but got", show magic+ ]+ return (hieVersion, ghcVersion)+ where+ takeLine :: IO [Word8]+ takeLine = reverse <$> loop []+ where+ loop :: [Word8] -> IO [Word8]+ loop acc = do+ c <- get @Word8 bh0+ if c == newline+ then return acc+ else loop (c : acc)
+ src/GHC/Iface/Ext/Binary/Instances.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE DerivingStrategies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Iface.Ext.Binary.Instances where++import GHC.Types.Unique (getUnique)+import GHC.Types.Unique.DSet (unionManyUniqDSets)+import Control.Monad+import Data.Proxy+import GHC.Types.Name+import GHC.Types.Avail+import GHC.Types.Basic+import GHC.Types.Var hiding (varName)+import GHC.Unit.Types+import GHC.Iface.Type++import GHC.Iface.Ext.Binary.Utils++import GHC.Utils.Panic.Plain (panic)++instance Binary Name where+ put_ bh name =+ case findUserDataWriter Proxy bh of+ tbl -> putEntry tbl bh name++ get bh =+ case findUserDataReader Proxy bh of+ tbl -> getEntry tbl bh++instance Binary a => Binary (GenModule a) where+ put_ bh (Module p n) = put_ bh p >> put_ bh n+ -- Module has strict fields, so use $! in order not to allocate a thunk+ get bh = do p <- get bh; n <- get bh; return $! Module p n++instance Binary Unit where+ put_ bh (RealUnit def_uid) = do+ putByte bh 0+ put_ bh def_uid+ put_ bh (VirtUnit indef_uid) = do+ putByte bh 1+ put_ bh indef_uid+ put_ bh HoleUnit =+ putByte bh 2+ get bh = do b <- getByte bh+ u <- case b of+ 0 -> fmap RealUnit (get bh)+ 1 -> fmap VirtUnit (get bh)+ _ -> pure HoleUnit+ -- Unit has strict fields that need forcing; otherwise we allocate a thunk.+ pure $! u++deriving newtype instance Binary unit => Binary (Definite unit)++instance Binary InstantiatedUnit where+ put_ bh indef = do+ put_ bh (instUnitInstanceOf indef)+ put_ bh (instUnitInsts indef)+ get bh = do+ cid <- get bh+ insts <- get bh+ let fs = mkInstantiatedUnitHash cid insts+ -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk+ return $! InstantiatedUnit {+ instUnitInstanceOf = cid,+ instUnitInsts = insts,+ instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),+ instUnitFS = fs,+ instUnitKey = getUnique fs+ }++instance Binary UnitId where+ put_ bh (UnitId fs) = put_ bh fs+ get bh = do fs <- get bh; return (UnitId fs)++instance Binary AvailInfo where+ put_ bh (Avail aa) = do+ putByte bh 0+ put_ bh aa+ put_ bh (AvailTC ab ac) = do+ putByte bh 1+ put_ bh ab+ put_ bh ac+ get bh = do+ h <- getByte bh+ case h of+ 0 -> do aa <- get bh+ return (Avail aa)+ _ -> do ab <- get bh+ ac <- get bh+ return (AvailTC ab ac)++instance Binary IfaceTyCon where+ put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i++ get bh = do+ n <- get bh+ i <- get bh+ return (IfaceTyCon n i)++instance Binary IfaceTyConSort where+ put_ bh IfaceNormalTyCon = putByte bh 0+ put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort+ put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity+ put_ bh IfaceEqualityTyCon = putByte bh 3++ get bh = do+ n <- getByte bh+ case n of+ 0 -> return IfaceNormalTyCon+ 1 -> IfaceTupleTyCon <$> get bh <*> get bh+ 2 -> IfaceSumTyCon <$> get bh+ _ -> return IfaceEqualityTyCon++instance Binary IfaceTyConInfo where+ put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s++ get bh = mkIfaceTyConInfo <$!> get bh <*> get bh+ -- We want to make sure, when reading from disk, as the most common case+ -- is supposed to be shared. Any thunk adds an additional indirection+ -- making sharing less useful.+ --+ -- See !12200 for how this bang and the one in 'IfaceTyCon' reduces the+ -- residency by ~10% when loading 'mi_extra_decls' from disk.++instance Binary TupleSort where+ put_ bh BoxedTuple = putByte bh 0+ put_ bh UnboxedTuple = putByte bh 1+ put_ bh ConstraintTuple = putByte bh 2+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return BoxedTuple+ 1 -> return UnboxedTuple+ _ -> return ConstraintTuple++instance Binary PromotionFlag where+ put_ bh NotPromoted = putByte bh 0+ put_ bh IsPromoted = putByte bh 1++ get bh = do+ n <- getByte bh+ case n of+ 0 -> return NotPromoted+ 1 -> return IsPromoted+ _ -> fail "Binary(IsPromoted): fail)"++instance Binary ForAllTyFlag where+ put_ bh Required = putByte bh 0+ put_ bh Specified = putByte bh 1+ put_ bh Inferred = putByte bh 2++ get bh = do+ h <- getByte bh+ case h of+ 0 -> return Required+ 1 -> return Specified+ _ -> return Inferred++instance Binary IfaceTyLit where+ put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n+ put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n+ put_ bh (IfaceCharTyLit n) = putByte bh 3 >> put_ bh n++ get bh =+ do tag <- getByte bh+ case tag of+ 1 -> do { n <- get bh+ ; return (IfaceNumTyLit n) }+ 2 -> do { n <- get bh+ ; return (IfaceStrTyLit n) }+ 3 -> do { n <- get bh+ ; return (IfaceCharTyLit n) }+ _ -> panic ("get IfaceTyLit " ++ show tag)++putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)+putAllTables _ [] act = do+ a <- act+ pure ([], a)+putAllTables bh (x : xs) act = do+ (r, (res, a)) <- forwardPutRel bh (const $ putTable x bh) $ do+ putAllTables bh xs act+ pure (r : res, a)++instance Binary OccName where+ put_ bh name = do+ put_ bh (occNameSpace name)+ put_ bh (occNameFS name)+ get bh = do+ aa <- get bh+ ab <- get bh+ return (mkOccNameFS aa ab)++instance Binary NameSpace where+ put_ _ _ = undefined+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return varName+ 1 -> return dataName+ 2 -> return tvName+ 3 -> return tcClsName+ _ -> do+ parent <- get bh+ return $ fieldName parent
+ src/GHC/Iface/Ext/Binary/Utils.hs view
@@ -0,0 +1,2092 @@++{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UnboxedTuples #-}++{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}+{-# OPTIONS_GHC -w #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++--+-- (c) The University of Glasgow 2002-2006+--+-- Binary I/O library, with special tweaks for GHC+--+-- Based on the nhc98 Binary library, which is copyright+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.+-- Under the terms of the license for that software, we must tell you+-- where you can obtain the original version of the Binary library, namely+-- http://www.cs.york.ac.uk/fp/nhc98/++module GHC.Iface.Ext.Binary.Utils+ ( {-type-} Bin, RelBin(..), getRelBin,+ {-class-} Binary(..),+ {-type-} ReadBinHandle, WriteBinHandle,+ SymbolTable, Dictionary,++ BinData(..), dataHandle, handleData,+ unsafeUnpackBinBuffer,++ openBinMem,+-- closeBin,++ advance,++ seekBinWriter,+ seekBinReader,+ seekBinReaderRel,+ tellBinReader,+ tellBinWriter,+ castBin,+ withBinBuffer,+ freezeWriteHandle,+ shrinkBinBuffer,+ thawReadHandle,++ foldGet, foldGet',++ writeBinMem,+ readBinMem,+ readBinMemN,++ putAt, getAt,+ putAtRel,+ forwardPut, forwardPut_, forwardGet,+ forwardPutRel, forwardPutRel_, forwardGetRel,++ -- * For writing instances+ putByte,+ getByte,+ putByteString,+ getByteString,++ -- * Variable length encodings+ putULEB128,+ getULEB128,+ putSLEB128,+ getSLEB128,++ -- * Fixed length encoding+ FixedLengthEncoding(..),++ -- * Lazy Binary I/O+ lazyGet,+ lazyPut,+ lazyGet',+ lazyPut',+ lazyGetMaybe,+ lazyPutMaybe,++ -- * User data+ ReaderUserData, getReaderUserData, setReaderUserData, noReaderUserData,+ WriterUserData, getWriterUserData, setWriterUserData, noWriterUserData,+ mkWriterUserData, mkReaderUserData,+ newReadState, newWriteState,+ addReaderToUserData, addWriterToUserData,+ findUserDataReader, findUserDataWriter,+ -- * Binary Readers & Writers+ BinaryReader(..), BinaryWriter(..),+ mkWriter, mkReader,+ SomeBinaryReader, SomeBinaryWriter,+ mkSomeBinaryReader, mkSomeBinaryWriter,+ -- * Tables+ ReaderTable(..),+ WriterTable(..),+ -- * String table ("dictionary")+ initFastStringReaderTable, initFastStringWriterTable,+ putDictionary, getDictionary, putFS,+ FSTable(..), getDictFastString, putDictFastString,+ -- * Generic deduplication table+ GenericSymbolTable(..),+ initGenericSymbolTable,+ getGenericSymtab, putGenericSymTab,+ getGenericSymbolTable, putGenericSymbolTable,+ -- * Newtype wrappers+ BinSpan(..), BinSrcSpan(..), BinLocated(..),+ -- * Newtypes for types that have canonically more than one valid encoding+ BindingName(..),+ simpleBindingNameWriter,+ simpleBindingNameReader,+ FullBinData(..), freezeBinHandle, thawBinHandle, putFullBinData,+ BinArray,++ makeAbsoluteBin,+ ) where++import GHC.Prelude++import Language.Haskell.Syntax.Module.Name (ModuleName(..))++import GHC.Types.Name (Name)+import GHC.Data.FastString+import GHC.Data.TrieMap+import GHC.Utils.Panic.Plain+import GHC.Types.Unique.FM+import GHC.Data.FastMutInt+import GHC.Utils.Fingerprint+import GHC.Types.SrcLoc+import GHC.Types.Unique+import qualified GHC.Data.Strict as Strict+import GHC.Utils.Outputable( JoinPointHood(..) )++import Control.DeepSeq+import Control.Monad ( when, (<$!>), unless, forM_, void )+import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)+import Data.Array+import Data.Array.IO+import Data.Array.Unsafe+import Data.ByteString (ByteString, copy)+import Data.Coerce+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe as BS+import Data.IORef+import Data.Char ( ord, chr )+import Data.List.NonEmpty ( NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Proxy+import Data.Set ( Set )+import qualified Data.Set as Set+import Data.List (unfoldr)+import System.IO as IO+import System.IO.Unsafe ( unsafeInterleaveIO )+import System.IO.Error ( mkIOError, eofErrorType )+import Type.Reflection ( Typeable, SomeTypeRep(..) )+import qualified Type.Reflection as Refl+import GHC.Real ( Ratio(..) )+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+#if MIN_VERSION_base(4,15,0)+import GHC.ForeignPtr ( unsafeWithForeignPtr )+#endif++import Unsafe.Coerce (unsafeCoerce)++type BinArray = ForeignPtr Word8++#if !MIN_VERSION_base(4,15,0)+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+unsafeWithForeignPtr = withForeignPtr+#endif++---------------------------------------------------------------+-- BinData+---------------------------------------------------------------++data BinData = BinData Int BinArray++instance NFData BinData where+ rnf (BinData sz _) = rnf sz++instance Binary BinData where+ put_ bh (BinData sz dat) = do+ put_ bh sz+ putPrim bh sz $ \dest ->+ unsafeWithForeignPtr dat $ \orig ->+ copyBytes dest orig sz+ --+ get bh = do+ sz <- get bh+ dat <- mallocForeignPtrBytes sz+ getPrim bh sz $ \orig ->+ unsafeWithForeignPtr dat $ \dest ->+ copyBytes dest orig sz+ return (BinData sz dat)++dataHandle :: BinData -> IO ReadBinHandle+dataHandle (BinData size bin) = do+ ixr <- newFastMutInt 0+ return (ReadBinMem noReaderUserData ixr size bin)++handleData :: WriteBinHandle -> IO BinData+handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr++---------------------------------------------------------------+-- FullBinData+---------------------------------------------------------------++-- | 'FullBinData' stores a slice to a 'BinArray'.+--+-- It requires less memory than 'ReadBinHandle', and can be constructed from+-- a 'ReadBinHandle' via 'freezeBinHandle' and turned back into a+-- 'ReadBinHandle' using 'thawBinHandle'.+-- Additionally, the byte array slice can be put into a 'WriteBinHandle' without extra+-- conversions via 'putFullBinData'.+data FullBinData = FullBinData+ { fbd_readerUserData :: ReaderUserData+ -- ^ 'ReaderUserData' that can be used to resume reading.+ , fbd_off_s :: {-# UNPACK #-} !Int+ -- ^ start offset+ , fbd_off_e :: {-# UNPACK #-} !Int+ -- ^ end offset+ , fbd_size :: {-# UNPACK #-} !Int+ -- ^ total buffer size+ , fbd_buffer :: {-# UNPACK #-} !BinArray+ }++-- Equality and Ord assume that two distinct buffers are different, even if they compare the same things.+instance Eq FullBinData where+ (FullBinData _ b c d e) == (FullBinData _ b1 c1 d1 e1) = b == b1 && c == c1 && d == d1 && e == e1++instance Ord FullBinData where+ compare (FullBinData _ b c d e) (FullBinData _ b1 c1 d1 e1) =+ compare b b1 `mappend` compare c c1 `mappend` compare d d1 `mappend` compare e e1++-- | Write the 'FullBinData' slice into the 'WriteBinHandle'.+putFullBinData :: WriteBinHandle -> FullBinData -> IO ()+putFullBinData bh (FullBinData _ o1 o2 _sz ba) = do+ let sz = o2 - o1+ putPrim bh sz $ \dest ->+ unsafeWithForeignPtr (ba `plusForeignPtr` o1) $ \orig ->+ copyBytes dest orig sz++-- | Freeze a 'ReadBinHandle' and a start index into a 'FullBinData'.+--+-- 'FullBinData' stores a slice starting from the 'Bin a' location to the current+-- offset of the 'ReadBinHandle'.+freezeBinHandle :: ReadBinHandle -> Bin a -> IO FullBinData+freezeBinHandle (ReadBinMem user_data ixr sz binr) (BinPtr start) = do+ ix <- readFastMutInt ixr+ pure (FullBinData user_data start ix sz binr)++-- | Turn the 'FullBinData' into a 'ReadBinHandle', setting the 'ReadBinHandle'+-- offset to the start of the 'FullBinData' and restore the 'ReaderUserData' that was+-- obtained from 'freezeBinHandle'.+thawBinHandle :: FullBinData -> IO ReadBinHandle+thawBinHandle (FullBinData user_data ix _end sz ba) = do+ ixr <- newFastMutInt ix+ return $ ReadBinMem user_data ixr sz ba++---------------------------------------------------------------+-- BinHandle+---------------------------------------------------------------++-- | A write-only handle that can be used to serialise binary data into a buffer.+--+-- The buffer is an unboxed binary array.+data WriteBinHandle+ = WriteBinMem {+ wbm_userData :: WriterUserData,+ -- ^ User data for writing binary outputs.+ -- Allows users to overwrite certain 'Binary' instances.+ -- This is helpful when a non-canonical 'Binary' instance is required,+ -- such as in the case of 'Name'.+ wbm_off_r :: !FastMutInt, -- ^ the current offset+ wbm_sz_r :: !FastMutInt, -- ^ size of the array (cached)+ wbm_arr_r :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1))+ }++-- | A read-only handle that can be used to deserialise binary data from a buffer.+--+-- The buffer is an unboxed binary array.+data ReadBinHandle+ = ReadBinMem {+ rbm_userData :: ReaderUserData,+ -- ^ User data for reading binary inputs.+ -- Allows users to overwrite certain 'Binary' instances.+ -- This is helpful when a non-canonical 'Binary' instance is required,+ -- such as in the case of 'Name'.+ rbm_off_r :: !FastMutInt, -- ^ the current offset+ rbm_sz_r :: !Int, -- ^ size of the array (cached)+ rbm_arr_r :: !BinArray -- ^ the array (bounds: (0,size-1))+ }++getReaderUserData :: ReadBinHandle -> ReaderUserData+getReaderUserData bh = rbm_userData bh++getWriterUserData :: WriteBinHandle -> WriterUserData+getWriterUserData bh = wbm_userData bh++setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle+setWriterUserData bh us = bh { wbm_userData = us }++setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle+setReaderUserData bh us = bh { rbm_userData = us }++-- | Add 'SomeBinaryReader' as a known binary decoder.+-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData',+-- it is overwritten.+addReaderToUserData :: forall a. Typeable a => BinaryReader a -> ReadBinHandle -> ReadBinHandle+addReaderToUserData reader bh = bh+ { rbm_userData = (rbm_userData bh)+ { ud_reader_data =+ let+ typRep = Refl.typeRep @a+ in+ Map.insert (SomeTypeRep typRep) (SomeBinaryReader typRep reader) (ud_reader_data (rbm_userData bh))+ }+ }++-- | Add 'SomeBinaryWriter' as a known binary encoder.+-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData',+-- it is overwritten.+addWriterToUserData :: forall a . Typeable a => BinaryWriter a -> WriteBinHandle -> WriteBinHandle+addWriterToUserData writer bh = bh+ { wbm_userData = (wbm_userData bh)+ { ud_writer_data =+ let+ typRep = Refl.typeRep @a+ in+ Map.insert (SomeTypeRep typRep) (SomeBinaryWriter typRep writer) (ud_writer_data (wbm_userData bh))+ }+ }++-- | Get access to the underlying buffer.+withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a+withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do+ ix <- readFastMutInt ix_r+ arr <- readIORef arr_r+ action $ BS.fromForeignPtr arr 0 ix++unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle+unsafeUnpackBinBuffer (BS.BS arr len) = do+ ix_r <- newFastMutInt 0+ return (ReadBinMem noReaderUserData ix_r len arr)++---------------------------------------------------------------+-- Bin+---------------------------------------------------------------++newtype Bin a = BinPtr Int+ deriving (Eq, Ord, Show, Bounded)++-- | Like a 'Bin' but is used to store relative offset pointers.+-- Relative offset pointers store a relative location, but also contain an+-- anchor that allow to obtain the absolute offset.+data RelBin a = RelBin+ { relBin_anchor :: {-# UNPACK #-} !(Bin a)+ -- ^ Absolute position from where we read 'relBin_offset'.+ , relBin_offset :: {-# UNPACK #-} !(RelBinPtr a)+ -- ^ Relative offset to 'relBin_anchor'.+ -- The absolute position of the 'RelBin' is @relBin_anchor + relBin_offset@+ }+ deriving (Eq, Ord, Show, Bounded)++-- | A 'RelBinPtr' is like a 'Bin', but contains a relative offset pointer+-- instead of an absolute offset.+newtype RelBinPtr a = RelBinPtr (Bin a)+ deriving (Eq, Ord, Show, Bounded)++castBin :: Bin a -> Bin b+castBin (BinPtr i) = BinPtr i++-- | Read a relative offset location and wrap it in 'RelBin'.+--+-- The resulting 'RelBin' can be translated into an absolute offset location using+-- 'makeAbsoluteBin'+getRelBin :: ReadBinHandle -> IO (RelBin a)+getRelBin bh = do+ start <- tellBinReader bh+ off <- get bh+ pure $ RelBin start off++makeAbsoluteBin :: RelBin a -> Bin a+makeAbsoluteBin (RelBin (BinPtr !start) (RelBinPtr (BinPtr !offset))) =+ BinPtr $ start + offset+{-# INLINE makeAbsoluteBin #-}++makeRelativeBin :: RelBin a -> RelBinPtr a+makeRelativeBin (RelBin _ offset) = offset++toRelBin :: Bin (RelBinPtr a) -> Bin a -> RelBin a+toRelBin (BinPtr !start) (BinPtr !goal) =+ RelBin (BinPtr start) (RelBinPtr $ BinPtr $ goal - start)++---------------------------------------------------------------+-- class Binary+---------------------------------------------------------------++-- | Do not rely on instance sizes for general types,+-- we use variable length encoding for many of them.+class Binary a where+ put_ :: WriteBinHandle -> a -> IO ()+ put :: WriteBinHandle -> a -> IO (Bin a)+ get :: ReadBinHandle -> IO a++ -- define one of put_, put. Use of put_ is recommended because it+ -- is more likely that tail-calls can kick in, and we rarely need the+ -- position return value.+ put_ bh a = do _ <- put bh a; return ()+ put bh a = do p <- tellBinWriter bh; put_ bh a; return p++putAt :: Binary a => WriteBinHandle -> Bin a -> a -> IO ()+putAt bh p x = do seekBinWriter bh p; put_ bh x; return ()++putAtRel :: WriteBinHandle -> Bin (RelBinPtr a) -> Bin a -> IO ()+putAtRel bh from to = putAt bh from (makeRelativeBin $ toRelBin from to)++getAt :: Binary a => ReadBinHandle -> Bin a -> IO a+getAt bh p = do seekBinReader bh p; get bh++openBinMem :: Int -> IO WriteBinHandle+openBinMem size+ | size <= 0 = error "GHC.Iface.Ext.Binary.Utils.openBinMem: size must be >= 0"+ | otherwise = do+ arr <- mallocForeignPtrBytes size+ arr_r <- newIORef arr+ ix_r <- newFastMutInt 0+ sz_r <- newFastMutInt size+ return WriteBinMem+ { wbm_userData = noWriterUserData+ , wbm_off_r = ix_r+ , wbm_sz_r = sz_r+ , wbm_arr_r = arr_r+ }++-- | Freeze the given 'WriteBinHandle' and turn it into an equivalent 'ReadBinHandle'.+--+-- The current offset of the 'WriteBinHandle' is maintained in the new 'ReadBinHandle'.+freezeWriteHandle :: WriteBinHandle -> IO ReadBinHandle+freezeWriteHandle wbm = do+ rbm_off_r <- newFastMutInt =<< readFastMutInt (wbm_off_r wbm)+ rbm_sz_r <- readFastMutInt (wbm_sz_r wbm)+ rbm_arr_r <- readIORef (wbm_arr_r wbm)+ pure $ ReadBinMem+ { rbm_userData = noReaderUserData+ , rbm_off_r = rbm_off_r+ , rbm_sz_r = rbm_sz_r+ , rbm_arr_r = rbm_arr_r+ }++-- | Copy the BinBuffer to a new BinBuffer which is exactly the right size.+-- This performs a copy of the underlying buffer.+-- The buffer may be truncated if the offset is not at the end of the written+-- output.+--+-- UserData is also discarded during the copy+-- You should just use this when translating a Put handle into a Get handle.+shrinkBinBuffer :: WriteBinHandle -> IO ReadBinHandle+shrinkBinBuffer bh = withBinBuffer bh $ \bs -> do+ unsafeUnpackBinBuffer (copy bs)++thawReadHandle :: ReadBinHandle -> IO WriteBinHandle+thawReadHandle rbm = do+ wbm_off_r <- newFastMutInt =<< readFastMutInt (rbm_off_r rbm)+ wbm_sz_r <- newFastMutInt (rbm_sz_r rbm)+ wbm_arr_r <- newIORef (rbm_arr_r rbm)+ pure $ WriteBinMem+ { wbm_userData = noWriterUserData+ , wbm_off_r = wbm_off_r+ , wbm_sz_r = wbm_sz_r+ , wbm_arr_r = wbm_arr_r+ }++tellBinWriter :: WriteBinHandle -> IO (Bin a)+tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)++tellBinReader :: ReadBinHandle -> IO (Bin a)+tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)++seekBinWriter :: WriteBinHandle -> Bin a -> IO ()+seekBinWriter h@(WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do+ sz <- readFastMutInt sz_r+ if (p > sz)+ then do expandBin h p; writeFastMutInt ix_r p+ else writeFastMutInt ix_r p++-- | 'seekBinNoExpandWriter' moves the index pointer to the location pointed to+-- by 'Bin a'.+-- This operation may 'panic', if the pointer location is out of bounds of the+-- buffer of 'BinHandle'.+seekBinNoExpandWriter :: WriteBinHandle -> Bin a -> IO ()+seekBinNoExpandWriter (WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do+ sz <- readFastMutInt sz_r+ if (p > sz)+ then panic "seekBinNoExpandWriter: seek out of range"+ else writeFastMutInt ix_r p++-- | SeekBin but without calling expandBin+seekBinReader :: ReadBinHandle -> Bin a -> IO ()+seekBinReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do+ if (p > sz_r)+ then panic "seekBinReader: seek out of range"+ else writeFastMutInt ix_r p++advance :: ReadBinHandle -> Int -> IO ()+advance (ReadBinMem _ ix_r sz_r _) !n = do+ !p <- readFastMutInt ix_r+ let !np = p + n+ if (np > sz_r)+ then panic "advance: seek out of range"+ else writeFastMutInt ix_r np++seekBinReaderRel :: ReadBinHandle -> RelBin a -> IO ()+seekBinReaderRel (ReadBinMem _ ix_r sz_r _) relBin = do+ let (BinPtr !p) = makeAbsoluteBin relBin+ if (p > sz_r)+ then panic "seekBinReaderRel: seek out of range"+ else writeFastMutInt ix_r p++writeBinMem :: WriteBinHandle -> FilePath -> IO ()+writeBinMem (WriteBinMem _ ix_r _ arr_r) fn = do+ h <- openBinaryFile fn WriteMode+ arr <- readIORef arr_r+ ix <- readFastMutInt ix_r+ unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix+ hClose h++readBinMem :: FilePath -> IO ReadBinHandle+readBinMem filename = do+ withBinaryFile filename ReadMode $ \h -> do+ filesize' <- hFileSize h+ let filesize = fromIntegral filesize'+ readBinMem_ filesize h++readBinMemN :: Int -> FilePath -> IO (Maybe ReadBinHandle)+readBinMemN size filename = do+ withBinaryFile filename ReadMode $ \h -> do+ filesize' <- hFileSize h+ let filesize = fromIntegral filesize'+ if filesize < size+ then pure Nothing+ else Just <$> readBinMem_ size h++readBinMem_ :: Int -> Handle -> IO ReadBinHandle+readBinMem_ filesize h = do+ arr <- mallocForeignPtrBytes filesize+ count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize+ when (count /= filesize) $+ error ("Binary.readBinMem: only read " ++ show count ++ " bytes")+ ix_r <- newFastMutInt 0+ return ReadBinMem+ { rbm_userData = noReaderUserData+ , rbm_off_r = ix_r+ , rbm_sz_r = filesize+ , rbm_arr_r = arr+ }++-- expand the size of the array to include a specified offset+expandBin :: WriteBinHandle -> Int -> IO ()+expandBin (WriteBinMem _ _ sz_r arr_r) !off = do+ !sz <- readFastMutInt sz_r+ let !sz' = getSize sz+ arr <- readIORef arr_r+ arr' <- mallocForeignPtrBytes sz'+ withForeignPtr arr $ \old ->+ withForeignPtr arr' $ \new ->+ copyBytes new old sz+ writeFastMutInt sz_r sz'+ writeIORef arr_r arr'+ where+ getSize :: Int -> Int+ getSize !sz+ | sz > off+ = sz+ | otherwise+ = getSize (sz * 2)++foldGet+ :: Binary a+ => Word -- n elements+ -> ReadBinHandle+ -> b -- initial accumulator+ -> (Word -> a -> b -> IO b)+ -> IO b+foldGet n bh init_b f = go 0 init_b+ where+ go i b+ | i == n = return b+ | otherwise = do+ a <- get bh+ b' <- f i a b+ go (i+1) b'++foldGet'+ :: Binary a+ => Word -- n elements+ -> ReadBinHandle+ -> b -- initial accumulator+ -> (Word -> a -> b -> IO b)+ -> IO b+{-# INLINE foldGet' #-}+foldGet' n bh init_b f = go 0 init_b+ where+ go i !b+ | i == n = return b+ | otherwise = do+ !a <- get bh+ b' <- f i a b+ go (i+1) b'+++-- -----------------------------------------------------------------------------+-- Low-level reading/writing of bytes++-- | Takes a size and action writing up to @size@ bytes.+-- After the action has run advance the index to the buffer+-- by size bytes.+putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()+putPrim h@(WriteBinMem _ ix_r sz_r arr_r) size f = do+ ix <- readFastMutInt ix_r+ sz <- readFastMutInt sz_r+ when (ix + size > sz) $+ expandBin h (ix + size)+ arr <- readIORef arr_r+ unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix)+ writeFastMutInt ix_r (ix + size)++-- -- | Similar to putPrim but advances the index by the actual number of+-- -- bytes written.+-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO ()+-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do+-- ix <- readFastMutInt ix_r+-- sz <- readFastMutInt sz_r+-- when (ix + size > sz) $+-- expandBin h (ix + size)+-- arr <- readIORef arr_r+-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)+-- writeFastMutInt ix_r (ix + written)++getPrim :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a+getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do+ ix <- readFastMutInt ix_r+ when (ix + size > sz_r) $+ ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)+ w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix)+ -- This is safe WRT #17760 as we we guarantee that the above line doesn't+ -- diverge+ writeFastMutInt ix_r (ix + size)+ return w++putWord8 :: WriteBinHandle -> Word8 -> IO ()+putWord8 h !w = putPrim h 1 (\op -> poke op w)++getWord8 :: ReadBinHandle -> IO Word8+getWord8 h = getPrim h 1 peek++putWord16 :: WriteBinHandle -> Word16 -> IO ()+putWord16 h w = putPrim h 2 (\op -> do+ pokeElemOff op 0 (fromIntegral (w `shiftR` 8))+ pokeElemOff op 1 (fromIntegral (w .&. 0xFF))+ )++getWord16 :: ReadBinHandle -> IO Word16+getWord16 h = getPrim h 2 (\op -> do+ w0 <- fromIntegral <$> peekElemOff op 0+ w1 <- fromIntegral <$> peekElemOff op 1+ return $! w0 `shiftL` 8 .|. w1+ )++putWord32 :: WriteBinHandle -> Word32 -> IO ()+putWord32 h w = putPrim h 4 (\op -> do+ pokeElemOff op 0 (fromIntegral (w `shiftR` 24))+ pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))+ pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF))+ pokeElemOff op 3 (fromIntegral (w .&. 0xFF))+ )++getWord32 :: ReadBinHandle -> IO Word32+getWord32 h = getPrim h 4 (\op -> do+ w0 <- fromIntegral <$> peekElemOff op 0+ w1 <- fromIntegral <$> peekElemOff op 1+ w2 <- fromIntegral <$> peekElemOff op 2+ w3 <- fromIntegral <$> peekElemOff op 3++ return $! (w0 `shiftL` 24) .|.+ (w1 `shiftL` 16) .|.+ (w2 `shiftL` 8) .|.+ w3+ )++putWord64 :: WriteBinHandle -> Word64 -> IO ()+putWord64 h w = putPrim h 8 (\op -> do+ pokeElemOff op 0 (fromIntegral (w `shiftR` 56))+ pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))+ pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))+ pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))+ pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))+ pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))+ pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))+ pokeElemOff op 7 (fromIntegral (w .&. 0xFF))+ )++getWord64 :: ReadBinHandle -> IO Word64+getWord64 h = getPrim h 8 (\op -> do+ w0 <- fromIntegral <$> peekElemOff op 0+ w1 <- fromIntegral <$> peekElemOff op 1+ w2 <- fromIntegral <$> peekElemOff op 2+ w3 <- fromIntegral <$> peekElemOff op 3+ w4 <- fromIntegral <$> peekElemOff op 4+ w5 <- fromIntegral <$> peekElemOff op 5+ w6 <- fromIntegral <$> peekElemOff op 6+ w7 <- fromIntegral <$> peekElemOff op 7++ return $! (w0 `shiftL` 56) .|.+ (w1 `shiftL` 48) .|.+ (w2 `shiftL` 40) .|.+ (w3 `shiftL` 32) .|.+ (w4 `shiftL` 24) .|.+ (w5 `shiftL` 16) .|.+ (w6 `shiftL` 8) .|.+ w7+ )++putByte :: WriteBinHandle -> Word8 -> IO ()+putByte bh !w = putWord8 bh w++getByte :: ReadBinHandle -> IO Word8+getByte h = getWord8 h++-- -----------------------------------------------------------------------------+-- Encode numbers in LEB128 encoding.+-- Requires one byte of space per 7 bits of data.+--+-- There are signed and unsigned variants.+-- Do NOT use the unsigned one for signed values, at worst it will+-- result in wrong results, at best it will lead to bad performance+-- when coercing negative values to an unsigned type.+--+-- We mark them as SPECIALIZE as it's extremely critical that they get specialized+-- to their specific types.+--+-- TODO: Each use of putByte performs a bounds check,+-- we should use putPrimMax here. However it's quite hard to return+-- the number of bytes written into putPrimMax without allocating an+-- Int for it, while the code below does not allocate at all.+-- So we eat the cost of the bounds check instead of increasing allocations+-- for now.++-- Unsigned numbers+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-}+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-}+putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO ()+putULEB128 bh w =+#if defined(DEBUG)+ (if w < 0 then panic "putULEB128: Signed number" else id) $+#endif+ go w+ where+ go :: a -> IO ()+ go w+ | w <= (127 :: a)+ = putByte bh (fromIntegral w :: Word8)+ | otherwise = do+ -- bit 7 (8th bit) indicates more to come.+ let !byte = setBit (fromIntegral w) 7 :: Word8+ putByte bh byte+ go (w `unsafeShiftR` 7)++{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word64 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word32 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word16 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int64 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int32 #-}+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int16 #-}+getULEB128 :: forall a. (Integral a, FiniteBits a) => ReadBinHandle -> IO a+getULEB128 bh =+ go 0 0+ where+ go :: Int -> a -> IO a+ go shift w = do+ b <- getByte bh+ let !hasMore = testBit b 7+ let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a+ if hasMore+ then do+ go (shift+7) val+ else+ return $! val++-- Signed numbers+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}+putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()+putSLEB128 bh initial = go initial+ where+ go :: a -> IO ()+ go val = do+ let !byte = fromIntegral (clearBit val 7) :: Word8+ let !val' = val `unsafeShiftR` 7+ let !signBit = testBit byte 6+ let !done =+ -- Unsigned value, val' == 0 and last value can+ -- be discriminated from a negative number.+ ((val' == 0 && not signBit) ||+ -- Signed value,+ (val' == -1 && signBit))++ let !byte' = if done then byte else setBit byte 7+ putByte bh byte'++ unless done $ go val'++{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-}+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-}+getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a+getSLEB128 bh = do+ (val,shift,signed) <- go 0 0+ if signed && (shift < finiteBitSize val )+ then return $! ((complement 0 `unsafeShiftL` shift) .|. val)+ else return val+ where+ go :: Int -> a -> IO (a,Int,Bool)+ go shift val = do+ byte <- getByte bh+ let !byteVal = fromIntegral (clearBit byte 7) :: a+ let !val' = val .|. (byteVal `unsafeShiftL` shift)+ let !more = testBit byte 7+ let !shift' = shift+7+ if more+ then go (shift') val'+ else do+ let !signed = testBit byte 6+ return (val',shift',signed)++-- -----------------------------------------------------------------------------+-- Fixed length encoding instances++-- Sometimes words are used to represent a certain bit pattern instead+-- of a number. Using FixedLengthEncoding we will write the pattern as+-- is to the interface file without the variable length encoding we usually+-- apply.++-- | Encode the argument in its full length. This is different from many default+-- binary instances which make no guarantee about the actual encoding and+-- might do things using variable length encoding.+newtype FixedLengthEncoding a+ = FixedLengthEncoding { unFixedLength :: a }+ deriving (Eq,Ord,Show)++instance Binary (FixedLengthEncoding Word8) where+ put_ h (FixedLengthEncoding x) = putByte h x+ get h = FixedLengthEncoding <$> getByte h++instance Binary (FixedLengthEncoding Word16) where+ put_ h (FixedLengthEncoding x) = putWord16 h x+ get h = FixedLengthEncoding <$> getWord16 h++instance Binary (FixedLengthEncoding Word32) where+ put_ h (FixedLengthEncoding x) = putWord32 h x+ get h = FixedLengthEncoding <$> getWord32 h++instance Binary (FixedLengthEncoding Word64) where+ put_ h (FixedLengthEncoding x) = putWord64 h x+ get h = FixedLengthEncoding <$> getWord64 h++-- -----------------------------------------------------------------------------+-- Primitive Word writes++instance Binary Word8 where+ put_ bh !w = putWord8 bh w+ get = getWord8++instance Binary Word16 where+ put_ = putULEB128+ get = getULEB128++instance Binary Word32 where+ put_ = putULEB128+ get = getULEB128++instance Binary Word64 where+ put_ = putULEB128+ get = getULEB128++-- -----------------------------------------------------------------------------+-- Primitive Int writes++instance Binary Int8 where+ put_ h w = put_ h (fromIntegral w :: Word8)+ get h = do w <- get h; return $! (fromIntegral (w::Word8))++instance Binary Int16 where+ put_ = putSLEB128+ get = getSLEB128++instance Binary Int32 where+ put_ = putSLEB128+ get = getSLEB128++instance Binary Int64 where+ put_ h w = putSLEB128 h w+ get h = getSLEB128 h++-- -----------------------------------------------------------------------------+-- Instances for standard types++instance Binary () where+ put_ _ () = return ()+ get _ = return ()++instance Binary Bool where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))++instance Binary Char where+ put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)+ get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))++instance Binary Int where+ put_ bh i = put_ bh (fromIntegral i :: Int64)+ get bh = do+ x <- get bh+ return $! (fromIntegral (x :: Int64))++instance Binary a => Binary [a] where+ put_ bh l = do+ let len = length l+ put_ bh len+ mapM_ (put_ bh) l+ get bh = do+ len <- get bh :: IO Int -- Int is variable length encoded so only+ -- one byte for small lists.+ let loop 0 = return []+ loop n = do a <- get bh; as <- loop (n-1); return (a:as)+ loop len++-- | This instance doesn't rely on the determinism of the keys' 'Ord' instance,+-- so it works e.g. for 'Name's too.+instance (Binary a, Ord a) => Binary (Set a) where+ put_ bh s = put_ bh (Set.toList s)+ get bh = Set.fromList <$> get bh++instance Binary a => Binary (NonEmpty a) where+ put_ bh = put_ bh . NonEmpty.toList+ get bh = NonEmpty.fromList <$> get bh++instance (Ix a, Binary a, Binary b) => Binary (Array a b) where+ put_ bh arr = do+ put_ bh $ bounds arr+ put_ bh $ elems arr+ get bh = do+ bounds <- get bh+ xs <- get bh+ return $ listArray bounds xs++instance (Binary a, Binary b) => Binary (a,b) where+ put_ bh (a,b) = do put_ bh a; put_ bh b+ get bh = do a <- get bh+ b <- get bh+ return (a,b)++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+ put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ return (a,b,c)++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+ put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ d <- get bh+ return (a,b,c,d)++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where+ put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ d <- get bh+ e <- get bh+ return (a,b,c,d,e)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where+ put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ d <- get bh+ e <- get bh+ f <- get bh+ return (a,b,c,d,e,f)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where+ put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ d <- get bh+ e <- get bh+ f <- get bh+ g <- get bh+ return (a,b,c,d,e,f,g)++instance Binary a => Binary (Maybe a) where+ put_ bh Nothing = putByte bh 0+ put_ bh (Just a) = do putByte bh 1; put_ bh a+ get bh = do h <- getWord8 bh+ case h of+ 0 -> return Nothing+ _ -> do x <- get bh; return (Just x)++instance Binary a => Binary (Strict.Maybe a) where+ put_ bh Strict.Nothing = putByte bh 0+ put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a+ get bh =+ do h <- getWord8 bh+ case h of+ 0 -> return Strict.Nothing+ _ -> do x <- get bh; return (Strict.Just x)++instance (Binary a, Binary b) => Binary (Either a b) where+ put_ bh (Left a) = do putByte bh 0; put_ bh a+ put_ bh (Right b) = do putByte bh 1; put_ bh b+ get bh = do h <- getWord8 bh+ case h of+ 0 -> do a <- get bh ; return (Left a)+ _ -> do b <- get bh ; return (Right b)++instance Binary JoinPointHood where+ put_ bh NotJoinPoint = putByte bh 0+ put_ bh (JoinPoint ar) = do+ putByte bh 1+ put_ bh ar+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return NotJoinPoint+ _ -> do { ar <- get bh; return (JoinPoint ar) }++{-+Finally - a reasonable portable Integer instance.++We used to encode values in the Int32 range as such,+falling back to a string of all things. In either case+we stored a tag byte to discriminate between the two cases.++This made some sense as it's highly portable but also not very+efficient.++However GHC stores a surprisingly large number of large Integer+values. In the examples looked at between 25% and 50% of Integers+serialized were outside of the Int32 range.++Consider a value like `2724268014499746065`, some sort of hash+actually generated by GHC.+In the old scheme this was encoded as a list of 19 chars. This+gave a size of 77 Bytes, one for the length of the list and 76+since we encode chars as Word32 as well.++We can easily do better. The new plan is:++* Start with a tag byte+ * 0 => Int64 (LEB128 encoded)+ * 1 => Negative large integer+ * 2 => Positive large integer+* Followed by the value:+ * Int64 is encoded as usual+ * Large integers are encoded as a list of bytes (Word8).+ We use Data.Bits which defines a bit order independent of the representation.+ Values are stored LSB first.++This means our example value `2724268014499746065` is now only 10 bytes large.+* One byte tag+* One byte for the length of the [Word8] list.+* 8 bytes for the actual date.++The new scheme also does not depend in any way on+architecture specific details.++We still use this scheme even with LEB128 available,+as it has less overhead for truly large numbers. (> maxBound :: Int64)++The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal+-}++instance Binary Integer where+ put_ bh i+ | i >= lo64 && i <= hi64 = do+ putWord8 bh 0+ put_ bh (fromIntegral i :: Int64)+ | otherwise = do+ if i < 0+ then putWord8 bh 1+ else putWord8 bh 2+ put_ bh (unroll $ abs i)+ where+ lo64 = fromIntegral (minBound :: Int64)+ hi64 = fromIntegral (maxBound :: Int64)+ get bh = do+ int_kind <- getWord8 bh+ case int_kind of+ 0 -> fromIntegral <$!> (get bh :: IO Int64)+ -- Large integer+ 1 -> negate <$!> getInt+ 2 -> getInt+ _ -> panic "Binary Integer - Invalid byte"+ where+ getInt :: IO Integer+ getInt = roll <$!> (get bh :: IO [Word8])++unroll :: Integer -> [Word8]+unroll = unfoldr step+ where+ step 0 = Nothing+ step i = Just (fromIntegral i, i `shiftR` 8)++roll :: [Word8] -> Integer+roll = foldl' unstep 0 . reverse+ where+ unstep a b = a `shiftL` 8 .|. fromIntegral b+++ {-+ -- This code is currently commented out.+ -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for+ -- discussion.++ put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)+ put_ bh (J# s# a#) = do+ putByte bh 1+ put_ bh (I# s#)+ let sz# = sizeofByteArray# a# -- in *bytes*+ put_ bh (I# sz#) -- in *bytes*+ putByteArray bh a# sz#++ get bh = do+ b <- getByte bh+ case b of+ 0 -> do (I# i#) <- get bh+ return (S# i#)+ _ -> do (I# s#) <- get bh+ sz <- get bh+ (BA a#) <- getByteArray bh sz+ return (J# s# a#)++putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()+putByteArray bh a s# = loop 0#+ where loop n#+ | n# ==# s# = return ()+ | otherwise = do+ putByte bh (indexByteArray a n#)+ loop (n# +# 1#)++getByteArray :: BinHandle -> Int -> IO ByteArray+getByteArray bh (I# sz) = do+ (MBA arr) <- newByteArray sz+ let loop n+ | n ==# sz = return ()+ | otherwise = do+ w <- getByte bh+ writeByteArray arr n w+ loop (n +# 1#)+ loop 0#+ freezeByteArray arr+ -}++{-+data ByteArray = BA ByteArray#+data MBA = MBA (MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+ case newByteArray# sz s of { (# s, arr #) ->+ (# s, MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+ case unsafeFreezeByteArray# arr s of { (# s, arr #) ->+ (# s, BA arr #) }++writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()+writeByteArray arr i (W8# w) = IO $ \s ->+ case writeWord8Array# arr i w s of { s ->+ (# s, () #) }++indexByteArray :: ByteArray# -> Int# -> Word8+indexByteArray a# n# = W8# (indexWord8Array# a# n#)++-}+instance (Binary a) => Binary (Ratio a) where+ put_ bh (a :% b) = do put_ bh a; put_ bh b+ get bh = do a <- get bh; b <- get bh; return (a :% b)++-- Instance uses fixed-width encoding to allow inserting+-- Bin placeholders in the stream.+instance Binary (Bin a) where+ put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32)+ get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32)))++-- Instance uses fixed-width encoding to allow inserting+-- Bin placeholders in the stream.+instance Binary (RelBinPtr a) where+ put_ bh (RelBinPtr i) = put_ bh i+ get bh = RelBinPtr <$> get bh++-- -----------------------------------------------------------------------------+-- Forward reading/writing++-- | @'forwardPut' put_A put_B@ outputs A after B but allows A to be read before B+-- by using a forward reference.+forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)+forwardPut bh put_A put_B = do+ -- write placeholder pointer to A+ pre_a <- tellBinWriter bh+ put_ bh pre_a++ -- write B+ r_b <- put_B++ -- update A's pointer+ a <- tellBinWriter bh+ putAt bh pre_a a+ seekBinNoExpandWriter bh a++ -- write A+ r_a <- put_A r_b+ pure (r_a,r_b)++forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()+forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B++-- | Read a value stored using a forward reference+--+-- The forward reference is expected to be an absolute offset.+forwardGet :: ReadBinHandle -> IO a -> IO a+forwardGet bh get_A = do+ -- read forward reference+ p <- get bh -- a BinPtr+ -- store current position+ p_a <- tellBinReader bh+ -- go read the forward value, then seek back+ seekBinReader bh p+ r <- get_A+ seekBinReader bh p_a+ pure r++-- | @'forwardPutRel' put_A put_B@ outputs A after B but allows A to be read before B+-- by using a forward reference.+--+-- This forward reference is a relative offset that allows us to skip over the+-- result of 'put_A'.+forwardPutRel :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)+forwardPutRel bh put_A put_B = do+ -- write placeholder pointer to A+ pre_a <- tellBinWriter bh+ put_ bh pre_a++ -- write B+ r_b <- put_B++ -- update A's pointer+ a <- tellBinWriter bh+ putAtRel bh pre_a a+ seekBinNoExpandWriter bh a++ -- write A+ r_a <- put_A r_b+ pure (r_a,r_b)++-- | Like 'forwardGetRel', but discard the result.+forwardPutRel_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()+forwardPutRel_ bh put_A put_B = void $ forwardPutRel bh put_A put_B++-- | Read a value stored using a forward reference.+--+-- The forward reference is expected to be a relative offset.+forwardGetRel :: ReadBinHandle -> IO a -> IO a+forwardGetRel bh get_A = do+ -- read forward reference+ p <- getRelBin bh+ -- store current position+ p_a <- tellBinReader bh+ -- go read the forward value, then seek back+ seekBinReader bh $ makeAbsoluteBin p+ r <- get_A+ seekBinReader bh p_a+ pure r++-- -----------------------------------------------------------------------------+-- Lazy reading/writing++lazyPut :: Binary a => WriteBinHandle -> a -> IO ()+lazyPut = lazyPut' put_++lazyGet :: Binary a => ReadBinHandle -> IO a+lazyGet = lazyGet' get++lazyPut' :: (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()+lazyPut' f bh a = do+ -- output the obj with a ptr to skip over it:+ pre_a <- tellBinWriter bh+ put_ bh pre_a -- save a slot for the ptr+ f bh a -- dump the object+ q <- tellBinWriter bh -- q = ptr to after object+ putAtRel bh pre_a q -- fill in slot before a with ptr to q+ seekBinWriter bh q -- finally carry on writing at q++lazyGet' :: (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a+lazyGet' f bh = do+ p <- getRelBin bh -- a BinPtr+ p_a <- tellBinReader bh+ a <- unsafeInterleaveIO $ do+ -- NB: Use a fresh rbm_off_r variable in the child thread, for thread+ -- safety.+ off_r <- newFastMutInt 0+ let bh' = bh { rbm_off_r = off_r }+ seekBinReader bh' p_a+ f bh'+ seekBinReader bh (makeAbsoluteBin p) -- skip over the object for now+ return a++-- | Serialize the constructor strictly but lazily serialize a value inside a+-- 'Just'.+--+-- This way we can check for the presence of a value without deserializing the+-- value itself.+lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO ()+lazyPutMaybe bh Nothing = putWord8 bh 0+lazyPutMaybe bh (Just x) = do+ putWord8 bh 1+ lazyPut bh x++-- | Deserialize a value serialized by 'lazyPutMaybe'.+lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a)+lazyGetMaybe bh = do+ h <- getWord8 bh+ case h of+ 0 -> pure Nothing+ _ -> Just <$> lazyGet bh++-- -----------------------------------------------------------------------------+-- UserData+-- -----------------------------------------------------------------------------++-- Note [Binary UserData]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- Information we keep around during interface file+-- serialization/deserialization. Namely we keep the functions for serializing+-- and deserializing 'Name's and 'FastString's. We do this because we actually+-- use serialization in two distinct settings,+--+-- * When serializing interface files themselves+--+-- * When computing the fingerprint of an IfaceDecl (which we computing by+-- hashing its Binary serialization)+--+-- These two settings have different needs while serializing Names:+--+-- * Names in interface files are serialized via a symbol table (see Note+-- [Symbol table representation of names] in "GHC.Iface.Binary").+--+-- * During fingerprinting a binding Name is serialized as the OccName and a+-- non-binding Name is serialized as the fingerprint of the thing they+-- represent. See Note [Fingerprinting IfaceDecls] for further discussion.+--++-- | Newtype to serialise binding names differently to non-binding 'Name'.+-- See Note [Binary UserData]+newtype BindingName = BindingName { getBindingName :: Name }+ deriving ( Eq )++simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName+simpleBindingNameWriter = coerce++simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName+simpleBindingNameReader = coerce++-- | Existential for 'BinaryWriter' with a type witness.+data SomeBinaryWriter = forall a . SomeBinaryWriter (Refl.TypeRep a) (BinaryWriter a)++-- | Existential for 'BinaryReader' with a type witness.+data SomeBinaryReader = forall a . SomeBinaryReader (Refl.TypeRep a) (BinaryReader a)++-- | UserData required to serialise symbols for interface files.+--+-- See Note [Binary UserData]+data WriterUserData =+ WriterUserData {+ ud_writer_data :: Map SomeTypeRep SomeBinaryWriter+ -- ^ A mapping from a type witness to the 'Writer' for the associated type.+ -- This is a 'Map' because microbenchmarks indicated this is more efficient+ -- than other representations for less than ten elements.+ --+ -- Considered representations:+ --+ -- * [(TypeRep, SomeBinaryWriter)]+ -- * bytehash (on hackage)+ -- * Map TypeRep SomeBinaryWriter+ }++-- | UserData required to deserialise symbols for interface files.+--+-- See Note [Binary UserData]+data ReaderUserData =+ ReaderUserData {+ ud_reader_data :: Map SomeTypeRep SomeBinaryReader+ -- ^ A mapping from a type witness to the 'Reader' for the associated type.+ -- This is a 'Map' because microbenchmarks indicated this is more efficient+ -- than other representations for less than ten elements.+ --+ -- Considered representations:+ --+ -- * [(TypeRep, SomeBinaryReader)]+ -- * bytehash (on hackage)+ -- * Map TypeRep SomeBinaryReader+ }++mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData+mkWriterUserData caches = noWriterUserData+ { ud_writer_data = Map.fromList $ map (\cache@(SomeBinaryWriter typRep _) -> (SomeTypeRep typRep, cache)) caches+ }++mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData+mkReaderUserData caches = noReaderUserData+ { ud_reader_data = Map.fromList $ map (\cache@(SomeBinaryReader typRep _) -> (SomeTypeRep typRep, cache)) caches+ }++mkSomeBinaryWriter :: forall a . Refl.Typeable a => BinaryWriter a -> SomeBinaryWriter+mkSomeBinaryWriter cb = SomeBinaryWriter (Refl.typeRep @a) cb++mkSomeBinaryReader :: forall a . Refl.Typeable a => BinaryReader a -> SomeBinaryReader+mkSomeBinaryReader cb = SomeBinaryReader (Refl.typeRep @a) cb++newtype BinaryReader s = BinaryReader+ { getEntry :: ReadBinHandle -> IO s+ } deriving (Functor)++newtype BinaryWriter s = BinaryWriter+ { putEntry :: WriteBinHandle -> s -> IO ()+ }++mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s+mkWriter f = BinaryWriter+ { putEntry = f+ }++mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s+mkReader f = BinaryReader+ { getEntry = f+ }++-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'.+--+-- If no 'BinaryReader' has been configured before, this function will panic.+findUserDataReader :: forall a . Refl.Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a+findUserDataReader query bh =+ case Map.lookup (Refl.someTypeRep query) (ud_reader_data $ getReaderUserData bh) of+ Nothing -> panic $ "Failed to find BinaryReader for the key: " ++ show (Refl.someTypeRep query)+ Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->+ unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader+ -- This 'unsafeCoerce' could be written safely like this:+ --+ -- @+ -- Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->+ -- case testEquality (typeRep @a) tyRep of+ -- Just Refl -> coerce @(BinaryReader x) @(BinaryReader a) reader+ -- Nothing -> panic $ "Invariant violated"+ -- @+ --+ -- But it comes at a slight performance cost and this function is used in+ -- binary serialisation hot loops, thus, we prefer the small performance boost over+ -- the additional type safety.++-- | Find the 'BinaryWriter' for the 'Binary' instance for the type identified by 'Proxy a'.+--+-- If no 'BinaryWriter' has been configured before, this function will panic.+findUserDataWriter :: forall a . Refl.Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a+findUserDataWriter query bh =+ case Map.lookup (Refl.someTypeRep query) (ud_writer_data $ getWriterUserData bh) of+ Nothing -> panic $ "Failed to find BinaryWriter for the key: " ++ show (Refl.someTypeRep query)+ Just (SomeBinaryWriter _ (writer :: BinaryWriter x)) ->+ unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) writer+ -- This 'unsafeCoerce' could be written safely like this:+ --+ -- @+ -- Just (SomeBinaryWriter tyRep (writer :: BinaryWriter x)) ->+ -- case testEquality (typeRep @a) tyRep of+ -- Just Refl -> coerce @(BinaryWriter x) @(BinaryWriter a) writer+ -- Nothing -> panic $ "Invariant violated"+ -- @+ --+ -- But it comes at a slight performance cost and this function is used in+ -- binary serialisation hot loops, thus, we prefer the small performance boost over+ -- the additional type safety.+++noReaderUserData :: ReaderUserData+noReaderUserData = ReaderUserData+ { ud_reader_data = Map.empty+ }++noWriterUserData :: WriterUserData+noWriterUserData = WriterUserData+ { ud_writer_data = Map.empty+ }++newReadState :: (ReadBinHandle -> IO Name) -- ^ how to deserialize 'Name's+ -> (ReadBinHandle -> IO FastString)+ -> ReaderUserData+newReadState get_name get_fs =+ mkReaderUserData+ [ mkSomeBinaryReader $ mkReader get_name+ , mkSomeBinaryReader $ mkReader @BindingName (coerce get_name)+ , mkSomeBinaryReader $ mkReader get_fs+ ]++newWriteState :: (WriteBinHandle -> Name -> IO ())+ -- ^ how to serialize non-binding 'Name's+ -> (WriteBinHandle -> Name -> IO ())+ -- ^ how to serialize binding 'Name's+ -> (WriteBinHandle -> FastString -> IO ())+ -> WriterUserData+newWriteState put_non_binding_name put_binding_name put_fs =+ mkWriterUserData+ [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_binding_name bh (getBindingName name))+ , mkSomeBinaryWriter $ mkWriter put_non_binding_name+ , mkSomeBinaryWriter $ mkWriter put_fs+ ]++-- ----------------------------------------------------------------------------+-- Types for lookup and deduplication tables.+-- ----------------------------------------------------------------------------++-- | A 'ReaderTable' describes how to deserialise a table from disk,+-- and how to create a 'BinaryReader' that looks up values in the deduplication table.+data ReaderTable a = ReaderTable+ { getTable :: ReadBinHandle -> IO (SymbolTable a)+ -- ^ Deserialise a list of elements into a 'SymbolTable'.+ , mkReaderFromTable :: SymbolTable a -> BinaryReader a+ -- ^ Given the table from 'getTable', create a 'BinaryReader'+ -- that reads values only from the 'SymbolTable'.+ }++-- | A 'WriterTable' is an interface any deduplication table can implement to+-- describe how the table can be written to disk.+newtype WriterTable = WriterTable+ { putTable :: WriteBinHandle -> IO Int+ -- ^ Serialise a table to disk. Returns the number of written elements.+ }++-- ----------------------------------------------------------------------------+-- Common data structures for constructing and maintaining lookup tables for+-- binary serialisation and deserialisation.+-- ----------------------------------------------------------------------------++-- | The 'GenericSymbolTable' stores a mapping from already seen elements to an index.+-- If an element wasn't seen before, it is added to the mapping together with a fresh+-- index.+--+-- 'GenericSymbolTable' is a variant of a 'BinSymbolTable' that is polymorphic in the table implementation.+-- As such it can be used with any container that implements the 'TrieMap' type class.+--+-- While 'GenericSymbolTable' is similar to the 'BinSymbolTable', it supports storing tree-like+-- structures such as 'Type' and 'IfaceType' more efficiently.+--+data GenericSymbolTable m = GenericSymbolTable+ { gen_symtab_next :: !FastMutInt+ -- ^ The next index to use.+ , gen_symtab_map :: !(IORef (m Int))+ -- ^ Given a symbol, find the symbol and return its index.+ , gen_symtab_to_write :: !(IORef [Key m])+ -- ^ Reversed list of values to write into the buffer.+ -- This is an optimisation, as it allows us to write out quickly all+ -- newly discovered values that are discovered when serialising 'Key m'+ -- to disk.+ }++-- | Initialise a 'GenericSymbolTable', initialising the index to '0'.+initGenericSymbolTable :: TrieMap m => IO (GenericSymbolTable m)+initGenericSymbolTable = do+ symtab_next <- newFastMutInt 0+ symtab_map <- newIORef emptyTM+ symtab_todo <- newIORef []+ pure $ GenericSymbolTable+ { gen_symtab_next = symtab_next+ , gen_symtab_map = symtab_map+ , gen_symtab_to_write = symtab_todo+ }++-- | Serialise the 'GenericSymbolTable' to disk.+--+-- Since 'GenericSymbolTable' stores tree-like structures, such as 'IfaceType',+-- serialising an element can add new elements to the mapping.+-- Thus, 'putGenericSymbolTable' first serialises all values, and then checks whether any+-- new elements have been discovered. If so, repeat the loop.+putGenericSymbolTable :: forall m. (TrieMap m) => GenericSymbolTable m -> (WriteBinHandle -> Key m -> IO ()) -> WriteBinHandle -> IO Int+{-# INLINE putGenericSymbolTable #-}+putGenericSymbolTable gen_sym_tab serialiser bh = do+ putGenericSymbolTable bh+ where+ symtab_next = gen_symtab_next gen_sym_tab+ symtab_to_write = gen_symtab_to_write gen_sym_tab+ putGenericSymbolTable :: WriteBinHandle -> IO Int+ putGenericSymbolTable bh = do+ let loop = do+ vs <- atomicModifyIORef' symtab_to_write (\a -> ([], a))+ case vs of+ [] -> readFastMutInt symtab_next+ todo -> do+ mapM_ (\n -> serialiser bh n) (reverse todo)+ loop+ snd <$>+ (forwardPutRel bh (const $ readFastMutInt symtab_next >>= put_ bh) $+ loop)++-- | Read the elements of a 'GenericSymbolTable' from disk into a 'SymbolTable'.+getGenericSymbolTable :: forall a . (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a)+getGenericSymbolTable deserialiser bh = do+ sz <- forwardGetRel bh (get bh) :: IO Int+ mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)+ forM_ [0..(sz-1)] $ \i -> do+ f <- deserialiser bh+ writeArray mut_arr i f+ unsafeFreeze mut_arr++-- | Write an element 'Key m' to the given 'WriteBinHandle'.+--+-- If the element was seen before, we simply write the index of that element to the+-- 'WriteBinHandle'. If we haven't seen it before, we add the element to+-- the 'GenericSymbolTable', increment the index, and return this new index.+putGenericSymTab :: (TrieMap m) => GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()+{-# INLINE putGenericSymTab #-}+putGenericSymTab GenericSymbolTable{+ gen_symtab_map = symtab_map_ref,+ gen_symtab_next = symtab_next,+ gen_symtab_to_write = symtab_todo }+ bh val = do+ symtab_map <- readIORef symtab_map_ref+ case lookupTM val symtab_map of+ Just off -> put_ bh (fromIntegral off :: Word32)+ Nothing -> do+ off <- readFastMutInt symtab_next+ writeFastMutInt symtab_next (off+1)+ writeIORef symtab_map_ref+ $! insertTM val off symtab_map+ atomicModifyIORef symtab_todo (\todo -> (val : todo, ()))+ put_ bh (fromIntegral off :: Word32)++-- | Read a value from a 'SymbolTable'.+getGenericSymtab :: Binary a => SymbolTable a -> ReadBinHandle -> IO a+getGenericSymtab symtab bh = do+ i :: Word32 <- get bh+ return $! symtab ! fromIntegral i++---------------------------------------------------------+-- The Dictionary+---------------------------------------------------------++-- | A 'SymbolTable' of 'FastString's.+type Dictionary = SymbolTable FastString++initFastStringReaderTable :: IO (ReaderTable FastString)+initFastStringReaderTable = do+ return $+ ReaderTable+ { getTable = getDictionary+ , mkReaderFromTable = \tbl -> mkReader (getDictFastString tbl)+ }++initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString)+initFastStringWriterTable = do+ dict_next_ref <- newFastMutInt 0+ dict_map_ref <- newIORef emptyUFM+ let bin_dict =+ FSTable+ { fs_tab_next = dict_next_ref+ , fs_tab_map = dict_map_ref+ }+ let put_dict bh = do+ fs_count <- readFastMutInt dict_next_ref+ dict_map <- readIORef dict_map_ref+ putDictionary bh fs_count dict_map+ pure fs_count++ return+ ( WriterTable+ { putTable = put_dict+ }+ , mkWriter $ putDictFastString bin_dict+ )++putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()+putDictionary bh sz dict = do+ put_ bh sz+ mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))+ -- It's OK to use nonDetEltsUFM here because the elements have indices+ -- that array uses to create order++getDictionary :: ReadBinHandle -> IO Dictionary+getDictionary bh = do+ sz <- get bh :: IO Int+ mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)+ forM_ [0..(sz-1)] $ \i -> do+ fs <- getFS bh+ writeArray mut_arr i fs+ unsafeFreeze mut_arr++getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString+getDictFastString dict bh = do+ j <- get bh+ return $! (dict ! fromIntegral (j :: Word32))++putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO ()+putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh++allocateFastString :: FSTable -> FastString -> IO Word32+allocateFastString FSTable { fs_tab_next = j_r+ , fs_tab_map = out_r+ } f = do+ out <- readIORef out_r+ let !uniq = getUnique f+ case lookupUFM_Directly out uniq of+ Just (j, _) -> return (fromIntegral j :: Word32)+ Nothing -> do+ j <- readFastMutInt j_r+ writeFastMutInt j_r (j + 1)+ writeIORef out_r $! addToUFM_Directly out uniq (j, f)+ return (fromIntegral j :: Word32)++-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to+-- avoid a collision and copy to avoid a dependency.+data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use+ , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString)))+ -- indexed by FastString+ }+++---------------------------------------------------------+-- The Symbol Table+---------------------------------------------------------++-- | Symbols that are read from disk.+-- The 'SymbolTable' index starts on '0'.+type SymbolTable a = Array Int a++---------------------------------------------------------+-- Reading and writing FastStrings+---------------------------------------------------------++putFS :: WriteBinHandle -> FastString -> IO ()+putFS bh fs = putBS bh $ bytesFS fs++getFS :: ReadBinHandle -> IO FastString+getFS bh = do+ l <- get bh :: IO Int+ getPrim bh l (\src -> pure $! mkFastStringBytes src l )++-- | Put a ByteString without its length (can't be read back without knowing the+-- length!)+putByteString :: WriteBinHandle -> ByteString -> IO ()+putByteString bh bs =+ BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do+ putPrim bh l (\op -> copyBytes op (castPtr ptr) l)++-- | Get a ByteString whose length is known+getByteString :: ReadBinHandle -> Int -> IO ByteString+getByteString bh l =+ BS.create l $ \dest -> do+ getPrim bh l (\src -> copyBytes dest src l)++putBS :: WriteBinHandle -> ByteString -> IO ()+putBS bh bs =+ BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do+ put_ bh l+ putPrim bh l (\op -> copyBytes op (castPtr ptr) l)++getBS :: ReadBinHandle -> IO ByteString+getBS bh = do+ l <- get bh :: IO Int+ BS.create l $ \dest -> do+ getPrim bh l (\src -> copyBytes dest src l)++instance Binary ByteString where+ put_ bh f = putBS bh f+ get bh = getBS bh++instance Binary FastString where+ put_ bh f =+ case findUserDataWriter (Proxy :: Proxy FastString) bh of+ tbl -> putEntry tbl bh f++ get bh =+ case findUserDataReader (Proxy :: Proxy FastString) bh of+ tbl -> getEntry tbl bh++deriving instance Binary NonDetFastString+deriving instance Binary LexicalFastString++instance Binary Fingerprint where+ put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2+ get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)++instance Binary ModuleName where+ put_ bh (ModuleName fs) = put_ bh fs+ get bh = do fs <- get bh; return (ModuleName fs)++-- instance Binary TupleSort where+-- put_ bh BoxedTuple = putByte bh 0+-- put_ bh UnboxedTuple = putByte bh 1+-- put_ bh ConstraintTuple = putByte bh 2+-- get bh = do+-- h <- getByte bh+-- case h of+-- 0 -> do return BoxedTuple+-- 1 -> do return UnboxedTuple+-- _ -> do return ConstraintTuple++-- instance Binary Activation where+-- put_ bh NeverActive = do+-- putByte bh 0+-- put_ bh FinalActive = do+-- putByte bh 1+-- put_ bh AlwaysActive = do+-- putByte bh 2+-- put_ bh (ActiveBefore src aa) = do+-- putByte bh 3+-- put_ bh src+-- put_ bh aa+-- put_ bh (ActiveAfter src ab) = do+-- putByte bh 4+-- put_ bh src+-- put_ bh ab+-- get bh = do+-- h <- getByte bh+-- case h of+-- 0 -> do return NeverActive+-- 1 -> do return FinalActive+-- 2 -> do return AlwaysActive+-- 3 -> do src <- get bh+-- aa <- get bh+-- return (ActiveBefore src aa)+-- _ -> do src <- get bh+-- ab <- get bh+-- return (ActiveAfter src ab)++-- instance Binary InlinePragma where+-- put_ bh (InlinePragma s a b c d) = do+-- put_ bh s+-- put_ bh a+-- put_ bh b+-- put_ bh c+-- put_ bh d++-- get bh = do+-- s <- get bh+-- a <- get bh+-- b <- get bh+-- c <- get bh+-- d <- get bh+-- return (InlinePragma s a b c d)++-- instance Binary RuleMatchInfo where+-- put_ bh FunLike = putByte bh 0+-- put_ bh ConLike = putByte bh 1+-- get bh = do+-- h <- getByte bh+-- if h == 1 then return ConLike+-- else return FunLike++-- instance Binary InlineSpec where+-- put_ bh NoUserInlinePrag = putByte bh 0+-- put_ bh Inline = putByte bh 1+-- put_ bh Inlinable = putByte bh 2+-- put_ bh NoInline = putByte bh 3++-- get bh = do h <- getByte bh+-- case h of+-- 0 -> return NoUserInlinePrag+-- 1 -> return Inline+-- 2 -> return Inlinable+-- _ -> return NoInline++-- instance Binary RecFlag where+-- put_ bh Recursive = do+-- putByte bh 0+-- put_ bh NonRecursive = do+-- putByte bh 1+-- get bh = do+-- h <- getByte bh+-- case h of+-- 0 -> do return Recursive+-- _ -> do return NonRecursive++-- instance Binary OverlapMode where+-- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s+-- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s+-- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s+-- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s+-- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s+-- get bh = do+-- h <- getByte bh+-- case h of+-- 0 -> (get bh) >>= \s -> return $ NoOverlap s+-- 1 -> (get bh) >>= \s -> return $ Overlaps s+-- 2 -> (get bh) >>= \s -> return $ Incoherent s+-- 3 -> (get bh) >>= \s -> return $ Overlapping s+-- 4 -> (get bh) >>= \s -> return $ Overlappable s+-- _ -> panic ("get OverlapMode" ++ show h)+++-- instance Binary OverlapFlag where+-- put_ bh flag = do put_ bh (overlapMode flag)+-- put_ bh (isSafeOverlap flag)+-- get bh = do+-- h <- get bh+-- b <- get bh+-- return OverlapFlag { overlapMode = h, isSafeOverlap = b }++-- instance Binary FixityDirection where+-- put_ bh InfixL = do+-- putByte bh 0+-- put_ bh InfixR = do+-- putByte bh 1+-- put_ bh InfixN = do+-- putByte bh 2+-- get bh = do+-- h <- getByte bh+-- case h of+-- 0 -> do return InfixL+-- 1 -> do return InfixR+-- _ -> do return InfixN++-- instance Binary Fixity where+-- put_ bh (Fixity src aa ab) = do+-- put_ bh src+-- put_ bh aa+-- put_ bh ab+-- get bh = do+-- src <- get bh+-- aa <- get bh+-- ab <- get bh+-- return (Fixity src aa ab)++-- instance Binary WarningTxt where+-- put_ bh (WarningTxt s w) = do+-- putByte bh 0+-- put_ bh s+-- put_ bh w+-- put_ bh (DeprecatedTxt s d) = do+-- putByte bh 1+-- put_ bh s+-- put_ bh d++-- get bh = do+-- h <- getByte bh+-- case h of+-- 0 -> do s <- get bh+-- w <- get bh+-- return (WarningTxt s w)+-- _ -> do s <- get bh+-- d <- get bh+-- return (DeprecatedTxt s d)++-- instance Binary StringLiteral where+-- put_ bh (StringLiteral st fs _) = do+-- put_ bh st+-- put_ bh fs+-- get bh = do+-- st <- get bh+-- fs <- get bh+-- return (StringLiteral st fs Nothing)++newtype BinLocated a = BinLocated { unBinLocated :: Located a }++instance Binary a => Binary (BinLocated a) where+ put_ bh (BinLocated (L l x)) = do+ put_ bh $ BinSrcSpan l+ put_ bh x++ get bh = do+ l <- unBinSrcSpan <$> get bh+ x <- get bh+ return $ BinLocated (L l x)++newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan }++-- See Note [Source Location Wrappers]+instance Binary BinSpan where+ put_ bh (BinSpan ss) = do+ put_ bh (srcSpanFile ss)+ put_ bh (srcSpanStartLine ss)+ put_ bh (srcSpanStartCol ss)+ put_ bh (srcSpanEndLine ss)+ put_ bh (srcSpanEndCol ss)++ get bh = do+ f <- get bh+ sl <- get bh+ sc <- get bh+ el <- get bh+ ec <- get bh+ return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc)+ (mkRealSrcLoc f el ec))++instance Binary UnhelpfulSpanReason where+ put_ bh r = case r of+ UnhelpfulNoLocationInfo -> putByte bh 0+ UnhelpfulWiredIn -> putByte bh 1+ UnhelpfulInteractive -> putByte bh 2+ UnhelpfulGenerated -> putByte bh 3+ UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs++ get bh = do+ h <- getByte bh+ case h of+ 0 -> return UnhelpfulNoLocationInfo+ 1 -> return UnhelpfulWiredIn+ 2 -> return UnhelpfulInteractive+ 3 -> return UnhelpfulGenerated+ _ -> UnhelpfulOther <$> get bh++newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan }++-- See Note [Source Location Wrappers]+instance Binary BinSrcSpan where+ put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do+ putByte bh 0+ -- BufSpan doesn't ever get serialised because the positions depend+ -- on build location.+ put_ bh $ BinSpan ss++ put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do+ putByte bh 1+ put_ bh s++ get bh = do+ h <- getByte bh+ case h of+ 0 -> do BinSpan ss <- get bh+ return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing)+ _ -> do s <- get bh+ return $ BinSrcSpan (UnhelpfulSpan s)+++{-+Note [Source Location Wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Source locations are banned from interface files, to+prevent filepaths affecting interface hashes.++Unfortunately, we can't remove all binary instances,+as they're used to serialise .hie files, and we don't+want to break binary compatibility.++To this end, the Bin[Src]Span newtypes wrappers were+introduced to prevent accidentally serialising a+source location as part of a larger structure.+-}++--------------------------------------------------------------------------------+-- Instances for the containers package+--------------------------------------------------------------------------------++instance (Binary v) => Binary (IntMap v) where+ put_ bh m = put_ bh (IntMap.toList m)+ get bh = IntMap.fromList <$> get bh
+ src/GHC/Iface/Ext/Compat.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}+module GHC.Iface.Ext.Compat where++#if !MIN_VERSION_ghc(9,12,1)+mkIfLclName :: a -> a+mkIfLclName = id+#endif
+ src/GHC/Iface/Ext/Debug.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -w #-}++{-+Functions to validate and check .hie file ASTs generated by GHC.+-}++module GHC.Iface.Ext.Debug where++import GHC.Prelude++import GHC.Types.SrcLoc+import GHC.Unit.Module+import GHC.Utils.Outputable++import GHC.Iface.Ext.Types+import GHC.Iface.Ext.Utils+import GHC.Types.Name++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Function ( on )+import Data.List ( sortOn )++type Diff a = a -> a -> [SDoc]++diffFile :: Diff HieFile+diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)++diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map HiePath (HieAST a))+diffAsts f = diffList (diffAst f) `on` M.elems++diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)+diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =+ infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2+ where+ spanDiff+ | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]+ | otherwise = []+ infoDiff' i1 i2+ = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2+ ++ (diffList diffType `on` nodeType) i1 i2+ ++ (diffIdents `on` nodeIdentifiers) i1 i2+ sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo)+ infoDiff = case sinfoDiff info1 info2 of+ [] -> []+ xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1)+ , "and", ppr (sourcedNodeIdents info2,span2)+ , "While comparing"+ , ppr (normalizeIdents $ sourcedNodeIdents info1), "and"+ , ppr (normalizeIdents $ sourcedNodeIdents info2)+ ]+ ]++ diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b+ diffIdent (a,b) (c,d) = diffName a c+ ++ eqDiff b d+ diffName (Right a) (Right b) = case (a,b) of+ (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')+ (LocalName o _, ExternalName _ o' _) -> eqDiff o o'+ _ -> eqDiff a b+ diffName a b = eqDiff a b++type DiffIdent = Either ModuleName HieName++normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]+normalizeIdents = sortOn go . map (first toHieName) . M.toList+ where+ first f (a,b) = (fmap f a, b)+ go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)++diffList :: Diff a -> Diff [a]+diffList f xs ys+ | length xs == length ys = concat $ zipWith f xs ys+ | otherwise = ["length of lists doesn't match"]++eqDiff :: (Outputable a, Eq a) => Diff a+eqDiff a b+ | a == b = []+ | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]++validAst :: HieAST a -> Either SDoc ()+validAst (Node _ span children) = do+ checkContainment children+ checkSorted children+ mapM_ validAst children+ where+ checkSorted [] = return ()+ checkSorted [_] = return ()+ checkSorted (x:y:xs)+ | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)+ | otherwise = Left $ hsep+ [ ppr $ nodeSpan x+ , "is not to the left of"+ , ppr $ nodeSpan y+ ]+ checkContainment [] = return ()+ checkContainment (x:xs)+ | span `containsSpan` (nodeSpan x) = checkContainment xs+ | otherwise = Left $ hsep+ [ ppr $ span+ , "does not contain"+ , ppr $ nodeSpan x+ ]++-- | Look for any identifiers which occur outside of their supposed scopes.+-- Returns a list of error messages.+validateScopes :: Module -> M.Map HiePath (HieAST a) -> [SDoc]+validateScopes mod asts = validScopes ++ validEvs+ where+ refMap = generateReferencesMap asts+ -- We use a refmap for most of the computation++ evs = M.keys+ $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap++ validEvs = do+ i@(Right ev) <- evs+ case M.lookup i refMap of+ Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ]+ Just refs+ | nameIsLocalOrFrom mod ev+ , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs)+ -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"]+ | otherwise -> []++ -- Check if all the names occur in their calculated scopes+ validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap+ valid (Left _) _ = []+ valid (Right n) refs = concatMap inScope refs+ where+ mapRef = foldMap getScopeFromContext . identInfo . snd+ scopes = case foldMap mapRef refs of+ Just xs -> xs+ Nothing -> []+ inScope (sp, dets)+ | (definedInAsts asts n || (any isEvidenceContext (identInfo dets)))+ && any isOccurrence (identInfo dets)+ -- We validate scopes for names which are defined locally, and occur+ -- in this span, or are evidence variables+ = case scopes of+ [] | nameIsLocalOrFrom mod n+ , ( not (isDerivedOccName $ nameOccName n)+ || any isEvidenceContext (identInfo dets))+ -- If we don't get any scopes for a local name or+ -- an evidence variable, then its an error.+ -- We can ignore other kinds of derived names as+ -- long as we take evidence vars into account+ -> return $ hsep $+ [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp+ , "Doesn't have a calculated scope: ", ppr scopes]+ | otherwise -> []+ _ -> if any (`scopeContainsSpan` sp) scopes+ then []+ else return $ hsep $+ [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp+ , "doesn't occur in calculated scope", ppr scopes]+ | otherwise = []
+ src/GHC/Iface/Ext/Types.hs view
@@ -0,0 +1,865 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -w #-}++{-+Types for the .hie file format are defined here.++For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files+-}++module GHC.Iface.Ext.Types where++import GHC.Prelude++import GHC.Settings.Config+import GHC.Iface.Ext.Binary.Utils+import GHC.Iface.Ext.Binary.Instances ()+import GHC.Data.FastString+import GHC.Builtin.Utils+import GHC.Iface.Type+import GHC.Unit.Module ( ModuleName, Module )+import GHC.Types.Name+import GHC.Utils.Outputable hiding ( (<>) )+import GHC.Types.SrcLoc+import GHC.Types.Avail+import GHC.Types.Unique+import qualified GHC.Utils.Outputable as O ( (<>) )+import GHC.Utils.Panic+import GHC.Core.ConLike ( ConLike(..) )+import GHC.Core.TyCo.Rep ( Type(..) )+import GHC.Core.Type ( coreFullView, isFunTy, Var (..) )+import GHC.Core.TyCon ( isTypeSynonymTyCon, isClassTyCon, isFamilyTyCon )+import GHC.Types.Id ( Id, isRecordSelector, isClassOpId )+import GHC.Types.TyThing ( TyThing (..) )+import GHC.Types.Var ( isTyVar, isFUNArg )++import qualified Data.Array as A+import qualified Data.Map as M+import qualified Data.Set as S+import Data.ByteString ( ByteString )+import Data.Data ( Data )+import Data.Semigroup ( Semigroup(..) )+import Data.Word ( Word8 )+import Control.Applicative ( (<|>) )+import Data.Coerce ( coerce )+import Data.Function ( on )+import qualified Data.Semigroup as S++type Span = RealSrcSpan++{- |+GHC builds up a wealth of information about Haskell source as it compiles it.+@.hie@ files are a way of persisting some of this information to disk so that+external tools that need to work with haskell source don't need to parse,+typecheck, and rename all over again. These files contain:++ * a simplified AST++ * nodes are annotated with source positions and types+ * identifiers are annotated with scope information++ * the raw bytes of the initial Haskell source++Besides saving compilation cycles, @.hie@ files also offer a more stable+interface than the GHC API.+-}+data HieFile = HieFile+ { hie_hs_file :: FilePath+ -- ^ Initial Haskell source file path++ , hie_module :: Module+ -- ^ The module this HIE file is for++ , hie_types :: A.Array TypeIndex HieTypeFlat+ -- ^ Types referenced in the 'hie_asts'.+ --+ -- See Note [Efficient serialization of redundant type info]++ , hie_asts :: HieASTs TypeIndex+ -- ^ Type-annotated abstract syntax trees++ , hie_exports :: [AvailInfo]+ -- ^ The names that this module exports++ , hie_hs_src :: ByteString+ -- ^ Raw bytes of the initial Haskell source++ , hie_entity_infos :: NameEntityInfo+ -- ^ Entity information for each `Name` in the `hie_asts`+ }++type NameEntityInfo = M.Map Name (S.Set EntityInfo)++instance Binary NameEntityInfo where+ put_ bh m = put_ bh $ M.toList m+ get bh = fmap M.fromList (get bh)+++{-+Note [Efficient serialization of redundant type info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The type information in .hie files is highly repetitive and redundant. For+example, consider the expression++ const True 'a'++There is a lot of shared structure between the types of subterms:++ * const True 'a' :: Bool+ * const True :: Char -> Bool+ * const :: Bool -> Char -> Bool++Since all 3 of these types need to be stored in the .hie file, it is worth+making an effort to deduplicate this shared structure. The trick is to define+a new data type that is a flattened version of 'Type':++ data HieType a = HAppTy a a -- data Type = AppTy Type Type+ | HFunTy a a -- | FunTy Type Type+ | ...++ type TypeIndex = Int++Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',+where the 'TypeIndex's in the 'HieType' are references to other elements of the+array. Types recovered from GHC are deduplicated and stored in this compressed+form with sharing of subtrees.+-}++type TypeIndex = Int++-- | A flattened version of 'Type'.+--+-- See Note [Efficient serialization of redundant type info]+data HieType a+ = HTyVarTy Name+ | HAppTy a (HieArgs a)+ | HTyConApp IfaceTyCon (HieArgs a)+ | HForAllTy ((Name, a),ForAllTyFlag) a+ | HFunTy a a a+ | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')+ | HLitTy IfaceTyLit+ | HCastTy a+ | HCoercionTy+ deriving (Functor, Foldable, Traversable, Eq)++type HieTypeFlat = HieType TypeIndex++-- | Roughly isomorphic to the original core 'Type'.+newtype HieTypeFix = Roll (HieType (HieTypeFix))+ deriving Eq++instance Binary (HieType TypeIndex) where+ put_ bh (HTyVarTy n) = do+ putByte bh 0+ put_ bh n+ put_ bh (HAppTy a b) = do+ putByte bh 1+ put_ bh a+ put_ bh b+ put_ bh (HTyConApp n xs) = do+ putByte bh 2+ put_ bh n+ put_ bh xs+ put_ bh (HForAllTy bndr a) = do+ putByte bh 3+ put_ bh bndr+ put_ bh a+ put_ bh (HFunTy w a b) = do+ putByte bh 4+ put_ bh w+ put_ bh a+ put_ bh b+ put_ bh (HQualTy a b) = do+ putByte bh 5+ put_ bh a+ put_ bh b+ put_ bh (HLitTy l) = do+ putByte bh 6+ put_ bh l+ put_ bh (HCastTy a) = do+ putByte bh 7+ put_ bh a+ put_ bh (HCoercionTy) = putByte bh 8++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> HTyVarTy <$> get bh+ 1 -> HAppTy <$> get bh <*> get bh+ 2 -> HTyConApp <$> get bh <*> get bh+ 3 -> HForAllTy <$> get bh <*> get bh+ 4 -> HFunTy <$> get bh <*> get bh <*> get bh+ 5 -> HQualTy <$> get bh <*> get bh+ 6 -> HLitTy <$> get bh+ 7 -> HCastTy <$> get bh+ 8 -> return HCoercionTy+ _ -> panic "Binary (HieArgs Int): invalid tag"+++-- | A list of type arguments along with their respective visibilities (ie. is+-- this an argument that would return 'True' for 'isVisibleForAllTyFlag'?).+newtype HieArgs a = HieArgs [(Bool,a)]+ deriving (Functor, Foldable, Traversable, Eq, Show)++instance Binary (HieArgs TypeIndex) where+ put_ bh (HieArgs xs) = put_ bh xs+ get bh = HieArgs <$> get bh+++-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid+-- non-determinism when printing or storing HieASTs which are sorted by their+-- HiePath.+type HiePath = LexicalFastString++{-# COMPLETE HiePath #-}+pattern HiePath :: FastString -> HiePath+pattern HiePath fs = LexicalFastString fs++-- | Mapping from filepaths to the corresponding AST+newtype HieASTs a = HieASTs { getAsts :: M.Map HiePath (HieAST a) }+ deriving (Functor, Foldable, Traversable, Eq)++instance Binary (HieASTs TypeIndex) where+ put_ bh asts = put_ bh $ M.toAscList $ getAsts asts+ get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)++instance Outputable a => Outputable (HieASTs a) where+ ppr (HieASTs asts) = M.foldrWithKey go "" asts+ where+ go k a rest = vcat $+ [ "File: " O.<> ppr k+ , ppr a+ , rest+ ]++data HieAST a =+ Node+ { sourcedNodeInfo :: SourcedNodeInfo a+ , nodeSpan :: Span+ , nodeChildren :: [HieAST a]+ } deriving (Functor, Foldable, Traversable, Eq)++instance Binary (HieAST TypeIndex) where+ put_ bh ast = do+ put_ bh $ sourcedNodeInfo ast+ put_ bh $ BinSpan $ nodeSpan ast+ put_ bh $ nodeChildren ast++ get bh = Node+ <$> get bh+ <*> (unBinSpan <$> get bh)+ <*> get bh++instance Outputable a => Outputable (HieAST a) where+ ppr (Node ni sp ch) = hang header 2 rest+ where+ header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni+ rest = vcat (map ppr ch)+++-- | NodeInfos grouped by source+newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) }+ deriving (Functor, Foldable, Traversable, Eq)++instance Binary (SourcedNodeInfo TypeIndex) where+ put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts+ get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh)++instance Outputable a => Outputable (SourcedNodeInfo a) where+ ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts+ where+ go k a rest = vcat $+ [ "Source: " O.<> ppr k+ , ppr a+ , rest+ ]++-- | Source of node info+data NodeOrigin+ = SourceInfo+ | GeneratedInfo+ deriving (Eq, Enum, Ord)++instance Outputable NodeOrigin where+ ppr SourceInfo = text "From source"+ ppr GeneratedInfo = text "generated by ghc"++instance Binary NodeOrigin where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))++-- | A node annotation+data NodeAnnotation = NodeAnnotation+ { nodeAnnotConstr :: !FastString -- ^ name of the AST node constructor+ , nodeAnnotType :: !FastString -- ^ name of the AST node Type+ }+ deriving (Eq)++instance Ord NodeAnnotation where+ compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1)+ = mconcat [lexicalCompareFS c0 c1, lexicalCompareFS t0 t1]++instance Outputable NodeAnnotation where+ ppr (NodeAnnotation c t) = ppr (c,t)++instance Binary NodeAnnotation where+ put_ bh (NodeAnnotation c t) = do+ put_ bh c+ put_ bh t+ get bh = NodeAnnotation+ <$> get bh+ <*> get bh++-- | The information stored in one AST node.+--+-- The type parameter exists to provide flexibility in representation of types+-- (see Note [Efficient serialization of redundant type info]).+data NodeInfo a = NodeInfo+ { nodeAnnotations :: S.Set NodeAnnotation+ -- ^ Annotations++ , nodeType :: [a]+ -- ^ The Haskell types of this node, if any.++ , nodeIdentifiers :: NodeIdentifiers a+ -- ^ All the identifiers and their details+ } deriving (Functor, Foldable, Traversable, Eq)++instance Binary (NodeInfo TypeIndex) where+ put_ bh ni = do+ put_ bh $ S.toAscList $ nodeAnnotations ni+ put_ bh $ nodeType ni+ put_ bh $ M.toList $ nodeIdentifiers ni+ get bh = NodeInfo+ <$> fmap (S.fromDistinctAscList) (get bh)+ <*> get bh+ <*> fmap (M.fromList) (get bh)++instance Outputable a => Outputable (NodeInfo a) where+ ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", "+ [ parens (text "annotations:" <+> ppr anns)+ , parens (text "types:" <+> ppr typs)+ , parens (text "identifier info:" <+> pprNodeIdents idents)+ ]++pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc+pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni+ where+ go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id]++pprIdentifier :: Identifier -> SDoc+pprIdentifier (Left mod) = text "module" <+> ppr mod+pprIdentifier (Right name) = text "name" <+> ppr name++type Identifier = Either ModuleName Name++type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)++-- | Information associated with every identifier+--+-- We need to include types with identifiers because sometimes multiple+-- identifiers occur in the same span(Overloaded Record Fields and so on)+data IdentifierDetails a = IdentifierDetails+ { identType :: Maybe a+ , identInfo :: S.Set ContextInfo+ } deriving (Eq, Functor, Foldable, Traversable)++instance Outputable a => Outputable (IdentifierDetails a) where+ ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x)++instance Semigroup (IdentifierDetails a) where+ d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)+ (S.union (identInfo d1) (identInfo d2))++instance Monoid (IdentifierDetails a) where+ mempty = IdentifierDetails Nothing S.empty++instance Binary (IdentifierDetails TypeIndex) where+ put_ bh dets = do+ put_ bh $ identType dets+ put_ bh $ S.toList $ identInfo dets+ get bh = IdentifierDetails+ <$> get bh+ <*> fmap S.fromDistinctAscList (get bh)+++-- | Different contexts under which identifiers exist+data ContextInfo+ = Use -- ^ regular variable+ | MatchBind+ | IEThing IEType -- ^ import/export+ | TyDecl++ -- | Value binding+ | ValBind+ BindType -- ^ whether or not the binding is in an instance+ Scope -- ^ scope over which the value is bound+ (Maybe Span) -- ^ span of entire binding++ -- | Pattern binding+ --+ -- This case is tricky because the bound identifier can be used in two+ -- distinct scopes. Consider the following example (with @-XViewPatterns@)+ --+ -- @+ -- do (b, a, (a -> True)) <- bar+ -- foo a+ -- @+ --+ -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and+ -- in the rest of the @do@-block in @foo a@.+ | PatternBind+ Scope -- ^ scope /in the pattern/ (the variable bound can be used+ -- further in the pattern)+ Scope -- ^ rest of the scope outside the pattern+ (Maybe Span) -- ^ span of entire binding++ | ClassTyDecl (Maybe Span)++ -- | Declaration+ | Decl+ DeclType -- ^ type of declaration+ (Maybe Span) -- ^ span of entire binding++ -- | Type variable+ | TyVarBind Scope TyVarScope++ -- | Record field+ | RecField RecFieldContext (Maybe Span)+ -- | Constraint/Dictionary evidence variable binding+ | EvidenceVarBind+ EvVarSource -- ^ how did this bind come into being+ Scope -- ^ scope over which the value is bound+ (Maybe Span) -- ^ span of the binding site++ -- | Usage of evidence variable+ | EvidenceVarUse+ deriving (Eq, Ord)++instance Outputable ContextInfo where+ ppr (Use) = text "usage"+ ppr (MatchBind) = text "LHS of a match group"+ ppr (IEThing x) = ppr x+ ppr (TyDecl) = text "bound in a type signature declaration"+ ppr (ValBind t sc sp) =+ ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp+ ppr (PatternBind sc1 sc2 sp) =+ text "bound in a pattern with scope:"+ <+> ppr sc1 <+> "," <+> ppr sc2+ <+> pprBindSpan sp+ ppr (ClassTyDecl sp) =+ text "bound in a class type declaration" <+> pprBindSpan sp+ ppr (Decl d sp) =+ text "declaration of" <+> ppr d <+> pprBindSpan sp+ ppr (TyVarBind sc1 sc2) =+ text "type variable binding with scope:"+ <+> ppr sc1 <+> "," <+> ppr sc2+ ppr (RecField ctx sp) =+ text "record field" <+> ppr ctx <+> pprBindSpan sp+ ppr (EvidenceVarBind ctx sc sp) =+ text "evidence variable" <+> ppr ctx+ $$ "with scope:" <+> ppr sc+ $$ pprBindSpan sp+ ppr (EvidenceVarUse) =+ text "usage of evidence variable"++pprBindSpan :: Maybe Span -> SDoc+pprBindSpan Nothing = text ""+pprBindSpan (Just sp) = text "bound at:" <+> ppr sp++instance Binary ContextInfo where+ put_ bh Use = putByte bh 0+ put_ bh (IEThing t) = do+ putByte bh 1+ put_ bh t+ put_ bh TyDecl = putByte bh 2+ put_ bh (ValBind bt sc msp) = do+ putByte bh 3+ put_ bh bt+ put_ bh sc+ put_ bh $ BinSpan <$> msp+ put_ bh (PatternBind a b c) = do+ putByte bh 4+ put_ bh a+ put_ bh b+ put_ bh $ BinSpan <$> c+ put_ bh (ClassTyDecl sp) = do+ putByte bh 5+ put_ bh $ BinSpan <$> sp+ put_ bh (Decl a b) = do+ putByte bh 6+ put_ bh a+ put_ bh $ BinSpan <$> b+ put_ bh (TyVarBind a b) = do+ putByte bh 7+ put_ bh a+ put_ bh b+ put_ bh (RecField a b) = do+ putByte bh 8+ put_ bh a+ put_ bh $ BinSpan <$> b+ put_ bh MatchBind = putByte bh 9+ put_ bh (EvidenceVarBind a b c) = do+ putByte bh 10+ put_ bh a+ put_ bh b+ put_ bh $ BinSpan <$> c+ put_ bh EvidenceVarUse = putByte bh 11++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> return Use+ 1 -> IEThing <$> get bh+ 2 -> return TyDecl+ 3 -> ValBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)+ 4 -> PatternBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)+ 5 -> ClassTyDecl <$> (fmap unBinSpan <$> get bh)+ 6 -> Decl <$> get bh <*> (fmap unBinSpan <$> get bh)+ 7 -> TyVarBind <$> get bh <*> get bh+ 8 -> RecField <$> get bh <*> (fmap unBinSpan <$> get bh)+ 9 -> return MatchBind+ 10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)+ 11 -> return EvidenceVarUse+ _ -> panic "Binary ContextInfo: invalid tag"++data EvVarSource+ = EvPatternBind -- ^ bound by a pattern match+ | EvSigBind -- ^ bound by a type signature+ | EvWrapperBind -- ^ bound by a hswrapper+ | EvImplicitBind -- ^ bound by an implicit variable+ | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class+ | EvLetBind EvBindDeps -- ^ A direct let binding+ deriving (Eq,Ord)++instance Binary EvVarSource where+ put_ bh EvPatternBind = putByte bh 0+ put_ bh EvSigBind = putByte bh 1+ put_ bh EvWrapperBind = putByte bh 2+ put_ bh EvImplicitBind = putByte bh 3+ put_ bh (EvInstBind b cls) = do+ putByte bh 4+ put_ bh b+ put_ bh cls+ put_ bh (EvLetBind deps) = do+ putByte bh 5+ put_ bh deps++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> pure EvPatternBind+ 1 -> pure EvSigBind+ 2 -> pure EvWrapperBind+ 3 -> pure EvImplicitBind+ 4 -> EvInstBind <$> get bh <*> get bh+ 5 -> EvLetBind <$> get bh+ _ -> panic "Binary EvVarSource: invalid tag"++instance Outputable EvVarSource where+ ppr EvPatternBind = text "bound by a pattern"+ ppr EvSigBind = text "bound by a type signature"+ ppr EvWrapperBind = text "bound by a HsWrapper"+ ppr EvImplicitBind = text "bound by an implicit variable binding"+ ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls+ ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls+ ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps++-- | Eq/Ord instances compare on the converted HieName,+-- as non-exported names may have different uniques after+-- a roundtrip+newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }+ deriving Outputable++instance Eq EvBindDeps where+ (==) = coerce ((==) `on` map toHieName)++instance Ord EvBindDeps where+ compare = coerce (compare `on` map toHieName)++instance Binary EvBindDeps where+ put_ bh (EvBindDeps xs) = put_ bh xs+ get bh = EvBindDeps <$> get bh+++-- | Types of imports and exports+data IEType+ = Import+ | ImportAs+ | ImportHiding+ | Export+ deriving (Eq, Enum, Ord)++instance Outputable IEType where+ ppr Import = text "import"+ ppr ImportAs = text "import as"+ ppr ImportHiding = text "import hiding"+ ppr Export = text "export"++instance Binary IEType where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data RecFieldContext+ = RecFieldDecl+ | RecFieldAssign+ | RecFieldMatch+ | RecFieldOcc+ deriving (Eq, Enum, Ord)++instance Outputable RecFieldContext where+ ppr RecFieldDecl = text "declaration"+ ppr RecFieldAssign = text "assignment"+ ppr RecFieldMatch = text "pattern match"+ ppr RecFieldOcc = text "occurrence"++instance Binary RecFieldContext where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data BindType+ = RegularBind+ | InstanceBind+ deriving (Eq, Ord, Enum)++instance Outputable BindType where+ ppr RegularBind = "regular"+ ppr InstanceBind = "instance"++instance Binary BindType where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))++data DeclType+ = FamDec -- ^ type or data family+ | SynDec -- ^ type synonym+ | DataDec -- ^ data declaration+ | ConDec -- ^ constructor declaration+ | PatSynDec -- ^ pattern synonym+ | ClassDec -- ^ class declaration+ | InstDec -- ^ instance declaration+ deriving (Eq, Ord, Enum)++instance Outputable DeclType where+ ppr FamDec = text "type or data family"+ ppr SynDec = text "type synonym"+ ppr DataDec = text "data"+ ppr ConDec = text "constructor"+ ppr PatSynDec = text "pattern synonym"+ ppr ClassDec = text "class"+ ppr InstDec = text "instance"++instance Binary DeclType where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))++data Scope+ = NoScope+ | LocalScope Span+ | ModuleScope+ deriving (Eq, Ord, Data)++instance Outputable Scope where+ ppr NoScope = text "NoScope"+ ppr (LocalScope sp) = text "LocalScope" <+> ppr sp+ ppr ModuleScope = text "ModuleScope"++instance Binary Scope where+ put_ bh NoScope = putByte bh 0+ put_ bh (LocalScope span) = do+ putByte bh 1+ put_ bh $ BinSpan span+ put_ bh ModuleScope = putByte bh 2++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> return NoScope+ 1 -> LocalScope . unBinSpan <$> get bh+ 2 -> return ModuleScope+ _ -> panic "Binary Scope: invalid tag"+++-- | Scope of a type variable.+--+-- This warrants a data type apart from 'Scope' because of complexities+-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For+-- example, consider:+--+-- @+-- foo, bar, baz :: forall a. a -> a+-- @+--+-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we+-- need a list of scopes to keep track of this. Furthermore, this list cannot be+-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.+--+-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@+-- which later gets resolved into a 'ResolvedScopes'.+data TyVarScope+ = ResolvedScopes [Scope]++ -- | Unresolved scopes should never show up in the final @.hie@ file+ | UnresolvedScope+ [Name] -- ^ names of the definitions over which the scope spans+ (Maybe Span) -- ^ the location of the instance/class declaration for+ -- the case where the type variable is declared in a+ -- method type signature+ deriving (Eq, Ord)++instance Outputable TyVarScope where+ ppr (ResolvedScopes xs) =+ text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs)+ ppr (UnresolvedScope ns sp) =+ text "unresolved type variable scope for name" O.<> plural ns+ <+> pprBindSpan sp++instance Binary TyVarScope where+ put_ bh (ResolvedScopes xs) = do+ putByte bh 0+ put_ bh xs+ put_ bh (UnresolvedScope ns span) = do+ putByte bh 1+ put_ bh ns+ put_ bh (BinSpan <$> span)++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> ResolvedScopes <$> get bh+ 1 -> UnresolvedScope <$> get bh <*> (fmap unBinSpan <$> get bh)+ _ -> panic "Binary TyVarScope: invalid tag"++-- | `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 (Eq)++instance Ord HieName where+ compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) S.<> leftmost_smallest c f+ -- TODO (int-index): Perhaps use RealSrcSpan in HieName?+ compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d+ -- TODO (int-index): Perhaps use RealSrcSpan in HieName?+ compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b+ -- Not actually non deterministic as it is a KnownKey+ compare ExternalName{} _ = LT+ compare LocalName{} ExternalName{} = GT+ compare LocalName{} _ = LT+ compare KnownKeyName{} _ = GT++instance Outputable HieName where+ ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp+ ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp+ ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u++hieNameOcc :: HieName -> OccName+hieNameOcc (ExternalName _ occ _) = occ+hieNameOcc (LocalName occ _) = occ+hieNameOcc (KnownKeyName u) =+ case lookupKnownKeyName u of+ Just n -> nameOccName n+ Nothing -> pprPanic "hieNameOcc:unknown known-key unique"+ (ppr u)++toHieName :: Name -> HieName+toHieName name+ | isKnownKeyName name = KnownKeyName (nameUnique name)+ | isExternalName name = ExternalName (nameModule name)+ (nameOccName name)+ (removeBufSpan $ nameSrcSpan name)+ | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)+++{- Note [Capture Entity Information]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to capture the entity information for the identifier in HieAst, so that+language tools and protocols can take advantage making use of it.++Capture `EntityInfo` for a `Name` or `Id` in `renamedSource` or `typecheckedSource`+if it is a name, we ask the env for the `TyThing` then compute the `EntityInfo` from tyThing+if it is an Id, we compute the `EntityInfo` directly from Id++see issue #24544 for more details+-}+++-- | Entity information+-- `EntityInfo` is a simplified version of `TyThing` and richer version than `Namespace` in `OccName`.+-- It state the kind of the entity, such as `Variable`, `TypeVariable`, `DataConstructor`, etc..+data EntityInfo+ = EntityVariable+ | EntityFunction+ | EntityDataConstructor+ | EntityTypeVariable+ | EntityClassMethod+ | EntityPatternSynonym+ | EntityTypeConstructor+ | EntityTypeClass+ | EntityTypeSynonym+ | EntityTypeFamily+ | EntityRecordField+ deriving (Eq, Ord, Enum, Show)+++instance Outputable EntityInfo where+ ppr EntityVariable = text "variable"+ ppr EntityFunction = text "function"+ ppr EntityDataConstructor = text "data constructor"+ ppr EntityTypeVariable = text "type variable"+ ppr EntityClassMethod = text "class method"+ ppr EntityPatternSynonym = text "pattern synonym"+ ppr EntityTypeConstructor = text "type constructor"+ ppr EntityTypeClass = text "type class"+ ppr EntityTypeSynonym = text "type synonym"+ ppr EntityTypeFamily = text "type family"+ ppr EntityRecordField = text "record field"+++instance Binary EntityInfo where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! toEnum (fromIntegral x)+++-- | Get the `EntityInfo` for an `Id`+idEntityInfo :: Id -> S.Set EntityInfo+idEntityInfo vid = S.fromList $ [EntityTypeVariable | isTyVar vid] <> [EntityFunction | isFunType $ varType vid]+ <> [EntityRecordField | isRecordSelector vid] <> [EntityClassMethod | isClassOpId vid] <> [EntityVariable]+ where+ isFunType a = case coreFullView a of+ ForAllTy _ t -> isFunType t+ FunTy { ft_af = flg, ft_res = rhs } -> isFUNArg flg || isFunType rhs+ _x -> isFunTy a++-- | Get the `EntityInfo` for a `TyThing`+tyThingEntityInfo :: TyThing -> S.Set EntityInfo+tyThingEntityInfo ty = case ty of+ AnId vid -> idEntityInfo vid+ AConLike con -> case con of+ RealDataCon _ -> S.singleton EntityDataConstructor+ PatSynCon _ -> S.singleton EntityPatternSynonym+ ATyCon tyCon -> S.fromList $ [EntityTypeSynonym | isTypeSynonymTyCon tyCon] <> [EntityTypeFamily | isFamilyTyCon tyCon]+ <> [EntityTypeClass | isClassTyCon tyCon] <> [EntityTypeConstructor]+ ACoAxiom _ -> S.empty++nameEntityInfo :: Name -> S.Set EntityInfo+nameEntityInfo name+ | isTyVarName name = S.fromList [EntityVariable, EntityTypeVariable]+ | isDataConName name = S.singleton EntityDataConstructor+ | isTcClsNameSpace (occNameSpace $ occName name) = S.singleton EntityTypeConstructor+ | isFieldName name = S.fromList [EntityVariable, EntityRecordField]+ | isVarName name = S.fromList [EntityVariable]+ | otherwise = S.empty
+ src/GHC/Iface/Ext/Utils.hs view
@@ -0,0 +1,605 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -w #-}+module GHC.Iface.Ext.Utils where++import GHC.Prelude++import GHC.Core.Map.Type+import GHC.Driver.DynFlags ( DynFlags )+import GHC.Driver.Ppr+import GHC.Data.FastString ( FastString, mkFastString )+import GHC.Iface.Type+import GHC.Types.Name hiding (varName)+import GHC.Types.Name.Set+import GHC.Utils.Outputable hiding ( (<>) )+import qualified GHC.Utils.Outputable as O+import GHC.Types.SrcLoc+import GHC.CoreToIface+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Compare( nonDetCmpType )+import GHC.Core.Type+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Parser.Annotation+import qualified GHC.Data.Strict as Strict++import GHC.Iface.Ext.Compat+import GHC.Iface.Ext.Types++import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.IntMap.Strict as IM+import qualified Data.Array as A+import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) )+import Data.Maybe ( maybeToList, mapMaybe)+import Data.Monoid+import Data.List (find)+import Data.Traversable ( for )+import Data.Coerce+import GHC.Utils.Monad.State.Strict hiding (get)+import GHC.Utils.Panic.Plain( assert )+import Control.Monad.Trans.Reader+import qualified Data.Tree as Tree++type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]++generateReferencesMap+ :: Foldable f+ => f (HieAST a)+ -> RefMap a+generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty+ where+ go ast = M.unionsWith (++) (this : map go (nodeChildren ast))+ where+ this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast++renderHieType :: DynFlags -> HieTypeFix -> String+renderHieType dflags ht = showSDoc dflags (ppr $ hieTypeToIface ht)++resolveVisibility :: Type -> [Type] -> [(Bool,Type)]+resolveVisibility kind ty_args+ = go (mkEmptySubst in_scope) kind ty_args+ where+ in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)++ go _ _ [] = []+ go env ty ts+ | Just ty' <- coreView ty+ = go env ty' ts+ go env (ForAllTy (Bndr tv vis) res) (t:ts)+ | isVisibleForAllTyFlag vis = (True , t) : ts'+ | otherwise = (False, t) : ts'+ where+ ts' = go (extendTvSubst env tv t) res ts++ go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps+ = (True,t) : (go env res ts)++ go env (TyVarTy tv) ts+ | Just ki <- lookupTyVar env tv = go env ki ts+ go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded++foldType :: (HieType a -> a) -> HieTypeFix -> a+foldType f (Roll t) = f $ fmap (foldType f) t++selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)+selectPoint hf (sl,sc) = getFirst $+ flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(HiePath fs,ast) -> First $+ case selectSmallestContaining (sp fs) ast of+ Nothing -> Nothing+ Just ast' -> Just ast'+ where+ sloc fs = mkRealSrcLoc fs sl sc+ sp fs = mkRealSrcSpan (sloc fs) (sloc fs)++findEvidenceUse :: NodeIdentifiers a -> [Name]+findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)]+ where+ xs = M.toList ni++data EvidenceInfo a+ = EvidenceInfo+ { evidenceVar :: Name+ , evidenceSpan :: RealSrcSpan+ , evidenceType :: a+ , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)+ } deriving (Eq, Functor)++instance Ord a => Ord (EvidenceInfo a) where+ compare (EvidenceInfo name span typ dets) (EvidenceInfo name' span' typ' dets') =+ case stableNameCmp name name' of+ EQ -> compare (span, typ, dets) (span', typ', dets')+ r -> r++instance (Outputable a) => Outputable (EvidenceInfo a) where+ ppr (EvidenceInfo name span typ dets) =+ hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $+ pdets $$ (pprDefinedAt name)+ where+ pdets = case dets of+ Nothing -> text "is a usage of an external evidence variable"+ Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn)++getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a)+getEvidenceTreesAtPoint hf refmap point =+ [t | Just ast <- pure $ selectPoint hf point+ , n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast)+ , Just t <- pure $ getEvidenceTree refmap n+ ]++getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a))+getEvidenceTree refmap var = go emptyNameSet var+ where+ go seen var+ | var `elemNameSet` seen = Nothing+ | otherwise = do+ xs <- M.lookup (Right var) refmap+ case find (any isEvidenceBind . identInfo . snd) xs of+ Just (sp,dets) -> do+ typ <- identType dets+ (evdet,children) <- getFirst $ foldMap First $ do+ det <- S.toList $ identInfo dets+ case det of+ EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn ->+ pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs)+ EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[])+ _ -> pure Nothing+ pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children+ -- It is externally bound+ Nothing -> getFirst $ foldMap First $ do+ (sp,dets) <- xs+ if (any isEvidenceUse $ identInfo dets)+ then do+ case identType dets of+ Nothing -> pure Nothing+ Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) []+ else pure Nothing++hieTypeToIface :: HieTypeFix -> IfaceType+hieTypeToIface = foldType go+ where+ go (HTyVarTy n) = IfaceTyVar $ (mkIfLclName (occNameFS $ getOccName n))+ go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)+ go (HLitTy l) = IfaceLitTy l+ go (HForAllTy ((n,k),af) t) = let b = (mkIfLclName (occNameFS $ getOccName n), k)+ in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t+ go (HFunTy w a b) = IfaceFunTy visArgTypeLike w a b+ go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b+ go (HCastTy a) = a+ go HCoercionTy = IfaceTyVar (mkIfLclName "<coercion type>")+ go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)++ -- This isn't fully faithful - we can't produce the 'Inferred' case+ hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs+ hieToIfaceArgs (HieArgs xs) = go' xs+ where+ go' [] = IA_Nil+ go' ((True ,x):xs) = IA_Arg x Required $ go' xs+ go' ((False,x):xs) = IA_Arg x Specified $ go' xs++data HieTypeState+ = HTS+ { tyMap :: !(TypeMap TypeIndex)+ , htyTable :: !(IM.IntMap HieTypeFlat)+ , freshIndex :: !TypeIndex+ }++initialHTS :: HieTypeState+initialHTS = HTS emptyTypeMap IM.empty 0++freshTypeIndex :: State HieTypeState TypeIndex+freshTypeIndex = do+ index <- gets freshIndex+ modify $ \hts -> hts { freshIndex = index+1 }+ return index++compressTypes+ :: HieASTs Type+ -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+compressTypes asts = (a, arr)+ where+ (a, (HTS _ m i)) = flip runState initialHTS $+ for asts $ \typ ->+ getTypeIndex typ+ arr = A.array (0,i-1) (IM.toList m)++recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix+recoverFullType i m = go i+ where+ go i = Roll $ fmap go (m A.! i)++getTypeIndex :: Type -> State HieTypeState TypeIndex+getTypeIndex t+ | otherwise = do+ tm <- gets tyMap+ case lookupTypeMap tm t of+ Just i -> return i+ Nothing -> do+ ht <- go t+ extendHTS t ht+ where+ extendHTS t ht = do+ i <- freshTypeIndex+ modify $ \(HTS tm tt fi) ->+ HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi+ return i++ go (TyVarTy v) = return $ HTyVarTy $ varName v+ go ty@(AppTy _ _) = do+ let (head,args) = splitAppTys ty+ visArgs = HieArgs $ resolveVisibility (typeKind head) args+ ai <- getTypeIndex head+ argsi <- mapM getTypeIndex visArgs+ return $ HAppTy ai argsi+ go (TyConApp f xs) = do+ let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs+ is <- mapM getTypeIndex visArgs+ return $ HTyConApp (toIfaceTyCon f) is+ go (ForAllTy (Bndr v a) t) = do+ k <- getTypeIndex (varType v)+ i <- getTypeIndex t+ return $ HForAllTy ((varName v,k),a) i+ go (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) = do+ ai <- getTypeIndex a+ bi <- getTypeIndex b+ wi <- getTypeIndex w+ return $ if isInvisibleFunArg af+ then assert (isManyTy w) $ HQualTy ai bi+ else HFunTy wi ai bi+ go (LitTy a) = return $ HLitTy $ toIfaceTyLit a+ go (CastTy t _) = do+ i <- getTypeIndex t+ return $ HCastTy i+ go (CoercionTy _) = return HCoercionTy++resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a)+resolveTyVarScopes asts = M.map go asts+ where+ go ast = resolveTyVarScopeLocal ast asts++resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a+resolveTyVarScopeLocal ast asts = go ast+ where+ resolveNameScope dets = dets{identInfo =+ S.map resolveScope (identInfo dets)}+ resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =+ TyVarBind sc $ ResolvedScopes+ [ LocalScope binding+ | name <- names+ , Just binding <- [getNameBinding name asts]+ ]+ resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =+ TyVarBind sc $ ResolvedScopes+ [ LocalScope binding+ | name <- names+ , Just binding <- [getNameBindingInClass name sp asts]+ ]+ resolveScope scope = scope+ go (Node info span children) = Node info' span $ map go children+ where+ info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info)+ updateNodeInfo i = i { nodeIdentifiers = idents }+ where+ idents = M.map resolveNameScope $ nodeIdentifiers i++getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span+getNameBinding n asts = do+ (_,msp) <- getNameScopeAndBinding n asts+ msp++getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope]+getNameScope n asts = do+ (scopes,_) <- getNameScopeAndBinding n asts+ return scopes++getNameBindingInClass+ :: Name+ -> Span+ -> M.Map HiePath (HieAST a)+ -> Maybe Span+getNameBindingInClass n sp asts = do+ ast <- M.lookup (HiePath (srcSpanFile sp)) asts+ clsNode <- selectLargestContainedBy sp ast+ getFirst $ foldMap First $ do+ child <- flattenAst clsNode+ dets <- maybeToList+ $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child+ let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)+ return (getFirst binding)++getNameScopeAndBinding+ :: Name+ -> M.Map HiePath (HieAST a)+ -> Maybe ([Scope], Maybe Span)+getNameScopeAndBinding n asts = case nameSrcSpan n of+ RealSrcSpan sp _ -> do -- @Maybe+ ast <- M.lookup (HiePath (srcSpanFile sp)) asts+ defNode <- selectLargestContainedBy sp ast+ getFirst $ foldMap First $ do -- @[]+ node <- flattenAst defNode+ dets <- maybeToList+ $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node+ scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)+ let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)+ return $ Just (scopes, getFirst binding)+ _ -> Nothing++getScopeFromContext :: ContextInfo -> Maybe [Scope]+getScopeFromContext (ValBind _ sc _) = Just [sc]+getScopeFromContext (PatternBind a b _) = Just [a, b]+getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]+getScopeFromContext (Decl _ _) = Just [ModuleScope]+getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs+getScopeFromContext (TyVarBind a _) = Just [a]+getScopeFromContext (EvidenceVarBind _ a _) = Just [a]+getScopeFromContext _ = Nothing++getBindSiteFromContext :: ContextInfo -> Maybe Span+getBindSiteFromContext (ValBind _ _ sp) = sp+getBindSiteFromContext (PatternBind _ _ sp) = sp+getBindSiteFromContext _ = Nothing++flattenAst :: HieAST a -> [HieAST a]+flattenAst n =+ n : concatMap flattenAst (nodeChildren n)++smallestContainingSatisfying+ :: Span+ -> (HieAST a -> Bool)+ -> HieAST a+ -> Maybe (HieAST a)+smallestContainingSatisfying sp cond node+ | nodeSpan node `containsSpan` sp = getFirst $ mconcat+ [ foldMap (First . smallestContainingSatisfying sp cond) $+ nodeChildren node+ , First $ if cond node then Just node else Nothing+ ]+ | sp `containsSpan` nodeSpan node = Nothing+ | otherwise = Nothing++selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)+selectLargestContainedBy sp node+ | sp `containsSpan` nodeSpan node = Just node+ | nodeSpan node `containsSpan` sp =+ getFirst $ foldMap (First . selectLargestContainedBy sp) $+ nodeChildren node+ | otherwise = Nothing++selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)+selectSmallestContaining sp node+ | nodeSpan node `containsSpan` sp = getFirst $ mconcat+ [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node+ , First (Just node)+ ]+ | sp `containsSpan` nodeSpan node = Nothing+ | otherwise = Nothing++definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool+definedInAsts asts n = case nameSrcSpan n of+ RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts+ _ -> False++getEvidenceBindDeps :: ContextInfo -> [Name]+getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) =+ getEvBindDeps xs+getEvidenceBindDeps _ = []++isEvidenceBind :: ContextInfo -> Bool+isEvidenceBind EvidenceVarBind{} = True+isEvidenceBind _ = False++isEvidenceContext :: ContextInfo -> Bool+isEvidenceContext EvidenceVarUse = True+isEvidenceContext EvidenceVarBind{} = True+isEvidenceContext _ = False++isEvidenceUse :: ContextInfo -> Bool+isEvidenceUse EvidenceVarUse = True+isEvidenceUse _ = False++isOccurrence :: ContextInfo -> Bool+isOccurrence Use = True+isOccurrence EvidenceVarUse = True+isOccurrence _ = False++scopeContainsSpan :: Scope -> Span -> Bool+scopeContainsSpan NoScope _ = False+scopeContainsSpan ModuleScope _ = True+scopeContainsSpan (LocalScope a) b = a `containsSpan` b++-- | One must contain the other. Leaf nodes cannot contain anything+combineAst :: HieAST Type -> HieAST Type -> HieAST Type+combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)+ | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys)+ | aSpn `containsSpan` bSpn = combineAst b a+combineAst a (Node xs span children) = Node xs span (insertAst a children)++-- | Insert an AST in a sorted list of disjoint Asts+insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]+insertAst x = mergeAsts [x]++nodeInfo :: HieAST Type -> NodeInfo Type+nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo++emptyNodeInfo :: NodeInfo a+emptyNodeInfo = NodeInfo S.empty [] M.empty++sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a+sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo++combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type+combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo++-- | Merge two nodes together.+--+-- Precondition and postcondition: elements in 'nodeType' are ordered.+combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type+(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =+ NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)+ where+ mergeSorted :: [Type] -> [Type] -> [Type]+ mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of+ LT -> a : mergeSorted as lb+ EQ -> a : mergeSorted as bs+ GT -> b : mergeSorted la bs+ mergeSorted as [] = as+ mergeSorted [] bs = bs+++{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.++In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),+different nodes in an AST tree should either have disjoint spans (in+which case you can say for sure which one comes first) or one span+should be completely contained in the other (in which case the contained+span corresponds to some child node).++However, since Haskell does have position-altering pragmas it /is/+possible for spans to be overlapping. Here is an example of a source file+in which @foozball@ and @quuuuuux@ have overlapping spans:++@+module Baz where++# line 3 "Baz.hs"+foozball :: Int+foozball = 0++# line 3 "Baz.hs"+bar, quuuuuux :: Int+bar = 1+quuuuuux = 2+@++In these cases, we just do our best to produce sensible `HieAST`'s. The blame+should be laid at the feet of whoever wrote the line pragmas in the first place+(usually the C preprocessor...).+-}+mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]+mergeAsts xs [] = xs+mergeAsts [] ys = ys+mergeAsts xs@(a:as) ys@(b:bs)+ | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs+ | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs)+ | span_a `rightOf` span_b = b : mergeAsts xs bs+ | span_a `leftOf` span_b = a : mergeAsts as ys++ -- These cases are to work around ASTs that are not fully disjoint+ | span_a `startsRightOf` span_b = b : mergeAsts as ys+ | otherwise = a : mergeAsts as ys+ where+ span_a = nodeSpan a+ span_b = nodeSpan b++rightOf :: Span -> Span -> Bool+rightOf s1 s2+ = (srcSpanStartLine s1, srcSpanStartCol s1)+ >= (srcSpanEndLine s2, srcSpanEndCol s2)+ && (srcSpanFile s1 == srcSpanFile s2)++leftOf :: Span -> Span -> Bool+leftOf s1 s2+ = (srcSpanEndLine s1, srcSpanEndCol s1)+ <= (srcSpanStartLine s2, srcSpanStartCol s2)+ && (srcSpanFile s1 == srcSpanFile s2)++startsRightOf :: Span -> Span -> Bool+startsRightOf s1 s2+ = (srcSpanStartLine s1, srcSpanStartCol s1)+ >= (srcSpanStartLine s2, srcSpanStartCol s2)++-- | combines and sorts ASTs using a merge sort+mergeSortAsts :: [HieAST Type] -> [HieAST Type]+mergeSortAsts = go . map pure+ where+ go [] = []+ go [xs] = xs+ go xss = go (mergePairs xss)+ mergePairs [] = []+ mergePairs [xs] = [xs]+ mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss++simpleNodeInfo :: FastString -> FastString -> NodeInfo a+simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty++locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]+locOnly (RealSrcSpan span _) = do+ org <- ask+ let e = mkSourcedNodeInfo org $ emptyNodeInfo+ pure [Node e span []]+locOnly _ = pure []++locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a]+locOnlyE (EpaSpan s) = locOnly s+locOnlyE _ = pure []++mkScope :: (HasLoc a) => a -> Scope+mkScope a = case getHasLoc a of+ (RealSrcSpan sp _) -> LocalScope sp+ _ -> NoScope++combineScopes :: Scope -> Scope -> Scope+combineScopes ModuleScope _ = ModuleScope+combineScopes _ ModuleScope = ModuleScope+combineScopes NoScope x = x+combineScopes x NoScope = x+combineScopes (LocalScope a) (LocalScope b) =+ mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing)++mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a+mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni++{-# INLINEABLE makeNodeA #-}+makeNodeA+ :: (Monad m, Data a)+ => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')+ -> EpAnn ann -- ^ return an empty list if this is unhelpful+ -> ReaderT NodeOrigin m [HieAST b]+makeNodeA x spn = makeNode x (locA spn)++{-# INLINEABLE makeNode #-}+makeNode+ :: (Monad m, Data a)+ => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')+ -> SrcSpan -- ^ return an empty list if this is unhelpful+ -> ReaderT NodeOrigin m [HieAST b]+makeNode x spn = do+ org <- ask+ pure $ case spn of+ RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]+ _ -> []+ where+ cons = mkFastString . show . toConstr $ x+ typ = mkFastString . show . typeRepTyCon . typeOf $ x++{-# INLINEABLE makeTypeNodeA #-}+makeTypeNodeA+ :: (Monad m, Data a)+ => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')+ -> SrcSpanAnnA -- ^ return an empty list if this is unhelpful+ -> Type -- ^ type to associate with the node+ -> ReaderT NodeOrigin m [HieAST Type]+makeTypeNodeA x spn etyp = makeTypeNode x (locA spn) etyp++{-# INLINEABLE makeTypeNode #-}+makeTypeNode+ :: (Monad m, Data a)+ => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')+ -> SrcSpan -- ^ return an empty list if this is unhelpful+ -> Type -- ^ type to associate with the node+ -> ReaderT NodeOrigin m [HieAST Type]+makeTypeNode x spn etyp = do+ org <- ask+ pure $ case spn of+ RealSrcSpan span _ ->+ [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []]+ _ -> []+ where+ cons = mkFastString . show . toConstr $ x+ typ = mkFastString . show . typeRepTyCon . typeOf $ x
+ test/GHC/Iface/Ext/BinarySpec.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE BlockArguments #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Iface.Ext.BinarySpec (spec) where++import Test.Hspec++import Control.Concurrent (readMVar)+import Data.Maybe+import Data.String+import Data.Functor+import Data.Foldable+import Data.Map qualified as Map+import Data.ByteString.Char8 qualified as B++import System.Process+import System.FilePath+import System.IO.Temp+import System.Environment.Blank (unsetEnv)++import GHC.Unit.Types+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Cache+import GHC.Unit.Module.Env+import Language.Haskell.Syntax.Module.Name++import GHC.Iface.Ext.Binary+import GHC.Iface.Ext.Types+import GHC.Iface.Ext.Utils ()+import GHC.Iface.Ext.Debug ()++run :: CreateProcess -> IO ()+run p = withCreateProcess p \ _ _ _ -> void . waitForProcess++deriving instance Show unit => Show (GenModule unit)+deriving newtype instance IsString ModuleName+deriving newtype instance IsString UnitId++instance IsString Unit where+ fromString = RealUnit . Definite . fromString++withHieFile :: String -> (FilePath -> IO b) -> IO b+withHieFile ghc action = do+ withSystemTempDirectory "hspec" \ dir -> do+ createHieFile ghc dir "Foo.hs" [+ "module Foo where"+ , "foo :: Int"+ , "foo = 23"+ ]+ action $ dir </> "Foo.hie"++createHieFile :: FilePath -> FilePath -> FilePath -> [String] -> IO ()+createHieFile ghc dir name contents = do+ writeFile (dir </> name) $ unlines contents+ unsetEnv "GHC_ENVIRONMENT"+ run (proc ghc ["-v0", "-fwrite-ide-info", name]) { cwd = Just dir }++supported :: [(String, Integer)]+supported = [+ ("9.8.4", 9084)+ , ("9.10.1", 9101)+ , ("9.10.2", 9102)+ , ("9.12.1", 9121)+ , ("9.12.2", 9122)+ ]++spec :: Spec+spec = do+ describe "readHieFile" do+ it "rejects HIE-files created with GHC 9.4.8" do+ withHieFile "ghc-9.4.8" \ hieFile -> do+ extractSourceFileName hieFile `shouldReturn` "Foo.hs"+ let+ message =+ "Unsupported HIE version 9048 for file "+ <> hieFile+ <> ", supported versions: 9122, 9121, 9102, 9101, 9084, 9083, 9082, 9081"+ expected = userError message+ nameCache <- initNameCache 'r' mempty+ readHieFile nameCache hieFile `shouldThrow` (== expected)++ for_ supported \ (ghcVersion, hieVersion) -> do++ let ghc = "ghc-" <> ghcVersion++ context ("with " <> ghc) do++ it "accepts HIE-files" do+ withHieFile ghc \ hieFile -> do+ extractSourceFileName hieFile `shouldReturn` "Foo.hs"++ nameCache <- initNameCache 'r' mempty+ result <- readHieFile nameCache hieFile++ result.hie_file_result_version `shouldBe` hieVersion+ result.hie_file_result_ghc_version `shouldBe` fromString ghcVersion++ let hie_file = result.hie_file_result++ hie_file.hie_hs_file `shouldBe` "Foo.hs"+ hie_file.hie_module `shouldBe` Module "main" "Foo"+ length hie_file.hie_types `shouldBe` 1+ Map.keys hie_file.hie_asts.getAsts `shouldBe` [HiePath "Foo.hs"]+ length hie_file.hie_exports `shouldBe` 1+ hie_file.hie_hs_src `shouldBe` B.unlines [+ "module Foo where"+ , "foo :: Int"+ , "foo = 23"+ ]+ length hie_file.hie_entity_infos `shouldBe` if hieVersion < 9121 then 0 else 3++ it "maintains precise locations in NameCache" do+ withSystemTempDirectory "hspec" \ dir -> do+ createHieFile ghc dir "Foo.hs" [+ "module Foo (foo) where"+ , ""+ , ""+ , "foo :: Int"+ , "foo = 23"+ ]+ createHieFile ghc dir "Bar.hs" [+ "module Bar where"+ , "import qualified Foo"+ , "bar :: Int"+ , "bar = Foo.foo"+ ]+ createHieFile ghc dir "Foo.hs" [+ "module Foo (foo) where"+ , "foo :: Int"+ , "foo = 23"+ ]+ nameCache <- initNameCache 'r' mempty+ _ <- readHieFile nameCache $ dir </> "Bar.hie"+ _ <- readHieFile nameCache $ dir </> "Foo.hie"++ names <- moduleEnvElts <$> readMVar (nsNames nameCache)++ let+ lookupFoo :: OccEnv Name -> Maybe Name+ lookupFoo = flip lookupOccEnv $ mkOccName varName "foo"++ candidates :: [Name]+ candidates = mapMaybe lookupFoo names++ expectedLocation :: SrcSpan+ expectedLocation = mkSrcSpan (mkSrcLoc "Foo.hs" 3 1) (mkSrcLoc "Foo.hs" 3 4)++ map nameSrcSpan candidates `shouldBe` [expectedLocation]
+ test/GHC/Iface/Ext/Upstream.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Iface.Ext.Upstream (readHieFile) where++import Prelude hiding (span)+import Data.Set qualified as Set+import Data.Map qualified as Map+import Data.Array.Base qualified as A++import GHC.Types.Avail+import GHC.Types.Name.Cache+import "ghc" GHC.Iface.Ext.Types qualified as GHC+import "ghc" GHC.Iface.Ext.Binary qualified as GHC++import GHC.Iface.Ext.Types++deriving instance Eq AvailInfo+deriving instance Eq HieFile++readHieFile :: FilePath -> NameCache -> IO HieFile+readHieFile hieFile nameCache = do+ fromHieFile . GHC.hie_file_result <$> GHC.readHieFile nameCache hieFile++fromHieFile :: GHC.HieFile -> HieFile+fromHieFile GHC.HieFile{..} = HieFile {+ hie_hs_file+, hie_module+, hie_types = A.amap fromHieType hie_types+, hie_asts = fromHieASTs hie_asts+, hie_exports+, hie_hs_src+#if __GLASGOW_HASKELL__ >= 912+, hie_entity_infos = Map.map (Set.map fromEntityInfo) hie_entity_infos+#else+, hie_entity_infos = mempty+#endif+}++#if __GLASGOW_HASKELL__ >= 912+fromEntityInfo :: GHC.EntityInfo -> EntityInfo+fromEntityInfo = \ case+ GHC.EntityVariable -> EntityVariable+ GHC.EntityFunction -> EntityFunction+ GHC.EntityDataConstructor -> EntityDataConstructor+ GHC.EntityTypeVariable -> EntityTypeVariable+ GHC.EntityClassMethod -> EntityClassMethod+ GHC.EntityPatternSynonym -> EntityPatternSynonym+ GHC.EntityTypeConstructor -> EntityTypeConstructor+ GHC.EntityTypeClass -> EntityTypeClass+ GHC.EntityTypeSynonym -> EntityTypeSynonym+ GHC.EntityTypeFamily -> EntityTypeFamily+ GHC.EntityRecordField -> EntityRecordField+#endif++fromHieType :: GHC.HieType a -> HieType a+fromHieType = \ case+ GHC.HTyVarTy name -> HTyVarTy name+ GHC.HAppTy a hieArgs -> HAppTy a (fromHieArgs hieArgs)+ GHC.HTyConApp ifaceTyCon hieArgs -> HTyConApp ifaceTyCon (fromHieArgs hieArgs)+ GHC.HForAllTy as a -> HForAllTy as a+ GHC.HFunTy a b c -> HFunTy a b c+ GHC.HQualTy a b -> HQualTy a b+ GHC.HLitTy ifaceTyLit -> HLitTy ifaceTyLit+ GHC.HCastTy a -> HCastTy a+ GHC.HCoercionTy -> HCoercionTy++fromHieArgs :: GHC.HieArgs a -> HieArgs a+fromHieArgs = \ case+ GHC.HieArgs xs -> HieArgs xs++fromHieASTs :: GHC.HieASTs a -> HieASTs a+fromHieASTs = \ case+ GHC.HieASTs asts -> HieASTs $ Map.map fromHieAST asts++fromHieAST :: GHC.HieAST a -> HieAST a+fromHieAST GHC.Node{..} = Node {+ sourcedNodeInfo = fromSourcedNodeInfo sourcedNodeInfo+, nodeSpan+, nodeChildren = map fromHieAST nodeChildren+}++fromSourcedNodeInfo :: GHC.SourcedNodeInfo a -> SourcedNodeInfo a+fromSourcedNodeInfo =+ SourcedNodeInfo . Map.map fromNodeInfo . Map.mapKeys fromNodeOrigin . GHC.getSourcedNodeInfo++fromNodeOrigin :: GHC.NodeOrigin -> NodeOrigin+fromNodeOrigin = \ case+ GHC.SourceInfo -> SourceInfo+ GHC.GeneratedInfo -> GeneratedInfo++fromNodeInfo :: GHC.NodeInfo a -> NodeInfo a+fromNodeInfo GHC.NodeInfo{..} = NodeInfo {+ nodeAnnotations = Set.map fromNodeAnnotation nodeAnnotations+, nodeType+, nodeIdentifiers = fromNodeIdentifiers nodeIdentifiers+}++fromNodeAnnotation :: GHC.NodeAnnotation -> NodeAnnotation+fromNodeAnnotation GHC.NodeAnnotation{..} = NodeAnnotation{..}++fromNodeIdentifiers :: GHC.NodeIdentifiers a -> NodeIdentifiers a+fromNodeIdentifiers = Map.map fromIdentifierDetails++fromIdentifierDetails :: GHC.IdentifierDetails a -> IdentifierDetails a+fromIdentifierDetails GHC.IdentifierDetails{..} = IdentifierDetails {+ identType+, identInfo = Set.map fromContextInfo identInfo+}++fromBindType :: GHC.BindType -> BindType+fromBindType = \ case+ GHC.RegularBind -> RegularBind+ GHC.InstanceBind -> InstanceBind++fromDeclType :: GHC.DeclType -> DeclType+fromDeclType = \ case+ GHC.FamDec -> FamDec+ GHC.SynDec -> SynDec+ GHC.DataDec -> DataDec+ GHC.InstDec -> InstDec+ GHC.PatSynDec -> PatSynDec+ GHC.ClassDec -> ClassDec+ GHC.ConDec -> ConDec++fromTyVarScope :: GHC.TyVarScope -> TyVarScope+fromTyVarScope = \case+ GHC.ResolvedScopes scopes -> ResolvedScopes $ map fromScope scopes+ GHC.UnresolvedScope a b -> UnresolvedScope a b++fromRecFieldContext :: GHC.RecFieldContext -> RecFieldContext+fromRecFieldContext = \ case+ GHC.RecFieldDecl -> RecFieldDecl+ GHC.RecFieldAssign -> RecFieldAssign+ GHC.RecFieldMatch -> RecFieldMatch+ GHC.RecFieldOcc -> RecFieldOcc++fromContextInfo :: GHC.ContextInfo -> ContextInfo+fromContextInfo = \ case+ GHC.Use -> Use+ GHC.MatchBind -> MatchBind+ GHC.IEThing iEType -> IEThing (fromIEType iEType)+ GHC.TyDecl -> TyDecl+ GHC.ValBind bindType scope span -> ValBind (fromBindType bindType) (fromScope scope) span+ GHC.PatternBind scopeA scopeB span -> PatternBind (fromScope scopeA) (fromScope scopeB) span+ GHC.ClassTyDecl span -> ClassTyDecl span+ GHC.Decl declType span -> Decl (fromDeclType declType) span+ GHC.TyVarBind scope tyVarScope -> TyVarBind (fromScope scope) (fromTyVarScope tyVarScope)+ GHC.RecField recFieldContext span -> RecField (fromRecFieldContext recFieldContext) span+ GHC.EvidenceVarBind evVarSource scope span -> EvidenceVarBind (fromEvVarSource evVarSource) (fromScope scope) span+ GHC.EvidenceVarUse -> EvidenceVarUse++fromIEType :: GHC.IEType -> IEType+fromIEType = \ case+ GHC.Import -> Import+ GHC.ImportAs -> ImportAs+ GHC.ImportHiding -> ImportHiding+ GHC.Export -> Export++fromScope :: GHC.Scope -> Scope+fromScope = \ case+ GHC.NoScope -> NoScope+ GHC.LocalScope span -> LocalScope span+ GHC.ModuleScope -> ModuleScope++fromEvVarSource :: GHC.EvVarSource -> EvVarSource+fromEvVarSource = \ case+ GHC.EvPatternBind -> EvPatternBind+ GHC.EvSigBind -> EvSigBind+ GHC.EvWrapperBind -> EvWrapperBind+ GHC.EvImplicitBind -> EvImplicitBind+ GHC.EvInstBind { isSuperInst, cls } -> EvInstBind { isSuperInst, cls }+ GHC.EvLetBind evBindDeps -> EvLetBind (fromEvBindDeps evBindDeps)++fromEvBindDeps :: GHC.EvBindDeps -> EvBindDeps+fromEvBindDeps = \ case+ GHC.EvBindDeps xs -> EvBindDeps xs
+ test/SmokeSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+module SmokeSpec (spec) where++import Test.Hspec+import Test.QuickCheck++import Foreign (Ptr, peek)+import Data.Word+import Data.Foldable+import Control.Exception (bracket_)+import System.Environment (lookupEnv)+import System.Process++import GHC.Types.Name.Cache+import GHC.Settings.Config (cProjectUnitId)+import GHC.Types.Unique.Supply (initUniqSupply)++import GHC.Iface.Ext.Binary+import GHC.Iface.Ext.BinarySpec ()+import qualified GHC.Iface.Ext.Upstream as Upstream++foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64+foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int++withDeterministicUniqueSupply :: IO a -> IO a+withDeterministicUniqueSupply action = do+ counter <- peek ghc_unique_counter64+ increment <- peek ghc_unique_inc+ bracket_ (initUniqSupply 0 1) (initUniqSupply counter increment) action++findHieFiles :: IO [FilePath]+findHieFiles = lookupEnv "CI" >>= \ case+ Nothing -> return []; Just+ _ -> lines <$> readCreateProcess (shell $ "find " <> store <> " -name '*.hie'") ""+ where+ store = "~/.local/state/cabal/store/" <> cProjectUnitId++spec :: Spec+spec = do+ describe "withDeterministicUniqueSupply" do+ it "runs an action with a deterministic unique supply" do+ withDeterministicUniqueSupply do+ peek ghc_unique_counter64 `shouldReturn` 0+ peek ghc_unique_inc `shouldReturn` 1++ it "restores the original unique supply when done" do+ counter <- peek ghc_unique_counter64+ increment <- peek ghc_unique_inc+ withDeterministicUniqueSupply do+ initUniqSupply 23 42+ peek ghc_unique_counter64 `shouldReturn` 23+ peek ghc_unique_inc `shouldReturn` 42+ peek ghc_unique_counter64 `shouldReturn` counter+ peek ghc_unique_inc `shouldReturn` increment++ describe "smoke tests" do+ runIO findHieFiles >>= traverse_ \ hieFile -> do+ it hieFile do+ theirs <- withDeterministicUniqueSupply do+ nameCache <- initNameCache 'r' mempty+ Upstream.readHieFile hieFile nameCache+ mine <- withDeterministicUniqueSupply do+ nameCache <- initNameCache 'r' mempty+ hie_file_result <$> readHieFile nameCache hieFile+ Blind mine `shouldBe` Blind theirs
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}