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
env <- getBkpEnv
time <- liftIO $ getModificationUTCTime (bkp_filename env)
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)
mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
......@@ -690,6 +691,7 @@ summariseRequirement pn mod_name = do
ms_hs_date = time,
ms_obj_date = Nothing,
ms_iface_date = hi_timestamp,
ms_hie_date = hie_timestamp,
ms_srcimps = [],
ms_textual_imps = extra_sig_imports,
ms_parsed_mod = Just (HsParsedModule {
......@@ -765,12 +767,13 @@ hsModuleToModSummary pn hsc_src modname
HsSrcFile -> "hs")
-- DANGEROUS: bootifying can POISON the module finder cache
let location = case hsc_src of
HsBootFile -> addBootSuffixLocn location0
HsBootFile -> addBootSuffixLocnOut location0
_ -> location0
-- This duplicates a pile of logic in GhcMake
env <- getBkpEnv
time <- liftIO $ getModificationUTCTime (bkp_filename env)
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
......@@ -815,7 +818,8 @@ hsModuleToModSummary pn hsc_src modname
}),
ms_hs_date = time,
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
......
......@@ -112,7 +112,8 @@ module Module
-- * The ModuleLocation type
ModLocation(..),
addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
addBootSuffix, addBootSuffix_maybe,
addBootSuffixLocn, addBootSuffixLocnOut,
-- * Module mappings
ModuleEnv,
......@@ -267,11 +268,12 @@ data ModLocation
-- yet. Always of form foo.hi, even if there is an
-- 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.
-- (might not exist either because the module hasn't
-- been compiled yet, or because it is part of a
-- package with a .a file)
ml_hie_file :: FilePath
} deriving Show
instance Outputable ModLocation where
......@@ -302,7 +304,16 @@ addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn
= locn { ml_hs_file = fmap addBootSuffix (ml_hs_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
typecheck
types
utils
hieFile
-- we use an explicit Prelude
Default-Extensions:
......@@ -179,6 +180,11 @@ Library
GhcPrelude
Exposed-Modules:
HieTypes
HieDebug
HieBin
HieUtils
HieAst
Ar
FileCleanup
DriverBkp
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
module HieAst ( mkHieFile ) where
import GhcPrelude
import Avail ( Avails )
import Bag ( Bag, bagToList )
import BasicTypes
import BooleanFormula
import Class ( FunDep )
import CoreUtils ( exprType )
import ConLike ( conLikeName )
import Config ( cProjectVersion )
import Desugar ( deSugarExpr )
import FieldLabel
import HsSyn
import HscTypes
import Module ( ModuleName, ml_hs_file )
import MonadUtils ( concatMapM, liftIO )
import Name ( Name, nameSrcSpan, setNameLoc )
import SrcLoc
import TcHsSyn ( hsPatType )
import Type ( Type )
import Var ( Id, Var, setVarName, varName, varType )
import HieTypes
import HieUtils
import qualified Data.Array as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Data ( Data, Typeable )
import Data.List ( foldl1' )
import Data.Maybe ( listToMaybe )
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class ( lift )
-- These synonyms match those defined in main/GHC.hs
type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
, Maybe [(LIE GhcRn, Avails)]
, Maybe LHsDocString )
type TypecheckedSource = LHsBinds GhcTc
{- Note [Name Remapping]
The Typechecker introduces new names for mono names in AbsBinds.
We don't care about the distinction between mono and poly bindings,
so we replace all occurrences of the mono name with the poly name.
-}
newtype HieState = HieState
{ name_remapping :: M.Map Name Id
}
initState :: HieState
initState = HieState M.empty
class ModifyState a where -- See Note [Name Remapping]
addSubstitution :: a -> a -> HieState -> HieState
instance ModifyState Name where
addSubstitution _ _ hs = hs
instance ModifyState Id where
addSubstitution mono poly hs =
hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}
modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
modifyState = foldr go id
where
go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
go _ f = f
type HieM = ReaderT HieState Hsc
-- | Construct an 'HieFile' from the outputs of the typechecker.
mkHieFile :: ModSummary -> TypecheckedSource -> RenamedSource -> Hsc HieFile
mkHieFile ms ts rs = do
(asts', arr) <- getCompressedAsts ts rs
let Just src_file = ml_hs_file $ ms_location ms
src <- liftIO $ BS.readFile src_file
return $ HieFile
{ hie_version = curHieVersion
, hie_ghc_version = BSC.pack cProjectVersion
, hie_hs_file = src_file
, hie_types = arr
, hie_asts = asts'
, hie_hs_src = src
}
getCompressedAsts :: TypecheckedSource -> RenamedSource
-> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
getCompressedAsts ts rs = do
asts <- enrichHie ts rs
return $ compressTypes asts
enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
rasts <- processGrp hsGrp
imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
exps <- toHie $ fmap (map $ IEC Export . fst) exports
let spanFile children = case children of
[] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
_ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
(realSrcSpanEnd $ nodeSpan $ last children)
modulify xs =
Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
asts = HieASTs
$ resolveTyVarScopes
$ M.map (modulify . mergeSortAsts)
$ M.fromListWith (++)
$ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
flat_asts = concat
[ tasts
, rasts
, imps
, exps
]
return asts
where
processGrp grp = concatM
[ toHie $ fmap (RS ModuleScope ) hs_valds grp
, toHie $ hs_splcds grp
, toHie $ hs_tyclds grp
, toHie $ hs_derivds grp
, toHie $ hs_fixds grp
, toHie $ hs_defds grp
, toHie $ hs_fords grp
, toHie $ hs_warnds grp
, toHie $ hs_annds grp
, toHie $ hs_ruleds grp
]
getRealSpan :: SrcSpan -> Maybe Span
getRealSpan (RealSrcSpan sp) = Just sp
getRealSpan _ = Nothing
grhss_span :: GRHSs p body -> SrcSpan
grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
grhss_span (XGRHSs _) = error "XGRHS has no span"
bindingsOnly :: [Context Name] -> [HieAST a]
bindingsOnly [] = []
bindingsOnly (C c n : xs) = case nameSrcSpan n of
RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
info = mempty{identInfo = S.singleton c}
_ -> bindingsOnly xs
concatM :: Monad m => [m [a]] -> m [a]
concatM xs = concat <$> sequence xs
{- Note [Capturing Scopes and other non local information]
toHie is a local tranformation, but scopes of bindings cannot be known locally,
hence we have to push the relevant info down into the binding nodes.
We use the following types (*Context and *Scoped) to wrap things and
carry the required info
(Maybe Span) always carries the span of the entire binding, including rhs
-}
data Context a = C ContextInfo a -- Used for names and bindings
data RContext a = RC RecFieldContext a
data RFContext a = RFC RecFieldContext (Maybe Span) a
-- ^ context for record fields
data IEContext a = IEC IEType a
-- ^ context for imports/exports
data BindContext a = BC BindType Scope a
-- ^ context for imports/exports
data PatSynFieldContext a = PSC (Maybe Span) a
-- ^ context for pattern synonym fields.
data SigContext a = SC SigInfo a
-- ^ context for type signatures
data SigInfo = SI SigType (Maybe Span)
data SigType = BindSig | ClassSig | InstSig
data RScoped a = RS Scope a
-- ^ Scope spans over everything to the right of a, (mostly) not
-- including a itself
-- (Includes a in a few special cases like recursive do bindings) or
-- let/where bindings
-- | Pattern scope
data PScoped a = PS (Maybe Span)
Scope -- ^ use site of the pattern
Scope -- ^ pattern to the right of a, not including a
a
deriving (Typeable, Data) -- Pattern Scope
{- Note [TyVar Scopes]
Due to -XScopedTypeVariables, type variables can be in scope quite far from
their original binding. We resolve the scope of these type variables
in a seperate pass
-}
data TScoped a = TS TyVarScope a -- TyVarScope
data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
-- ^ First scope remains constant
-- Second scope is used to build up the scope of a tyvar over
-- things to its right, ala RScoped
-- | Each element scopes over the elements to the right
listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
listScopes _ [] = []
listScopes rhsScope [pat] = [RS rhsScope pat]
listScopes rhsScope (pat : pats) = RS sc pat : pats'
where
pats'@((RS scope p):_) = listScopes rhsScope pats
sc = combineScopes scope $ mkScope $ getLoc p
-- | 'listScopes' specialised to 'PScoped' things
patScopes
:: Maybe Span
-> Scope
-> Scope
-> [LPat (GhcPass p)]
-> [PScoped (LPat (GhcPass p))]
patScopes rsp useScope patScope xs =
map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
listScopes patScope (map dL xs)
-- | 'listScopes' specialised to 'TVScoped' things
tvScopes
:: TyVarScope
-> Scope
-> [LHsTyVarBndr a]
-> [TVScoped (LHsTyVarBndr a)]
tvScopes tvScope rhsScope xs =
map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
{- Note [Scoping Rules for SigPat]
Explicitly quantified variables in pattern type signatures are not
brought into scope in the rhs, but implicitly quantified variables
are (HsWC and HsIB).
This is unlike other signatures, where explicitly quantified variables
are brought into the RHS Scope
For example
foo :: forall a. ...;
foo = ... -- a is in scope here
bar (x :: forall a. a -> a) = ... -- a is not in scope here
-- ^ a is in scope here (pattern body)
bax (x :: a) = ... -- a is in scope here
Because of HsWC and HsIB pass on their scope to their children
we must wrap the LHsType in pattern signatures in a
Shielded explictly, so that the HsWC/HsIB scope is not passed
on the the LHsType
-}
data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
type family ProtectedSig a where
ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
GhcRn
(Shielded (LHsType GhcRn)))
ProtectedSig GhcTc = NoExt
class ProtectSig a where
protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
instance (HasLoc a) => HasLoc (Shielded a) where
loc (SH _ a) = loc a
instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
instance ProtectSig GhcTc where
protectSig _ _ = NoExt
instance ProtectSig GhcRn where
protectSig sc (HsWC a (HsIB b sig)) =
HsWC a (HsIB b (SH sc sig))
protectSig _ _ = error "protectSig not given HsWC (HsIB)"
class HasLoc a where
-- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
-- know what their implicit bindings are scoping over
loc :: a -> SrcSpan
instance HasLoc thing => HasLoc (TScoped thing) where
loc (TS _ a) = loc a
instance HasLoc thing => HasLoc (PScoped thing) where
loc (PS _ _ _ a) = loc a
instance HasLoc (LHsQTyVars GhcRn) where
loc (HsQTvs _ vs) = loc vs
loc _ = noSrcSpan
instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
loc (HsIB _ a) = loc a
loc _ = noSrcSpan
instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
loc (HsWC _ a) = loc a
loc _ = noSrcSpan
instance HasLoc (Located a) where
loc (L l _) = l
instance HasLoc a => HasLoc [a] where
loc [] = noSrcSpan
loc xs = foldl1' combineSrcSpans $ map loc xs
instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
[loc a, loc tvs, loc b, loc c]
loc _ = noSrcSpan
instance HasLoc (HsDataDefn GhcRn) where
loc def@(HsDataDefn{}) = loc $ dd_cons def
-- Only used for data family instances, so we only need rhs
-- Most probably the rest will be unhelpful anyway
loc _ = noSrcSpan
instance HasLoc (Pat (GhcPass a)) where
loc (dL -> L l _) = l
-- | The main worker class
class ToHie a where
toHie :: a -> HieM [HieAST Type]
-- | Used to collect type info
class Data a => HasType a where
getTypeNode :: a -> HieM [HieAST Type]
instance (ToHie a) => ToHie [a] where
toHie = concatMapM toHie
instance (ToHie a) => ToHie (Bag a) where
toHie = toHie . bagToList
instance (ToHie a) => ToHie (Maybe a) where
toHie = maybe (pure []) toHie
instance ToHie (Context (Located NoExt)) where
toHie _ = pure []
instance ToHie (TScoped NoExt) where
toHie _ = pure []
instance ToHie (IEContext (Located ModuleName)) where
toHie (IEC c (L (RealSrcSpan span) mname)) =
pure $ [Node (NodeInfo S.empty [] idents) span []]
where details = mempty{identInfo = S.singleton (IEThing c)}
idents = M.singleton (Left mname) details
toHie _ = pure []
instance ToHie (Context (Located Var)) where
toHie c = case c of
C context (L (RealSrcSpan span) name')
-> do
m <- asks name_remapping
let name = M.findWithDefault name' (varName name') m
pure
[Node
(NodeInfo S.empty [] $
M.singleton (Right $ varName name)
(IdentifierDetails (Just $ varType name')
(S.singleton context)))
span
[]]
_ -> pure []
instance ToHie (Context (Located Name)) where
toHie c = case c of
C context (L (RealSrcSpan span) name') -> do
m <- asks name_remapping
let name = case M.lookup name' m of
Just var -> varName var
Nothing -> name'
pure
[Node
(NodeInfo S.empty [] $
M.singleton (Right name)
(IdentifierDetails Nothing
(S.singleton context)))
span
[]]
_ -> pure []
-- | Dummy instances - never called
instance ToHie (TScoped (LHsSigWcType GhcTc)) where
toHie _ = pure []
instance ToHie (TScoped (LHsWcType GhcTc)) where
toHie _ = pure []
instance ToHie (SigContext (LSig GhcTc)) where
toHie _ = pure []
instance ToHie (TScoped Type) where
toHie _ = pure []
instance HasType (LHsBind GhcRn) where
getTypeNode (L spn bind) = makeNode bind spn
instance HasType (LHsBind GhcTc) where
getTypeNode (L spn bind) = case bind of
FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
_ -> makeNode bind spn
instance HasType (LPat GhcRn) where
getTypeNode (dL -> L spn pat) = makeNode pat spn
instance HasType (LPat GhcTc) where
getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
instance HasType (LHsExpr GhcRn) where
getTypeNode (L spn e) = makeNode e spn
instance HasType (LHsExpr GhcTc) where
getTypeNode e@(L spn e') = lift $ do
hs_env <- Hsc $ \e w -> return (e,w)
(_,mbe) <- liftIO $ deSugarExpr hs_env e
case mbe of
Just te -> makeTypeNode e' spn (exprType te)
Nothing -> makeNode e' spn
instance ( ToHie (Context (Located (IdP a)))
, ToHie (MatchGroup a (LHsExpr a))
, ToHie (PScoped (LPat a))
, ToHie (GRHSs a (LHsExpr a))
, ToHie (LHsExpr a)
, ToHie (Located (PatSynBind a a))
, HasType (LHsBind a)
, ModifyState (IdP a)
, Data (HsBind a)
) => ToHie (BindContext (LHsBind a)) where
toHie (BC context scope b@(L span bind)) =
concatM $ getTypeNode b : case bind of
FunBind{fun_id = name, fun_matches = matches} ->
[ toHie $ C (ValBind context scope $ getRealSpan span) name
, toHie matches
]
PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
[ toHie $ PS (getRealSpan span) scope NoScope lhs
, toHie rhs
]
VarBind{var_rhs = expr} ->
[ toHie expr
]
AbsBinds{abs_exports = xs, abs_binds = binds} ->
[ local (modifyState xs) $ -- Note [Name Remapping]
toHie $ fmap (BC context scope) binds
]
PatSynBind _ psb ->
[ toHie $ L span psb -- PatSynBinds only occur at the top level
]
XHsBindsLR _ -> []
instance ( ToHie (LMatch a body)
) => ToHie (MatchGroup a body) where
toHie mg = concatM $ case mg of
MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
[ pure $ locOnly span
, toHie alts
]
MG{} -> []
XMatchGroup _ -> []
instance ( ToHie (Context (Located (IdP a)))
, ToHie (PScoped (LPat a))
, ToHie (HsPatSynDir a)
) => ToHie (Located (PatSynBind a a)) where
toHie (L sp psb) = concatM $ case psb of
PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
[ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
, toHie $ toBind dets
, toHie $ PS Nothing lhsScope NoScope pat
, toHie dir
]
where
lhsScope = combineScopes varScope detScope
varScope = mkLScope var
detScope = case dets of
(PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
(InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
(RecCon r) -> foldr go NoScope r