mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Backport HIE files to GHC 8.6 (#689)
* Backport HIE files support to 8.6 * Use hie files as source of truth for name source spans. Since we started reusing `.hi` files, this exposes a bug where definitions aren't available since a bad source span from the `.hi` file gets put into the NameCache. We rectify by ensuring the span in the NameCache always matches the one from the `.hie` file. This has surfaced because an interaction between the commit which uses `.hi` instead of retypechecking and the change to use the shared global NameCache to read `.hie` files.
This commit is contained in:
wz1000
GitHub
parent
cbafcf29f4
commit
993cfddc79
@ -155,6 +155,14 @@ library
|
||||
Development.IDE.Plugin.CodeAction.RuleTypes
|
||||
Development.IDE.Plugin.Completions.Logic
|
||||
Development.IDE.Plugin.Completions.Types
|
||||
if (impl(ghc > 8.5) && impl(ghc < 8.7)) && !flag(ghc-lib)
|
||||
hs-source-dirs: src-ghc86
|
||||
other-modules:
|
||||
Development.IDE.GHC.HieAst
|
||||
Development.IDE.GHC.HieBin
|
||||
Development.IDE.GHC.HieTypes
|
||||
Development.IDE.GHC.HieDebug
|
||||
Development.IDE.GHC.HieUtils
|
||||
if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)
|
||||
hs-source-dirs: src-ghc88
|
||||
other-modules:
|
||||
|
||||
1784
src-ghc86/Development/IDE/GHC/HieAst.hs
Normal file
1784
src-ghc86/Development/IDE/GHC/HieAst.hs
Normal file
File diff suppressed because it is too large
Load Diff
388
src-ghc86/Development/IDE/GHC/HieBin.hs
Normal file
388
src-ghc86/Development/IDE/GHC/HieBin.hs
Normal file
@ -0,0 +1,388 @@
|
||||
{-
|
||||
Binary serialization for .hie files.
|
||||
-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Development.IDE.GHC.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic,NameCacheUpdater(..)) where
|
||||
|
||||
import Config ( cProjectVersion )
|
||||
import Binary
|
||||
import BinIface ( getDictFastString )
|
||||
import FastMutInt
|
||||
import FastString ( FastString )
|
||||
import Module ( Module )
|
||||
import Name
|
||||
import NameCache
|
||||
import Outputable
|
||||
import PrelInfo
|
||||
import SrcLoc
|
||||
import UniqSupply ( takeUniqFromSupply )
|
||||
import Util ( maybeRead )
|
||||
import Unique
|
||||
import UniqFM
|
||||
import IfaceEnv
|
||||
|
||||
import qualified Data.Array as A
|
||||
import Data.IORef
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import Data.List ( mapAccumR )
|
||||
import Data.Word ( Word8, Word32 )
|
||||
import Control.Monad ( replicateM, when )
|
||||
import System.Directory ( createDirectoryIfMissing )
|
||||
import System.FilePath ( takeDirectory )
|
||||
|
||||
import Development.IDE.GHC.HieTypes
|
||||
|
||||
-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
|
||||
-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
|
||||
-- these two types.
|
||||
data HieName
|
||||
= ExternalName !Module !OccName !SrcSpan
|
||||
| LocalName !OccName !SrcSpan
|
||||
| KnownKeyName !Unique
|
||||
deriving (Eq)
|
||||
|
||||
instance Ord HieName where
|
||||
compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)
|
||||
compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)
|
||||
compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
|
||||
-- Not actually non determinstic 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
|
||||
|
||||
|
||||
data HieSymbolTable = HieSymbolTable
|
||||
{ hie_symtab_next :: !FastMutInt
|
||||
, hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))
|
||||
}
|
||||
|
||||
data HieDictionary = HieDictionary
|
||||
{ hie_dict_next :: !FastMutInt -- The next index to use
|
||||
, hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
|
||||
}
|
||||
|
||||
initBinMemSize :: Int
|
||||
initBinMemSize = 1024*1024
|
||||
|
||||
-- | The header for HIE files - Capital ASCII letters "HIE".
|
||||
hieMagic :: [Word8]
|
||||
hieMagic = [72,73,69]
|
||||
|
||||
hieMagicLen :: Int
|
||||
hieMagicLen = length hieMagic
|
||||
|
||||
ghcVersion :: ByteString
|
||||
ghcVersion = BSC.pack cProjectVersion
|
||||
|
||||
putBinLine :: BinHandle -> ByteString -> IO ()
|
||||
putBinLine bh xs = do
|
||||
mapM_ (putByte bh) $ BS.unpack xs
|
||||
putByte bh 10 -- newline char
|
||||
|
||||
-- | Write a `HieFile` to the given `FilePath`, with a proper header and
|
||||
-- symbol tables for `Name`s and `FastString`s
|
||||
writeHieFile :: FilePath -> HieFile -> IO ()
|
||||
writeHieFile hie_file_path hiefile = do
|
||||
bh0 <- openBinMem initBinMemSize
|
||||
|
||||
-- Write the header: hieHeader followed by the
|
||||
-- hieVersion and the GHC version used to generate this file
|
||||
mapM_ (putByte bh0) hieMagic
|
||||
putBinLine bh0 $ BSC.pack $ show hieVersion
|
||||
putBinLine bh0 $ ghcVersion
|
||||
|
||||
-- remember where the dictionary pointer will go
|
||||
dict_p_p <- tellBin bh0
|
||||
put_ bh0 dict_p_p
|
||||
|
||||
-- remember where the symbol table pointer will go
|
||||
symtab_p_p <- tellBin bh0
|
||||
put_ bh0 symtab_p_p
|
||||
|
||||
-- Make some intial state
|
||||
symtab_next <- newFastMutInt
|
||||
writeFastMutInt symtab_next 0
|
||||
symtab_map <- newIORef emptyUFM
|
||||
let hie_symtab = HieSymbolTable {
|
||||
hie_symtab_next = symtab_next,
|
||||
hie_symtab_map = symtab_map }
|
||||
dict_next_ref <- newFastMutInt
|
||||
writeFastMutInt dict_next_ref 0
|
||||
dict_map_ref <- newIORef emptyUFM
|
||||
let hie_dict = HieDictionary {
|
||||
hie_dict_next = dict_next_ref,
|
||||
hie_dict_map = dict_map_ref }
|
||||
|
||||
-- put the main thing
|
||||
let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
|
||||
(putName hie_symtab)
|
||||
(putFastString hie_dict)
|
||||
put_ bh hiefile
|
||||
|
||||
-- write the symtab pointer at the front of the file
|
||||
symtab_p <- tellBin bh
|
||||
putAt bh symtab_p_p symtab_p
|
||||
seekBin bh symtab_p
|
||||
|
||||
-- write the symbol table itself
|
||||
symtab_next' <- readFastMutInt symtab_next
|
||||
symtab_map' <- readIORef symtab_map
|
||||
putSymbolTable bh symtab_next' symtab_map'
|
||||
|
||||
-- write the dictionary pointer at the front of the file
|
||||
dict_p <- tellBin bh
|
||||
putAt bh dict_p_p dict_p
|
||||
seekBin bh dict_p
|
||||
|
||||
-- write the dictionary itself
|
||||
dict_next <- readFastMutInt dict_next_ref
|
||||
dict_map <- readIORef dict_map_ref
|
||||
putDictionary bh dict_next dict_map
|
||||
|
||||
-- and send the result to the file
|
||||
createDirectoryIfMissing True (takeDirectory hie_file_path)
|
||||
writeBinMem bh hie_file_path
|
||||
return ()
|
||||
|
||||
data HieFileResult
|
||||
= HieFileResult
|
||||
{ hie_file_result_version :: Integer
|
||||
, hie_file_result_ghc_version :: ByteString
|
||||
, hie_file_result :: HieFile
|
||||
}
|
||||
|
||||
type HieHeader = (Integer, ByteString)
|
||||
|
||||
-- | Read a `HieFile` from a `FilePath`. Can use
|
||||
-- an existing `NameCache`. Allows you to specify
|
||||
-- which versions of hieFile to attempt to read.
|
||||
-- `Left` case returns the failing header versions.
|
||||
readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)
|
||||
readHieFileWithVersion readVersion ncu file = do
|
||||
bh0 <- readBinMem file
|
||||
|
||||
(hieVersion, ghcVersion) <- readHieFileHeader file bh0
|
||||
|
||||
if readVersion (hieVersion, ghcVersion)
|
||||
then do
|
||||
hieFile <- readHieFileContents bh0 ncu
|
||||
return $ Right (HieFileResult hieVersion ghcVersion hieFile)
|
||||
else return $ Left (hieVersion, ghcVersion)
|
||||
|
||||
|
||||
-- | Read a `HieFile` from a `FilePath`. Can use
|
||||
-- an existing `NameCache`.
|
||||
readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult
|
||||
readHieFile ncu file = do
|
||||
|
||||
bh0 <- readBinMem file
|
||||
|
||||
(readHieVersion, ghcVersion) <- readHieFileHeader file bh0
|
||||
|
||||
-- Check if the versions match
|
||||
when (readHieVersion /= hieVersion) $
|
||||
panic $ unwords ["readHieFile: hie file versions don't match for file:"
|
||||
, file
|
||||
, "Expected"
|
||||
, show hieVersion
|
||||
, "but got", show readHieVersion
|
||||
]
|
||||
hieFile <- readHieFileContents bh0 ncu
|
||||
return $ HieFileResult hieVersion ghcVersion hieFile
|
||||
|
||||
readBinLine :: BinHandle -> IO ByteString
|
||||
readBinLine bh = BS.pack . reverse <$> loop []
|
||||
where
|
||||
loop acc = do
|
||||
char <- get bh :: IO Word8
|
||||
if char == 10 -- ASCII newline '\n'
|
||||
then return acc
|
||||
else loop (char : acc)
|
||||
|
||||
readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
|
||||
readHieFileHeader file bh0 = do
|
||||
-- Read the header
|
||||
magic <- replicateM hieMagicLen (get bh0)
|
||||
version <- BSC.unpack <$> readBinLine bh0
|
||||
case maybeRead version of
|
||||
Nothing ->
|
||||
panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"
|
||||
, show version
|
||||
]
|
||||
Just readHieVersion -> do
|
||||
ghcVersion <- readBinLine bh0
|
||||
|
||||
-- Check if the header is valid
|
||||
when (magic /= hieMagic) $
|
||||
panic $ unwords ["readHieFileHeader: headers don't match for file:"
|
||||
, file
|
||||
, "Expected"
|
||||
, show hieMagic
|
||||
, "but got", show magic
|
||||
]
|
||||
return (readHieVersion, ghcVersion)
|
||||
|
||||
readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile
|
||||
readHieFileContents bh0 ncu = do
|
||||
|
||||
dict <- get_dictionary bh0
|
||||
|
||||
-- read the symbol table so we are capable of reading the actual data
|
||||
bh1 <- do
|
||||
let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
|
||||
(getDictFastString dict)
|
||||
symtab <- get_symbol_table bh1
|
||||
let bh1' = setUserData bh1
|
||||
$ newReadState (getSymTabName symtab)
|
||||
(getDictFastString dict)
|
||||
return bh1'
|
||||
|
||||
-- load the actual data
|
||||
hiefile <- get bh1
|
||||
return hiefile
|
||||
where
|
||||
get_dictionary bin_handle = do
|
||||
dict_p <- get bin_handle
|
||||
data_p <- tellBin bin_handle
|
||||
seekBin bin_handle dict_p
|
||||
dict <- getDictionary bin_handle
|
||||
seekBin bin_handle data_p
|
||||
return dict
|
||||
|
||||
get_symbol_table bh1 = do
|
||||
symtab_p <- get bh1
|
||||
data_p' <- tellBin bh1
|
||||
seekBin bh1 symtab_p
|
||||
symtab <- getSymbolTable bh1 ncu
|
||||
seekBin bh1 data_p'
|
||||
return symtab
|
||||
|
||||
putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
|
||||
putFastString HieDictionary { hie_dict_next = j_r,
|
||||
hie_dict_map = out_r} bh f
|
||||
= do
|
||||
out <- readIORef out_r
|
||||
let unique = getUnique f
|
||||
case lookupUFM out unique of
|
||||
Just (j, _) -> put_ bh (fromIntegral j :: Word32)
|
||||
Nothing -> do
|
||||
j <- readFastMutInt j_r
|
||||
put_ bh (fromIntegral j :: Word32)
|
||||
writeFastMutInt j_r (j + 1)
|
||||
writeIORef out_r $! addToUFM out unique (j, f)
|
||||
|
||||
putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()
|
||||
putSymbolTable bh next_off symtab = do
|
||||
put_ bh next_off
|
||||
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
|
||||
mapM_ (putHieName bh) names
|
||||
|
||||
getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
|
||||
getSymbolTable bh ncu = do
|
||||
sz <- get bh
|
||||
od_names <- replicateM sz (getHieName bh)
|
||||
updateNameCache ncu $ \nc ->
|
||||
let arr = A.listArray (0,sz-1) names
|
||||
(nc', names) = mapAccumR fromHieName nc od_names
|
||||
in (nc',arr)
|
||||
|
||||
getSymTabName :: SymbolTable -> BinHandle -> IO Name
|
||||
getSymTabName st bh = do
|
||||
i :: Word32 <- get bh
|
||||
return $ st A.! (fromIntegral i)
|
||||
|
||||
putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
|
||||
putName (HieSymbolTable next ref) bh name = do
|
||||
symmap <- readIORef ref
|
||||
case lookupUFM symmap name of
|
||||
Just (off, ExternalName mod occ (UnhelpfulSpan _))
|
||||
| isGoodSrcSpan (nameSrcSpan name) -> do
|
||||
let hieName = ExternalName mod occ (nameSrcSpan name)
|
||||
writeIORef ref $! addToUFM symmap name (off, hieName)
|
||||
put_ bh (fromIntegral off :: Word32)
|
||||
Just (off, LocalName _occ span)
|
||||
| notLocal (toHieName name) || nameSrcSpan name /= span -> do
|
||||
writeIORef ref $! addToUFM symmap name (off, toHieName name)
|
||||
put_ bh (fromIntegral off :: Word32)
|
||||
Just (off, _) -> put_ bh (fromIntegral off :: Word32)
|
||||
Nothing -> do
|
||||
off <- readFastMutInt next
|
||||
writeFastMutInt next (off+1)
|
||||
writeIORef ref $! addToUFM symmap name (off, toHieName name)
|
||||
put_ bh (fromIntegral off :: Word32)
|
||||
|
||||
where
|
||||
notLocal :: HieName -> Bool
|
||||
notLocal LocalName{} = False
|
||||
notLocal _ = True
|
||||
|
||||
|
||||
-- ** Converting to and from `HieName`'s
|
||||
|
||||
toHieName :: Name -> HieName
|
||||
toHieName name
|
||||
| isKnownKeyName name = KnownKeyName (nameUnique name)
|
||||
| isExternalName name = ExternalName (nameModule name)
|
||||
(nameOccName name)
|
||||
(nameSrcSpan name)
|
||||
| otherwise = LocalName (nameOccName name) (nameSrcSpan name)
|
||||
|
||||
fromHieName :: NameCache -> HieName -> (NameCache, Name)
|
||||
fromHieName nc (ExternalName mod occ span) =
|
||||
let cache = nsNames nc
|
||||
in case lookupOrigNameCache cache mod occ of
|
||||
Just name
|
||||
| nameSrcSpan name == span -> (nc, name)
|
||||
| otherwise ->
|
||||
let name' = setNameLoc name span
|
||||
new_cache = extendNameCache cache mod occ name'
|
||||
in ( nc{ nsNames = new_cache }, name' )
|
||||
Nothing ->
|
||||
let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
|
||||
name = mkExternalName uniq mod occ span
|
||||
new_cache = extendNameCache cache mod occ name
|
||||
in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
|
||||
fromHieName nc (LocalName occ span) =
|
||||
let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
|
||||
name = mkInternalName uniq occ span
|
||||
in ( nc{ nsUniqs = us }, name )
|
||||
fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of
|
||||
Nothing -> pprPanic "fromHieName:unknown known-key unique"
|
||||
(ppr (unpkUnique u))
|
||||
Just n -> (nc, n)
|
||||
|
||||
-- ** Reading and writing `HieName`'s
|
||||
|
||||
putHieName :: BinHandle -> HieName -> IO ()
|
||||
putHieName bh (ExternalName mod occ span) = do
|
||||
putByte bh 0
|
||||
put_ bh (mod, occ, span)
|
||||
putHieName bh (LocalName occName span) = do
|
||||
putByte bh 1
|
||||
put_ bh (occName, span)
|
||||
putHieName bh (KnownKeyName uniq) = do
|
||||
putByte bh 2
|
||||
put_ bh $ unpkUnique uniq
|
||||
|
||||
getHieName :: BinHandle -> IO HieName
|
||||
getHieName bh = do
|
||||
t <- getByte bh
|
||||
case t of
|
||||
0 -> do
|
||||
(modu, occ, span) <- get bh
|
||||
return $ ExternalName modu occ span
|
||||
1 -> do
|
||||
(occ, span) <- get bh
|
||||
return $ LocalName occ span
|
||||
2 -> do
|
||||
(c,i) <- get bh
|
||||
return $ KnownKeyName $ mkUnique c i
|
||||
_ -> panic "HieBin.getHieName: invalid tag"
|
||||
145
src-ghc86/Development/IDE/GHC/HieDebug.hs
Normal file
145
src-ghc86/Development/IDE/GHC/HieDebug.hs
Normal file
@ -0,0 +1,145 @@
|
||||
{-
|
||||
Functions to validate and check .hie file ASTs generated by GHC.
|
||||
-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Development.IDE.GHC.HieDebug where
|
||||
|
||||
import Prelude hiding ((<>))
|
||||
import SrcLoc
|
||||
import Module
|
||||
import FastString
|
||||
import Outputable
|
||||
|
||||
import Development.IDE.GHC.HieTypes
|
||||
import Development.IDE.GHC.HieBin
|
||||
import Development.IDE.GHC.HieUtils
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Function ( on )
|
||||
import Data.List ( sortOn )
|
||||
import Data.Foldable ( toList )
|
||||
|
||||
ppHies :: Outputable a => (HieASTs a) -> SDoc
|
||||
ppHies (HieASTs asts) = M.foldrWithKey go "" asts
|
||||
where
|
||||
go k a rest = vcat $
|
||||
[ "File: " <> ppr k
|
||||
, ppHie a
|
||||
, rest
|
||||
]
|
||||
|
||||
ppHie :: Outputable a => HieAST a -> SDoc
|
||||
ppHie = go 0
|
||||
where
|
||||
go n (Node inf sp children) = hang header n rest
|
||||
where
|
||||
rest = vcat $ map (go (n+2)) children
|
||||
header = hsep
|
||||
[ "Node"
|
||||
, ppr sp
|
||||
, ppInfo inf
|
||||
]
|
||||
|
||||
ppInfo :: Outputable a => NodeInfo a -> SDoc
|
||||
ppInfo ni = hsep
|
||||
[ ppr $ toList $ nodeAnnotations ni
|
||||
, ppr $ nodeType ni
|
||||
, ppr $ M.toList $ nodeIdentifiers ni
|
||||
]
|
||||
|
||||
type Diff a = a -> a -> [SDoc]
|
||||
|
||||
diffFile :: Diff HieFile
|
||||
diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
|
||||
|
||||
diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))
|
||||
diffAsts f = diffList (diffAst f) `on` M.elems
|
||||
|
||||
diffAst :: (Outputable a, Eq 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
|
||||
= (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
|
||||
++ (diffList diffType `on` nodeType) info1 info2
|
||||
++ (diffIdents `on` nodeIdentifiers) info1 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 :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
|
||||
normalizeIdents = sortOn fst . map (first toHieName) . M.toList
|
||||
where
|
||||
first f (a,b) = (fmap f a, 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 :: M.Map FastString (HieAST a) -> [SDoc]
|
||||
validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
|
||||
where
|
||||
refMap = generateReferencesMap asts
|
||||
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 isOccurrence (identInfo dets)
|
||||
= case scopes of
|
||||
[] -> []
|
||||
_ -> if any (`scopeContainsSpan` sp) scopes
|
||||
then []
|
||||
else return $ hsep $
|
||||
[ "Name", ppr n, "at position", ppr sp
|
||||
, "doesn't occur in calculated scope", ppr scopes]
|
||||
| otherwise = []
|
||||
534
src-ghc86/Development/IDE/GHC/HieTypes.hs
Normal file
534
src-ghc86/Development/IDE/GHC/HieTypes.hs
Normal file
@ -0,0 +1,534 @@
|
||||
{-
|
||||
Types for the .hie file format are defined here.
|
||||
|
||||
For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
|
||||
-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module Development.IDE.GHC.HieTypes where
|
||||
|
||||
import Config
|
||||
import Binary
|
||||
import FastString ( FastString )
|
||||
import IfaceType
|
||||
import Module ( ModuleName, Module )
|
||||
import Name ( Name )
|
||||
import Outputable hiding ( (<>) )
|
||||
import SrcLoc
|
||||
import Avail
|
||||
|
||||
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 ( Typeable, Data )
|
||||
import Data.Semigroup ( Semigroup(..) )
|
||||
import Data.Word ( Word8 )
|
||||
import Control.Applicative ( (<|>) )
|
||||
|
||||
type Span = RealSrcSpan
|
||||
|
||||
instance Binary RealSrcSpan where
|
||||
put_ bh 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 (mkRealSrcSpan (mkRealSrcLoc f sl sc)
|
||||
(mkRealSrcLoc f el ec))
|
||||
|
||||
instance (A.Ix a, Binary a, Binary b) => Binary (A.Array a b) where
|
||||
put_ bh arr = do
|
||||
put_ bh $ A.bounds arr
|
||||
put_ bh $ A.elems arr
|
||||
get bh = do
|
||||
bounds <- get bh
|
||||
xs <- get bh
|
||||
return $ A.listArray bounds xs
|
||||
|
||||
-- | Current version of @.hie@ files
|
||||
hieVersion :: Integer
|
||||
hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
|
||||
|
||||
{- |
|
||||
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
|
||||
}
|
||||
instance Binary HieFile where
|
||||
put_ bh hf = do
|
||||
put_ bh $ hie_hs_file hf
|
||||
put_ bh $ hie_module hf
|
||||
put_ bh $ hie_types hf
|
||||
put_ bh $ hie_asts hf
|
||||
put_ bh $ hie_exports hf
|
||||
put_ bh $ hie_hs_src hf
|
||||
|
||||
get bh = HieFile
|
||||
<$> get bh
|
||||
<*> get bh
|
||||
<*> get bh
|
||||
<*> get bh
|
||||
<*> get bh
|
||||
<*> 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 a
|
||||
| HTyConApp IfaceTyCon (HieArgs a)
|
||||
| HForAllTy ((Name, a),ArgFlag) a
|
||||
| HFunTy 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))
|
||||
|
||||
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 a b) = do
|
||||
putByte bh 4
|
||||
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
|
||||
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 'isVisibleArgFlag'?).
|
||||
newtype HieArgs a = HieArgs [(Bool,a)]
|
||||
deriving (Functor, Foldable, Traversable, Eq)
|
||||
|
||||
instance Binary (HieArgs TypeIndex) where
|
||||
put_ bh (HieArgs xs) = put_ bh xs
|
||||
get bh = HieArgs <$> get bh
|
||||
|
||||
-- | Mapping from filepaths (represented using 'FastString') to the
|
||||
-- corresponding AST
|
||||
newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }
|
||||
deriving (Functor, Foldable, Traversable)
|
||||
|
||||
instance Binary (HieASTs TypeIndex) where
|
||||
put_ bh asts = put_ bh $ M.toAscList $ getAsts asts
|
||||
get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)
|
||||
|
||||
|
||||
data HieAST a =
|
||||
Node
|
||||
{ nodeInfo :: NodeInfo a
|
||||
, nodeSpan :: Span
|
||||
, nodeChildren :: [HieAST a]
|
||||
} deriving (Functor, Foldable, Traversable)
|
||||
|
||||
instance Binary (HieAST TypeIndex) where
|
||||
put_ bh ast = do
|
||||
put_ bh $ nodeInfo ast
|
||||
put_ bh $ nodeSpan ast
|
||||
put_ bh $ nodeChildren ast
|
||||
|
||||
get bh = Node
|
||||
<$> get bh
|
||||
<*> 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 (FastString,FastString)
|
||||
-- ^ (name of the AST node constructor, name of the AST node Type)
|
||||
|
||||
, nodeType :: [a]
|
||||
-- ^ The Haskell types of this node, if any.
|
||||
|
||||
, nodeIdentifiers :: NodeIdentifiers a
|
||||
-- ^ All the identifiers and their details
|
||||
} deriving (Functor, Foldable, Traversable)
|
||||
|
||||
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)
|
||||
|
||||
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 "IdentifierDetails" <+> 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.toAscList $ 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)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Outputable ContextInfo where
|
||||
ppr = text . show
|
||||
|
||||
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 msp
|
||||
put_ bh (PatternBind a b c) = do
|
||||
putByte bh 4
|
||||
put_ bh a
|
||||
put_ bh b
|
||||
put_ bh c
|
||||
put_ bh (ClassTyDecl sp) = do
|
||||
putByte bh 5
|
||||
put_ bh sp
|
||||
put_ bh (Decl a b) = do
|
||||
putByte bh 6
|
||||
put_ bh a
|
||||
put_ bh 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 b
|
||||
put_ bh MatchBind = putByte bh 9
|
||||
|
||||
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 <*> get bh
|
||||
4 -> PatternBind <$> get bh <*> get bh <*> get bh
|
||||
5 -> ClassTyDecl <$> get bh
|
||||
6 -> Decl <$> get bh <*> get bh
|
||||
7 -> TyVarBind <$> get bh <*> get bh
|
||||
8 -> RecField <$> get bh <*> get bh
|
||||
9 -> return MatchBind
|
||||
_ -> panic "Binary ContextInfo: invalid tag"
|
||||
|
||||
|
||||
-- | Types of imports and exports
|
||||
data IEType
|
||||
= Import
|
||||
| ImportAs
|
||||
| ImportHiding
|
||||
| Export
|
||||
deriving (Eq, Enum, Ord, Show)
|
||||
|
||||
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, Show)
|
||||
|
||||
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, Show, Enum)
|
||||
|
||||
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, Show, Enum)
|
||||
|
||||
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, Show, Typeable, 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 span
|
||||
put_ bh ModuleScope = putByte bh 2
|
||||
|
||||
get bh = do
|
||||
(t :: Word8) <- get bh
|
||||
case t of
|
||||
0 -> return NoScope
|
||||
1 -> LocalScope <$> 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 Show TyVarScope where
|
||||
show (ResolvedScopes sc) = show sc
|
||||
show _ = error "UnresolvedScope"
|
||||
|
||||
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 span
|
||||
|
||||
get bh = do
|
||||
(t :: Word8) <- get bh
|
||||
case t of
|
||||
0 -> ResolvedScopes <$> get bh
|
||||
1 -> UnresolvedScope <$> get bh <*> get bh
|
||||
_ -> panic "Binary TyVarScope: invalid tag"
|
||||
451
src-ghc86/Development/IDE/GHC/HieUtils.hs
Normal file
451
src-ghc86/Development/IDE/GHC/HieUtils.hs
Normal file
@ -0,0 +1,451 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Development.IDE.GHC.HieUtils where
|
||||
|
||||
import CoreMap
|
||||
import DynFlags ( DynFlags )
|
||||
import FastString ( FastString, mkFastString )
|
||||
import IfaceType
|
||||
import Name hiding (varName)
|
||||
import Outputable ( renderWithStyle, ppr, defaultUserStyle )
|
||||
import SrcLoc
|
||||
import ToIface
|
||||
import TyCon
|
||||
import TyCoRep
|
||||
import Type
|
||||
import Var
|
||||
import VarEnv
|
||||
|
||||
import Development.IDE.GHC.HieTypes
|
||||
|
||||
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 )
|
||||
import Data.Monoid
|
||||
import Data.Traversable ( for )
|
||||
import Control.Monad.Trans.State.Strict hiding (get)
|
||||
|
||||
|
||||
generateReferencesMap
|
||||
:: Foldable f
|
||||
=> f (HieAST a)
|
||||
-> M.Map Identifier [(Span, IdentifierDetails 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,)) $ nodeIdentifiers $ nodeInfo ast
|
||||
|
||||
renderHieType :: DynFlags -> HieTypeFix -> String
|
||||
renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty
|
||||
where sty = defaultUserStyle df
|
||||
|
||||
resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
|
||||
resolveVisibility kind ty_args
|
||||
= go (mkEmptyTCvSubst 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 (TvBndr tv vis) res) (t:ts)
|
||||
| isVisibleArgFlag vis = (True , t) : ts'
|
||||
| otherwise = (False, t) : ts'
|
||||
where
|
||||
ts' = go (extendTvSubst env tv t) res ts
|
||||
|
||||
go env (FunTy _ 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
|
||||
|
||||
hieTypeToIface :: HieTypeFix -> IfaceType
|
||||
hieTypeToIface = foldType go
|
||||
where
|
||||
go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
|
||||
go (HAppTy a b) = IfaceAppTy a b
|
||||
go (HLitTy l) = IfaceLitTy l
|
||||
go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
|
||||
in IfaceForAllTy (TvBndr b af) t
|
||||
go (HFunTy a b) = IfaceFunTy a b
|
||||
go (HQualTy pred b) = IfaceDFunTy pred b
|
||||
go (HCastTy a) = a
|
||||
go HCoercionTy = IfaceTyVar "<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 -> IfaceTcArgs
|
||||
hieToIfaceArgs (HieArgs xs) = go' xs
|
||||
where
|
||||
go' [] = ITC_Nil
|
||||
go' ((True ,x):xs) = ITC_Vis x $ go' xs
|
||||
go' ((False,x):xs) = ITC_Invis x $ 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 -> do
|
||||
i <- getTypeIndex typ
|
||||
return i
|
||||
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 (AppTy a b) = do
|
||||
ai <- getTypeIndex a
|
||||
bi <- getTypeIndex b
|
||||
return $ HAppTy ai bi
|
||||
go (TyConApp f xs) = do
|
||||
let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs
|
||||
is <- mapM getTypeIndex visArgs
|
||||
return $ HTyConApp (toIfaceTyCon f) is
|
||||
go (ForAllTy (TvBndr v a) t) = do
|
||||
k <- getTypeIndex (varType v)
|
||||
i <- getTypeIndex t
|
||||
return $ HForAllTy ((varName v,k),a) i
|
||||
go (FunTy a b) = do
|
||||
ai <- getTypeIndex a
|
||||
bi <- getTypeIndex b
|
||||
return $ if isPredTy a
|
||||
then HQualTy ai bi
|
||||
else HFunTy 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 FastString (HieAST a) -> M.Map FastString (HieAST a)
|
||||
resolveTyVarScopes asts = M.map go asts
|
||||
where
|
||||
go ast = resolveTyVarScopeLocal ast asts
|
||||
|
||||
resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (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' = info { nodeIdentifiers = idents }
|
||||
idents = M.map resolveNameScope $ nodeIdentifiers info
|
||||
|
||||
getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
|
||||
getNameBinding n asts = do
|
||||
(_,msp) <- getNameScopeAndBinding n asts
|
||||
msp
|
||||
|
||||
getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]
|
||||
getNameScope n asts = do
|
||||
(scopes,_) <- getNameScopeAndBinding n asts
|
||||
return scopes
|
||||
|
||||
getNameBindingInClass
|
||||
:: Name
|
||||
-> Span
|
||||
-> M.Map FastString (HieAST a)
|
||||
-> Maybe Span
|
||||
getNameBindingInClass n sp asts = do
|
||||
ast <- M.lookup (srcSpanFile sp) asts
|
||||
getFirst $ foldMap First $ do
|
||||
child <- flattenAst ast
|
||||
dets <- maybeToList
|
||||
$ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child
|
||||
let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
|
||||
return (getFirst binding)
|
||||
|
||||
getNameScopeAndBinding
|
||||
:: Name
|
||||
-> M.Map FastString (HieAST a)
|
||||
-> Maybe ([Scope], Maybe Span)
|
||||
getNameScopeAndBinding n asts = case nameSrcSpan n of
|
||||
RealSrcSpan sp -> do -- @Maybe
|
||||
ast <- M.lookup (srcSpanFile sp) asts
|
||||
defNode <- selectLargestContainedBy sp ast
|
||||
getFirst $ foldMap First $ do -- @[]
|
||||
node <- flattenAst defNode
|
||||
dets <- maybeToList
|
||||
$ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo 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 _ = 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 FastString (HieAST a) -> Name -> Bool
|
||||
definedInAsts asts n = case nameSrcSpan n of
|
||||
RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts
|
||||
_ -> False
|
||||
|
||||
isOccurrence :: ContextInfo -> Bool
|
||||
isOccurrence Use = 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 `combineNodeInfo` 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]
|
||||
|
||||
-- | 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 (cons, typ)) [] M.empty
|
||||
|
||||
locOnly :: SrcSpan -> [HieAST a]
|
||||
locOnly (RealSrcSpan span) =
|
||||
[Node e span []]
|
||||
where e = NodeInfo S.empty [] M.empty
|
||||
locOnly _ = []
|
||||
|
||||
mkScope :: SrcSpan -> Scope
|
||||
mkScope (RealSrcSpan sp) = LocalScope sp
|
||||
mkScope _ = NoScope
|
||||
|
||||
mkLScope :: Located a -> Scope
|
||||
mkLScope = mkScope . getLoc
|
||||
|
||||
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) (RealSrcSpan b)
|
||||
|
||||
{-# INLINEABLE makeNode #-}
|
||||
makeNode
|
||||
:: (Applicative m, Data a)
|
||||
=> a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
|
||||
-> SrcSpan -- ^ return an empty list if this is unhelpful
|
||||
-> m [HieAST b]
|
||||
makeNode x spn = pure $ case spn of
|
||||
RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]
|
||||
_ -> []
|
||||
where
|
||||
cons = mkFastString . show . toConstr $ x
|
||||
typ = mkFastString . show . typeRepTyCon . typeOf $ x
|
||||
|
||||
{-# INLINEABLE makeTypeNode #-}
|
||||
makeTypeNode
|
||||
:: (Applicative 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
|
||||
-> m [HieAST Type]
|
||||
makeTypeNode x spn etyp = pure $ case spn of
|
||||
RealSrcSpan span ->
|
||||
[Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
|
||||
_ -> []
|
||||
where
|
||||
cons = mkFastString . show . toConstr $ x
|
||||
typ = mkFastString . show . typeRepTyCon . typeOf $ x
|
||||
@ -52,9 +52,16 @@ module Development.IDE.GHC.Compat(
|
||||
upNameCache,
|
||||
|
||||
module GHC,
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
module HieTypes,
|
||||
module HieUtils,
|
||||
#else
|
||||
module Development.IDE.GHC.HieTypes,
|
||||
module Development.IDE.GHC.HieUtils,
|
||||
#endif
|
||||
|
||||
#endif
|
||||
) where
|
||||
|
||||
@ -94,35 +101,38 @@ import Avail
|
||||
import ErrUtils (ErrorMessages)
|
||||
import FastString (FastString)
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
import Development.IDE.GHC.HieAst (mkHieFile)
|
||||
import Development.IDE.GHC.HieBin
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
import HieUtils
|
||||
import HieTypes
|
||||
|
||||
supportsHieFiles :: Bool
|
||||
supportsHieFiles = True
|
||||
|
||||
hieExportNames :: HieFile -> [(SrcSpan, Name)]
|
||||
hieExportNames = nameListFromAvails . hie_exports
|
||||
|
||||
#else
|
||||
|
||||
import IfaceEnv
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
import BinIface
|
||||
#else
|
||||
import System.IO.Error
|
||||
import Development.IDE.GHC.HieUtils
|
||||
import Development.IDE.GHC.HieTypes
|
||||
import System.FilePath ((-<.>))
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
||||
#if !MIN_GHC_API_VERSION(8,8,0)
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
import GhcPlugins (srcErrorMessages)
|
||||
#else
|
||||
import System.IO.Error
|
||||
import IfaceEnv
|
||||
import Binary
|
||||
import Control.Exception (catch)
|
||||
import Data.ByteString (ByteString)
|
||||
import GhcPlugins (Hsc, srcErrorMessages)
|
||||
import TcRnTypes
|
||||
import MkIface
|
||||
#endif
|
||||
|
||||
import Control.Exception (catch)
|
||||
import System.IO
|
||||
import Foreign.ForeignPtr
|
||||
import MkIface
|
||||
|
||||
|
||||
hPutStringBuffer :: Handle -> StringBuffer -> IO ()
|
||||
@ -132,6 +142,20 @@ hPutStringBuffer hdl (StringBuffer buf len cur)
|
||||
|
||||
#endif
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
supportsHieFiles :: Bool
|
||||
supportsHieFiles = True
|
||||
|
||||
hieExportNames :: HieFile -> [(SrcSpan, Name)]
|
||||
hieExportNames = nameListFromAvails . hie_exports
|
||||
|
||||
#if !MIN_GHC_API_VERSION(8,8,0)
|
||||
ml_hie_file :: GHC.ModLocation -> FilePath
|
||||
ml_hie_file ml = ml_hi_file ml -<.> ".hie"
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
||||
upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
|
||||
#if !MIN_GHC_API_VERSION(8,8,0)
|
||||
upNameCache ref upd_fn
|
||||
@ -271,7 +295,7 @@ nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
|
||||
nameListFromAvails as =
|
||||
map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)
|
||||
|
||||
#if !MIN_GHC_API_VERSION(8,8,0)
|
||||
#if !MIN_GHC_API_VERSION(8,6,0)
|
||||
-- Reimplementations of functions for HIE files for GHC 8.6
|
||||
|
||||
mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile
|
||||
@ -303,21 +327,7 @@ writeHieFile :: FilePath -> HieFile -> IO ()
|
||||
readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult
|
||||
supportsHieFiles :: Bool
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
|
||||
writeHieFile fp hie = do
|
||||
bh <- openBinMem (1024 * 1024)
|
||||
putWithUserData (const $ return ()) bh hie
|
||||
writeBinMem bh fp
|
||||
|
||||
readHieFile nc fp = do
|
||||
bh <- readBinMem fp
|
||||
hie_file <- getWithUserData nc bh
|
||||
return (HieFileResult hie_file)
|
||||
|
||||
supportsHieFiles = True
|
||||
|
||||
#else
|
||||
#if MIN_GHC_API_VERSION(8,4,0)
|
||||
|
||||
supportsHieFiles = False
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user