Commit f582379d authored by Alec Theriault's avatar Alec Theriault Committed by Ben Gamari
Browse files

Support generating HIE files

Adds a `-fenable-ide-info` flag which instructs GHC to generate `.hie`
files (see the wiki page:
https://ghc.haskell.org/trac/ghc/wiki/HIEFiles).

This is a rebased version of Zubin Duggal's (@wz1000) GHC changes for
his GSOC project, as posted here:
https://gist.github.com/wz1000/5ed4ddd0d3e96d6bc75e095cef95363d.

Test Plan: ./validate

Reviewers: bgamari, gershomb, nomeata, alanz, sjakobi

Reviewed By: alanz, sjakobi

Subscribers: alanz, hvr, sjakobi, rwbarton, wz1000, carter

Differential Revision: https://phabricator.haskell.org/D5239
parent 21339c9f
...@@ -677,6 +677,7 @@ summariseRequirement pn mod_name = do ...@@ -677,6 +677,7 @@ summariseRequirement pn mod_name = do
env <- getBkpEnv env <- getBkpEnv
time <- liftIO $ getModificationUTCTime (bkp_filename env) time <- liftIO $ getModificationUTCTime (bkp_filename env)
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
...@@ -690,6 +691,7 @@ summariseRequirement pn mod_name = do ...@@ -690,6 +691,7 @@ summariseRequirement pn mod_name = do
ms_hs_date = time, ms_hs_date = time,
ms_obj_date = Nothing, ms_obj_date = Nothing,
ms_iface_date = hi_timestamp, ms_iface_date = hi_timestamp,
ms_hie_date = hie_timestamp,
ms_srcimps = [], ms_srcimps = [],
ms_textual_imps = extra_sig_imports, ms_textual_imps = extra_sig_imports,
ms_parsed_mod = Just (HsParsedModule { ms_parsed_mod = Just (HsParsedModule {
...@@ -765,12 +767,13 @@ hsModuleToModSummary pn hsc_src modname ...@@ -765,12 +767,13 @@ hsModuleToModSummary pn hsc_src modname
HsSrcFile -> "hs") HsSrcFile -> "hs")
-- DANGEROUS: bootifying can POISON the module finder cache -- DANGEROUS: bootifying can POISON the module finder cache
let location = case hsc_src of let location = case hsc_src of
HsBootFile -> addBootSuffixLocn location0 HsBootFile -> addBootSuffixLocnOut location0
_ -> location0 _ -> location0
-- This duplicates a pile of logic in GhcMake -- This duplicates a pile of logic in GhcMake
env <- getBkpEnv env <- getBkpEnv
time <- liftIO $ getModificationUTCTime (bkp_filename env) time <- liftIO $ getModificationUTCTime (bkp_filename env)
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
-- Also copied from 'getImports' -- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
...@@ -815,7 +818,8 @@ hsModuleToModSummary pn hsc_src modname ...@@ -815,7 +818,8 @@ hsModuleToModSummary pn hsc_src modname
}), }),
ms_hs_date = time, ms_hs_date = time,
ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
ms_iface_date = hi_timestamp ms_iface_date = hi_timestamp,
ms_hie_date = hie_timestamp
} }
-- | Create a new, externally provided hashed unit id from -- | Create a new, externally provided hashed unit id from
......
...@@ -112,7 +112,8 @@ module Module ...@@ -112,7 +112,8 @@ module Module
-- * The ModuleLocation type -- * The ModuleLocation type
ModLocation(..), ModLocation(..),
addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, addBootSuffix, addBootSuffix_maybe,
addBootSuffixLocn, addBootSuffixLocnOut,
-- * Module mappings -- * Module mappings
ModuleEnv, ModuleEnv,
...@@ -267,11 +268,12 @@ data ModLocation ...@@ -267,11 +268,12 @@ data ModLocation
-- yet. Always of form foo.hi, even if there is an -- yet. Always of form foo.hi, even if there is an
-- hi-boot file (we add the -boot suffix later) -- hi-boot file (we add the -boot suffix later)
ml_obj_file :: FilePath ml_obj_file :: FilePath,
-- Where the .o file is, whether or not it exists yet. -- Where the .o file is, whether or not it exists yet.
-- (might not exist either because the module hasn't -- (might not exist either because the module hasn't
-- been compiled yet, or because it is part of a -- been compiled yet, or because it is part of a
-- package with a .a file) -- package with a .a file)
ml_hie_file :: FilePath
} deriving Show } deriving Show
instance Outputable ModLocation where instance Outputable ModLocation where
...@@ -302,7 +304,16 @@ addBootSuffixLocn :: ModLocation -> ModLocation ...@@ -302,7 +304,16 @@ addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn addBootSuffixLocn locn
= locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
, ml_hi_file = addBootSuffix (ml_hi_file locn) , ml_hi_file = addBootSuffix (ml_hi_file locn)
, ml_obj_file = addBootSuffix (ml_obj_file locn) } , ml_obj_file = addBootSuffix (ml_obj_file locn)
, ml_hie_file = addBootSuffix (ml_hie_file locn) }
addBootSuffixLocnOut :: ModLocation -> ModLocation
-- ^ Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
addBootSuffixLocnOut locn
= locn { ml_hi_file = addBootSuffix (ml_hi_file locn)
, ml_obj_file = addBootSuffix (ml_obj_file locn)
, ml_hie_file = addBootSuffix (ml_hie_file locn) }
{- {-
************************************************************************ ************************************************************************
......
...@@ -170,6 +170,7 @@ Library ...@@ -170,6 +170,7 @@ Library
typecheck typecheck
types types
utils utils
hieFile
-- we use an explicit Prelude -- we use an explicit Prelude
Default-Extensions: Default-Extensions:
...@@ -179,6 +180,11 @@ Library ...@@ -179,6 +180,11 @@ Library
GhcPrelude GhcPrelude
Exposed-Modules: Exposed-Modules:
HieTypes
HieDebug
HieBin
HieUtils
HieAst
Ar Ar
FileCleanup FileCleanup
DriverBkp DriverBkp
......
This diff is collapsed.
{-# LANGUAGE ScopedTypeVariables #-}
module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where
import GhcPrelude
import Binary
import BinIface ( getDictFastString )
import FastMutInt
import FastString ( FastString )
import Module ( Module )
import Name
import NameCache
import Outputable
import PrelInfo
import SrcLoc
import UniqSupply ( takeUniqFromSupply )
import Unique
import UniqFM
import qualified Data.Array as A
import Data.IORef
import Data.List ( mapAccumR )
import Data.Word ( Word32 )
import Control.Monad ( replicateM )
-- | `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
writeHieFile :: Binary a => FilePath -> a -> IO ()
writeHieFile filename hiefile = do
bh0 <- openBinMem initBinMemSize
-- 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 fornt 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
writeBinMem bh filename
return ()
readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache)
readHieFile nc file = do
bh0 <- readBinMem file
dict <- get_dictionary bh0
-- read the symbol table so we are capable of reading the actual data
(bh1, nc') <- do
let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
(getDictFastString dict)
(nc', symtab) <- get_symbol_table bh1
let bh1' = setUserData bh1
$ newReadState (getSymTabName symtab)
(getDictFastString dict)
return (bh1', nc')
-- load the actual data
hiefile <- get bh1
return (hiefile, nc')
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
(nc', symtab) <- getSymbolTable bh1 nc
seekBin bh1 data_p'
return (nc', 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 -> NameCache -> IO (NameCache, SymbolTable)
getSymbolTable bh namecache = do
sz <- get bh
od_names <- replicateM sz (getHieName bh)
let arr = A.listArray (0,sz-1) names
(namecache', names) = mapAccumR fromHieName namecache od_names
return (namecache', 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 -> (nc, 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"
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module HieDebug where
import GhcPrelude
import SrcLoc
import Module
import FastString
import Outputable
import HieTypes
import HieBin
import 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 = []
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HieTypes where
import GhcPrelude
import Binary
import FastString ( FastString )
import IfaceType
import Module ( ModuleName )
import Name ( Name )
import Outputable hiding ( (<>) )
import SrcLoc ( RealSrcSpan )
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
-- | Current version of @.hie@ files
curHieVersion :: Word8
curHieVersion = 0
{- |
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