[Git][ghc/ghc][master] Add info about typeclass evidence to .hie files
Marge Bot
gitlab at gitlab.haskell.org
Tue May 26 07:03:39 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
53814a64 by Zubin Duggal at 2020-05-26T03:03:24-04:00
Add info about typeclass evidence to .hie files
See `testsuite/tests/hiefile/should_run/HieQueries.hs` and
`testsuite/tests/hiefile/should_run/HieQueries.stdout` for an example of this
We add two new fields, `EvidenceVarBind` and `EvidenceVarUse` to the
`ContextInfo` associated with an Identifier. These are associated with the
appropriate identifiers for the evidence variables collected when we come across
`HsWrappers`, `TcEvBinds` and `IPBinds` while traversing the AST.
Instance dictionary and superclass selector dictionaries from `tcg_insts` and
classes defined in `tcg_tcs` are also recorded in the AST as originating from
their definition span
This allows us to save a complete picture of the evidence constructed by the
constraint solver, and will let us report this to the user, enabling features
like going to the instance definition from the invocation of a class method(or
any other method taking a constraint) and finding all usages of a particular
instance.
Additionally,
- Mark NodeInfo with an origin so we can differentiate between bindings
origininating in the source vs those in ghc
- Along with typeclass evidence info, also include information on Implicit
Parameters
- Add a few utility functions to HieUtils in order to query the new info
Updates haddock submodule
- - - - -
11 changed files:
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Debug.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Iface/Ext/Utils.hs
- testsuite/tests/hiefile/should_compile/Scopes.hs
- + testsuite/tests/hiefile/should_run/HieQueries.hs
- + testsuite/tests/hiefile/should_run/HieQueries.stdout
- testsuite/tests/hiefile/should_run/PatTypes.hs
- testsuite/tests/hiefile/should_run/all.T
- utils/haddock
Changes:
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -13,36 +13,47 @@ Main functions for .hie file generation
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where
+import GHC.Utils.Outputable(ppr)
+
import GHC.Prelude
import GHC.Types.Avail ( Avails )
import GHC.Data.Bag ( Bag, bagToList )
import GHC.Types.Basic
import GHC.Data.BooleanFormula
-import GHC.Core.Class ( FunDep )
+import GHC.Core.Class ( FunDep, className, classSCSelIds )
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike ( conLikeName )
+import GHC.Core.TyCon ( TyCon, tyConClass_maybe )
+import GHC.Core.FVs
import GHC.HsToCore ( deSugarExpr )
import GHC.Types.FieldLabel
import GHC.Hs
import GHC.Driver.Types
import GHC.Unit.Module ( ModuleName, ml_hs_file )
import GHC.Utils.Monad ( concatMapM, liftIO )
-import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc )
+import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc, nameUnique )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
import GHC.Types.SrcLoc
import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType )
import GHC.Core.Type ( mkVisFunTys, Type )
+import GHC.Core.Predicate
+import GHC.Core.InstEnv
import GHC.Builtin.Types ( mkListTy, mkSumTy )
-import GHC.Types.Var ( Id, Var, setVarName, varName, varType )
import GHC.Tc.Types
+import GHC.Tc.Types.Evidence
+import GHC.Types.Var ( Id, Var, EvId, setVarName, varName, varType, varUnique )
+import GHC.Types.Var.Env
+import GHC.Types.Unique
import GHC.Iface.Make ( mkIfaceExports )
import GHC.Utils.Panic
import GHC.Data.Maybe
+import GHC.Data.FastString
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
@@ -53,6 +64,8 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.Data ( Data, Typeable )
import Data.List ( foldl1' )
+import Control.Monad ( forM_ )
+import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class ( lift )
@@ -196,12 +209,47 @@ 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
+type VarMap a = DVarEnv (Var,a)
+data HieState = HieState
{ name_remapping :: NameEnv Id
+ , unlocated_ev_binds :: VarMap (S.Set ContextInfo)
+ -- These contain evidence bindings that we don't have a location for
+ -- These are placed at the top level Node in the HieAST after everything
+ -- else has been generated
+ -- This includes things like top level evidence bindings.
}
+addUnlocatedEvBind :: Var -> ContextInfo -> HieM ()
+addUnlocatedEvBind var ci = do
+ let go (a,b) (_,c) = (a,S.union b c)
+ lift $ modify' $ \s ->
+ s { unlocated_ev_binds =
+ extendDVarEnv_C go (unlocated_ev_binds s)
+ var (var,S.singleton ci)
+ }
+
+getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type])
+getUnlocatedEvBinds file = do
+ binds <- lift $ gets unlocated_ev_binds
+ org <- ask
+ let elts = dVarEnvElts binds
+
+ mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci)
+
+ go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of
+ RealSrcSpan spn _
+ | srcSpanFile spn == file ->
+ let node = Node (mkSourcedNodeInfo org ni) spn []
+ ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e]
+ in (xs,node:ys)
+ _ -> (mkNodeInfo e : xs,ys)
+
+ (nis,asts) = foldr go ([],[]) elts
+
+ pure $ (M.fromList nis, asts)
+
initState :: HieState
-initState = HieState emptyNameEnv
+initState = HieState emptyNameEnv emptyDVarEnv
class ModifyState a where -- See Note [Name Remapping]
addSubstitution :: a -> a -> HieState -> HieState
@@ -216,10 +264,11 @@ instance ModifyState Id where
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 ABE{abe_poly=poly,abe_mono=mono} f
+ = addSubstitution mono poly . f
go _ f = f
-type HieM = ReaderT HieState Hsc
+type HieM = ReaderT NodeOrigin (StateT HieState Hsc)
-- | Construct an 'HieFile' from the outputs of the typechecker.
mkHieFile :: ModSummary
@@ -239,7 +288,10 @@ mkHieFileWithSource :: FilePath
-> RenamedSource -> Hsc HieFile
mkHieFileWithSource src_file src ms ts rs = do
let tc_binds = tcg_binds ts
- (asts', arr) <- getCompressedAsts tc_binds rs
+ top_ev_binds = tcg_ev_binds ts
+ insts = tcg_insts ts
+ tcs = tcg_tcs ts
+ (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs
return $ HieFile
{ hie_hs_file = src_file
, hie_module = ms_mod ms
@@ -250,38 +302,70 @@ mkHieFileWithSource src_file src ms ts rs = do
, hie_hs_src = src
}
-getCompressedAsts :: TypecheckedSource -> RenamedSource
+getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
-> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
-getCompressedAsts ts rs = do
- asts <- enrichHie ts rs
+getCompressedAsts ts rs top_ev_binds insts tcs = do
+ asts <- enrichHie ts rs top_ev_binds insts tcs
return $ compressTypes asts
-enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
-enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
+enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
+ -> Hsc (HieASTs Type)
+enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
+ flip evalStateT initState $ flip runReaderT SourceInfo $ 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)
+ -- Add Instance bindings
+ forM_ insts $ \i ->
+ addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing)
+ -- Add class parent bindings
+ forM_ tcs $ \tc ->
+ case tyConClass_maybe tc of
+ Nothing -> pure ()
+ Just c -> forM_ (classSCSelIds c) $ \v ->
+ addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing)
+ let spanFile file children = case children of
+ [] -> realSrcLocSpan (mkRealSrcLoc file 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
]
+
+ modulify file xs' = do
+
+ top_ev_asts <-
+ toHie $ EvBindContext ModuleScope Nothing
+ $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)
+ $ EvBinds ev_bs
+
+ (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file
+
+ let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts
+ span = spanFile file xs
+
+ moduleInfo = SourcedNodeInfo
+ $ M.singleton SourceInfo
+ $ (simpleNodeInfo "Module" "Module")
+ {nodeIdentifiers = uloc_evs}
+
+ moduleNode = Node moduleInfo span []
+
+ case mergeSortAsts $ moduleNode : xs of
+ [x] -> return x
+ xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs)
+
+ asts' <- sequence
+ $ M.mapWithKey modulify
+ $ M.fromListWith (++)
+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
+
+ let asts = HieASTs $ resolveTyVarScopes asts'
return asts
where
processGrp grp = concatM
@@ -305,13 +389,16 @@ grhss_span :: GRHSs p body -> SrcSpan
grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
grhss_span (XGRHSs _) = panic "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
+bindingsOnly :: [Context Name] -> HieM [HieAST a]
+bindingsOnly [] = pure []
+bindingsOnly (C c n : xs) = do
+ org <- ask
+ rest <- bindingsOnly xs
+ pure $ case nameSrcSpan n of
+ RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest
+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
+ info = mempty{identInfo = S.singleton c}
+ _ -> rest
concatM :: Monad m => [m [a]] -> m [a]
concatM xs = concat <$> sequence xs
@@ -345,6 +432,8 @@ data SigInfo = SI SigType (Maybe Span)
data SigType = BindSig | ClassSig | InstSig
+data EvBindContext a = EvBindContext Scope (Maybe Span) a
+
data RScoped a = RS Scope a
-- ^ Scope spans over everything to the right of a, (mostly) not
-- including a itself
@@ -502,8 +591,9 @@ instance ToHie (TScoped NoExtField) where
toHie _ = pure []
instance ToHie (IEContext (Located ModuleName)) where
- toHie (IEC c (L (RealSrcSpan span _) mname)) =
- pure $ [Node (NodeInfo S.empty [] idents) span []]
+ toHie (IEC c (L (RealSrcSpan span _) mname)) = do
+ org <- ask
+ pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]
where details = mempty{identInfo = S.singleton (IEThing c)}
idents = M.singleton (Left mname) details
toHie _ = pure []
@@ -511,38 +601,90 @@ instance ToHie (IEContext (Located ModuleName)) where
instance ToHie (Context (Located Var)) where
toHie c = case c of
C context (L (RealSrcSpan span _) name')
- -> do
- m <- asks name_remapping
- let name = case lookupNameEnv m (varName name') of
- Just var -> var
- Nothing-> name'
- pure
- [Node
- (NodeInfo S.empty [] $
- M.singleton (Right $ varName name)
- (IdentifierDetails (Just $ varType name')
- (S.singleton context)))
- span
- []]
+ | varUnique name' == mkBuiltinUnique 1 -> pure []
+ -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
+ | otherwise -> do
+ m <- lift $ gets name_remapping
+ org <- ask
+ let name = case lookupNameEnv m (varName name') of
+ Just var -> var
+ Nothing-> name'
+ pure
+ [Node
+ (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
+ M.singleton (Right $ varName name)
+ (IdentifierDetails (Just $ varType name')
+ (S.singleton context)))
+ span
+ []]
+ C (EvidenceVarBind i _ sp) (L _ name) -> do
+ addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
+ pure []
_ -> 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 lookupNameEnv m name' of
- Just var -> varName var
- Nothing -> name'
- pure
- [Node
- (NodeInfo S.empty [] $
- M.singleton (Right name)
- (IdentifierDetails Nothing
- (S.singleton context)))
- span
- []]
+ C context (L (RealSrcSpan span _) name')
+ | nameUnique name' == mkBuiltinUnique 1 -> pure []
+ -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
+ | otherwise -> do
+ m <- lift $ gets name_remapping
+ org <- ask
+ let name = case lookupNameEnv m name' of
+ Just var -> varName var
+ Nothing -> name'
+ pure
+ [Node
+ (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
+ M.singleton (Right name)
+ (IdentifierDetails Nothing
+ (S.singleton context)))
+ span
+ []]
_ -> pure []
+evVarsOfTermList :: EvTerm -> [EvId]
+evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e
+evVarsOfTermList (EvTypeable _ ev) =
+ case ev of
+ EvTypeableTyCon _ e -> concatMap evVarsOfTermList e
+ EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2]
+ EvTypeableTrFun e1 e2 -> concatMap evVarsOfTermList [e1,e2]
+ EvTypeableTyLit e -> evVarsOfTermList e
+evVarsOfTermList (EvFun{}) = []
+
+instance ToHie (EvBindContext (Located TcEvBinds)) where
+ toHie (EvBindContext sc sp (L span (EvBinds bs)))
+ = concatMapM go $ bagToList bs
+ where
+ go evbind = do
+ let evDeps = evVarsOfTermList $ eb_rhs evbind
+ depNames = EvBindDeps $ map varName evDeps
+ concatM $
+ [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp)
+ (L span $ eb_lhs evbind))
+ , toHie $ map (C EvidenceVarUse . L span) $ evDeps
+ ]
+ toHie _ = pure []
+
+instance ToHie (EvBindContext (Located NoExtField)) where
+ toHie _ = pure []
+
+instance ToHie (Located HsWrapper) where
+ toHie (L osp wrap)
+ = case wrap of
+ (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs)
+ (WpCompose a b) -> concatM $
+ [toHie (L osp a), toHie (L osp b)]
+ (WpFun a b _ _) -> concatM $
+ [toHie (L osp a), toHie (L osp b)]
+ (WpEvLam a) ->
+ toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp))
+ $ L osp a
+ (WpEvApp a) ->
+ concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a
+ _ -> pure []
+
-- | Dummy instances - never called
instance ToHie (TScoped (LHsSigWcType GhcTc)) where
toHie _ = pure []
@@ -586,7 +728,7 @@ instance HasType (LHsExpr GhcRn) where
--
-- See #16233
instance HasType (LHsExpr GhcTc) where
- getTypeNode e@(L spn e') = lift $
+ getTypeNode e@(L spn e') =
-- Some expression forms have their type immediately available
let tyOpt = case e' of
HsLit _ l -> Just (hsLitType l)
@@ -609,7 +751,7 @@ instance HasType (LHsExpr GhcTc) where
Nothing
| skipDesugaring e' -> fallback
| otherwise -> do
- hs_env <- Hsc $ \e w -> return (e,w)
+ hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w)
(_,mbe) <- liftIO $ deSugarExpr hs_env e
maybe fallback (makeTypeNode e' spn . exprType) mbe
where
@@ -634,21 +776,25 @@ instance HasType (LHsExpr GhcTc) where
XExpr (HsWrap{}) -> False
_ -> True
-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
+instance ( ToHie (Context (Located (IdP (GhcPass a))))
+ , ToHie (MatchGroup (GhcPass a) (LHsExpr (GhcPass a)))
+ , ToHie (PScoped (LPat (GhcPass a)))
+ , ToHie (GRHSs (GhcPass a) (LHsExpr (GhcPass a)))
+ , ToHie (LHsExpr (GhcPass a))
+ , ToHie (Located (PatSynBind (GhcPass a) (GhcPass a)))
+ , HasType (LHsBind (GhcPass a))
+ , ModifyState (IdP (GhcPass a))
+ , Data (HsBind (GhcPass a))
+ , IsPass a
+ ) => ToHie (BindContext (LHsBind (GhcPass a))) where
toHie (BC context scope b@(L span bind)) =
concatM $ getTypeNode b : case bind of
- FunBind{fun_id = name, fun_matches = matches} ->
+ FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->
[ toHie $ C (ValBind context scope $ getRealSpan span) name
, toHie matches
+ , case ghcPass @a of
+ GhcTc -> toHie $ L span wrap
+ _ -> pure []
]
PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
[ toHie $ PS (getRealSpan span) scope NoScope lhs
@@ -657,39 +803,55 @@ instance ( ToHie (Context (Located (IdP a)))
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
+ AbsBinds{ abs_exports = xs, abs_binds = binds
+ , abs_ev_binds = ev_binds
+ , abs_ev_vars = ev_vars } ->
+ [ lift (modify (modifyState xs)) >> -- Note [Name Remapping]
+ (toHie $ fmap (BC context scope) binds)
+ , toHie $ map (L span . abe_wrap) xs
+ , toHie $
+ map (EvBindContext (mkScope span) (getRealSpan span)
+ . L span) ev_binds
+ , toHie $
+ map (C (EvidenceVarBind EvSigBind
+ (mkScope span)
+ (getRealSpan span))
+ . L span) ev_vars
]
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 _ -> []
+ toHie mg = case mg of
+ MG{ mg_alts = (L span alts) , mg_origin = origin} ->
+ local (setOrigin origin) $ concatM
+ [ locOnly span
+ , toHie alts
+ ]
+ XMatchGroup _ -> pure []
+
+setOrigin :: Origin -> NodeOrigin -> NodeOrigin
+setOrigin FromSource _ = SourceInfo
+setOrigin Generated _ = GeneratedInfo
instance ( ToHie (Context (Located (IdP a)))
, ToHie (PScoped (LPat a))
, ToHie (HsPatSynDir a)
+ , (a ~ GhcPass p)
) => 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 $ PS Nothing lhsScope patScope pat
, toHie dir
]
where
lhsScope = combineScopes varScope detScope
varScope = mkLScope var
+ patScope = mkScope $ getLoc pat
detScope = case dets of
(PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
(InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
@@ -702,7 +864,6 @@ instance ( ToHie (Context (Located (IdP a)))
toBind (PrefixCon args) = PrefixCon $ map (C Use) args
toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
toBind (RecCon r) = RecCon $ map (PSC detSpan) r
- XPatSynBind _ -> []
instance ( ToHie (MatchGroup a (LHsExpr a))
) => ToHie (HsPatSynDir a) where
@@ -780,12 +941,24 @@ instance ( a ~ GhcPass p
SumPat _ pat _ _ ->
[ toHie $ PS rsp scope pscope pat
]
- ConPat {pat_con = con, pat_args = dets}->
+ ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext}->
[ case ghcPass @p of
GhcPs -> toHie $ C Use $ con
GhcRn -> toHie $ C Use $ con
GhcTc -> toHie $ C Use $ fmap conLikeName con
, toHie $ contextify dets
+ , case ghcPass @p of
+ GhcTc ->
+ let ev_binds = cpt_binds ext
+ ev_vars = cpt_dicts ext
+ wrap = cpt_wrap ext
+ evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope
+ in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds
+ , toHie $ L ospan wrap
+ , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
+ . L ospan) ev_vars
+ ]
+ _ -> pure []
]
ViewPat _ expr pat ->
[ toHie expr
@@ -816,10 +989,12 @@ instance ( a ~ GhcPass p
GhcPs -> noExtCon e
GhcRn -> noExtCon e
#endif
- GhcTc -> []
+ GhcTc ->
+ [ toHie $ L ospan wrap
+ , toHie $ PS rsp scope pscope $ (L ospan pat :: LPat a)
+ ]
where
- -- Make sure we get an error if this changes
- _noWarn@(CoPat _ _ _) = e
+ CoPat wrap pat _ = e
where
contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
contextify (InfixCon a b) = InfixCon a' b'
@@ -833,7 +1008,7 @@ instance ( a ~ GhcPass p
instance ToHie (TScoped (HsPatSigType GhcRn)) where
toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
- [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
+ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
, toHie body
]
-- See Note [Scoping Rules for SigPat]
@@ -850,15 +1025,14 @@ instance ( ToHie body
XGRHSs _ -> []
instance ( ToHie (Located body)
- , ToHie (RScoped (GuardLStmt a))
- , Data (GRHS a (Located body))
- ) => ToHie (LGRHS a (Located body)) where
+ , ToHie (RScoped (GuardLStmt (GhcPass a)))
+ , Data (GRHS (GhcPass a) (Located body))
+ ) => ToHie (LGRHS (GhcPass a) (Located body)) where
toHie (L span g) = concatM $ makeNode g span : case g of
GRHS _ guards body ->
[ toHie $ listScopes (mkLScope body) guards
, toHie body
]
- XGRHS _ -> []
instance ( a ~ GhcPass p
, ToHie (Context (Located (IdP a)))
@@ -954,7 +1128,7 @@ instance ( a ~ GhcPass p
, toHie expr
]
HsDo _ _ (L ispan stmts) ->
- [ pure $ locOnly ispan
+ [ locOnly ispan
, toHie $ listScopes NoScope stmts
]
ExplicitList _ _ exprs ->
@@ -1008,9 +1182,10 @@ instance ( a ~ GhcPass p
]
XExpr x
| GhcTc <- ghcPass @p
- , HsWrap _ a <- x
- -> [ toHie $ L mspan a ]
-
+ , HsWrap w a <- x
+ -> [ toHie $ L mspan a
+ , toHie (L mspan w)
+ ]
| otherwise
-> []
@@ -1070,17 +1245,37 @@ instance ( ToHie (LHsExpr a)
, ToHie (BindContext (LHsBind a))
, ToHie (SigContext (LSig a))
, ToHie (RScoped (HsValBindsLR a a))
+ , ToHie (EvBindContext (Located (XIPBinds a)))
+ , ToHie (RScoped (LIPBind a))
, Data (HsLocalBinds a)
) => ToHie (RScoped (LHsLocalBinds a)) where
toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
EmptyLocalBinds _ -> []
- HsIPBinds _ _ -> []
+ HsIPBinds _ ipbinds -> case ipbinds of
+ IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in
+ [ toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds
+ , toHie $ map (RS sc) xs
+ ]
+ XHsIPBinds _ -> []
HsValBinds _ valBinds ->
[ toHie $ RS (combineScopes scope $ mkScope sp)
valBinds
]
XHsLocalBindsLR _ -> []
+instance ( ToHie (LHsExpr a)
+ , ToHie (Context (Located (IdP a)))
+ , Data (IPBind a)
+ ) => ToHie (RScoped (LIPBind a)) where
+ toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of
+ IPBind _ (Left _) expr -> [toHie expr]
+ IPBind _ (Right v) expr ->
+ [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp))
+ $ L sp v
+ , toHie expr
+ ]
+ XIPBind _ -> []
+
instance ( ToHie (BindContext (LHsBind a))
, ToHie (SigContext (LSig a))
, ToHie (RScoped (XXValBindsLR a a))
@@ -1160,6 +1355,7 @@ instance ( a ~ GhcPass p
, ToHie (LHsExpr a)
, ToHie (SigContext (LSig a))
, ToHie (RScoped (HsValBindsLR a a))
+ , ToHie (RScoped (ExprLStmt a))
, Data (StmtLR a a (Located (HsExpr a)))
, Data (HsLocalBinds a)
) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
@@ -1193,6 +1389,7 @@ instance ( a ~ GhcPass p
, ToHie (MatchGroup a (LHsCmd a))
, ToHie (SigContext (LSig a))
, ToHie (RScoped (HsValBindsLR a a))
+ , ToHie (RScoped (LHsLocalBinds a))
, Data (HsCmd a)
, Data (HsCmdTop a)
, Data (StmtLR a a (Located (HsCmd a)))
@@ -1235,7 +1432,7 @@ instance ( a ~ GhcPass p
, toHie cmd'
]
HsCmdDo _ (L ispan stmts) ->
- [ pure $ locOnly ispan
+ [ locOnly ispan
, toHie $ listScopes NoScope stmts
]
XCmd _ -> []
@@ -1289,7 +1486,7 @@ instance ToHie (LTyClDecl GhcRn) where
, toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
, toHie $ fmap (BC InstanceBind ModuleScope) meths
, toHie typs
- , concatMapM (pure . locOnly . getLoc) deftyps
+ , concatMapM (locOnly . getLoc) deftyps
, toHie deftyps
]
where
@@ -1313,7 +1510,7 @@ instance ToHie (LFamilyDecl GhcRn) where
instance ToHie (FamilyInfo GhcRn) where
toHie (ClosedTypeFamily (Just eqns)) = concatM $
- [ concatMapM (pure . locOnly . getLoc) eqns
+ [ concatMapM (locOnly . getLoc) eqns
, toHie $ map go eqns
]
where
@@ -1371,7 +1568,7 @@ instance ToHie (HsDataDefn GhcRn) where
instance ToHie (HsDeriving GhcRn) where
toHie (L span clauses) = concatM
- [ pure $ locOnly span
+ [ locOnly span
, toHie clauses
]
@@ -1379,7 +1576,7 @@ instance ToHie (LHsDerivingClause GhcRn) where
toHie (L span cl) = concatM $ makeNode cl span : case cl of
HsDerivingClause _ strat (L ispan tys) ->
[ toHie strat
- , pure $ locOnly ispan
+ , locOnly ispan
, toHie $ map (TS (ResolvedScopes [])) tys
]
@@ -1391,14 +1588,14 @@ instance ToHie (Located (DerivStrategy GhcRn)) where
ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
instance ToHie (Located OverlapMode) where
- toHie (L span _) = pure $ locOnly span
+ toHie (L span _) = locOnly span
instance ToHie (LConDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars
, con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
[ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
- , concatM $ [ pure $ bindingsOnly bindings
+ , concatM $ [ bindingsOnly bindings
, toHie $ tvScopes resScope NoScope exp_vars ]
, toHie ctx
, toHie args
@@ -1429,7 +1626,7 @@ instance ToHie (LConDecl GhcRn) where
instance ToHie (Located [LConDeclField GhcRn]) where
toHie (L span decls) = concatM $
- [ pure $ locOnly span
+ [ locOnly span
, toHie decls
]
@@ -1437,7 +1634,7 @@ instance ( HasLoc thing
, ToHie (TScoped thing)
) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
toHie (TS sc (HsIB ibrn a)) = concatM $
- [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
+ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
, toHie $ TS sc a
]
where span = loc a
@@ -1446,7 +1643,7 @@ instance ( HasLoc thing
, ToHie (TScoped thing)
) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
toHie (TS sc (HsWC names a)) = concatM $
- [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
+ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
, toHie $ TS sc a
]
where span = loc a
@@ -1496,10 +1693,10 @@ instance ToHie (SigContext (LSig GhcRn)) where
]
SCCFunSig _ _ name mtxt ->
[ toHie $ (C Use) name
- , pure $ maybe [] (locOnly . getLoc) mtxt
+ , maybe (pure []) (locOnly . getLoc) mtxt
]
CompleteMatchSig _ _ (L ispan names) typ ->
- [ pure $ locOnly ispan
+ [ locOnly ispan
, toHie $ map (C Use) names
, toHie $ fmap (C Use) typ
]
@@ -1583,7 +1780,7 @@ instance ToHie (TScoped (LHsType GhcRn)) where
instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
toHie (HsValArg tm) = toHie tm
toHie (HsTypeArg _ ty) = toHie ty
- toHie (HsArgPar sp) = pure $ locOnly sp
+ toHie (HsArgPar sp) = locOnly sp
instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where
toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
@@ -1597,7 +1794,7 @@ instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where
instance ToHie (TScoped (LHsQTyVars GhcRn)) where
toHie (TS sc (HsQTvs implicits vars)) = concatM $
- [ pure $ bindingsOnly bindings
+ [ bindingsOnly bindings
, toHie $ tvScopes sc NoScope vars
]
where
@@ -1606,7 +1803,7 @@ instance ToHie (TScoped (LHsQTyVars GhcRn)) where
instance ToHie (LHsContext GhcRn) where
toHie (L span tys) = concatM $
- [ pure $ locOnly span
+ [ locOnly span
, toHie tys
]
@@ -1679,7 +1876,7 @@ instance ( a ~ GhcPass p
[ toHie expr
]
HsQuasiQuote _ _ _ ispan _ ->
- [ pure $ locOnly ispan
+ [ locOnly ispan
]
HsSpliced _ _ _ ->
[]
@@ -1695,7 +1892,7 @@ instance ToHie (LRoleAnnotDecl GhcRn) where
toHie (L span annot) = concatM $ makeNode annot span : case annot of
RoleAnnotDecl _ var roles ->
[ toHie $ C Use var
- , concatMapM (pure . locOnly . getLoc) roles
+ , concatMapM (locOnly . getLoc) roles
]
instance ToHie (LInstDecl GhcRn) where
@@ -1715,9 +1912,9 @@ instance ToHie (LClsInstDecl GhcRn) where
[ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
, toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
, toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
- , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
+ , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl
, toHie $ cid_tyfam_insts decl
- , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
+ , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl
, toHie $ cid_datafam_insts decl
, toHie $ cid_overlap_mode decl
]
@@ -1769,14 +1966,14 @@ instance ToHie (LForeignDecl GhcRn) where
]
instance ToHie ForeignImport where
- toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $
[ locOnly a
, locOnly b
, locOnly c
]
instance ToHie ForeignExport where
- toHie (CExport (L a _) (L b _)) = pure $ concat $
+ toHie (CExport (L a _) (L b _)) = concatM $
[ locOnly a
, locOnly b
]
@@ -1814,7 +2011,7 @@ instance ToHie (LRuleDecls GhcRn) where
instance ToHie (LRuleDecl GhcRn) where
toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
[ makeNode r span
- , pure $ locOnly $ getLoc rname
+ , locOnly $ getLoc rname
, toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
, toHie $ map (RS $ mkScope span) bndrs
, toHie exprA
@@ -1844,7 +2041,7 @@ instance ToHie (LImportDecl GhcRn) where
]
where
goIE (hiding, (L sp liens)) = concatM $
- [ pure $ locOnly sp
+ [ locOnly sp
, toHie $ map (IEC c) liens
]
where
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -23,7 +23,6 @@ import GHC.Utils.Binary
import GHC.Iface.Binary ( getDictFastString )
import GHC.Data.FastMutInt
import GHC.Data.FastString ( FastString )
-import GHC.Unit.Module ( Module )
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Utils.Outputable
@@ -32,7 +31,6 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique.Supply ( takeUniqFromSupply )
import GHC.Types.Unique
import GHC.Types.Unique.FM
-import GHC.Utils.Misc
import GHC.Iface.Env (NameCacheUpdater(..))
import qualified Data.Array as A
@@ -48,42 +46,6 @@ import System.FilePath ( takeDirectory )
import GHC.Iface.Ext.Types
--- | `Name`'s get converted into `HieName`'s before being written into @.hie@
--- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
--- these two types.
-data HieName
- = ExternalName !Module !OccName !SrcSpan
- | LocalName !OccName !SrcSpan
- | KnownKeyName !Unique
- deriving (Eq)
-
-instance Ord HieName where
- compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` SrcLoc.leftmost_smallest c f
- -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
- compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` SrcLoc.leftmost_smallest b d
- -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
- compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
- -- Not actually non deterministic as it is a KnownKey
- compare ExternalName{} _ = LT
- compare LocalName{} ExternalName{} = GT
- compare LocalName{} _ = LT
- compare KnownKeyName{} _ = GT
-
-instance Outputable HieName where
- ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
- ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
- ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
-
-hieNameOcc :: HieName -> OccName
-hieNameOcc (ExternalName _ occ _) = occ
-hieNameOcc (LocalName occ _) = occ
-hieNameOcc (KnownKeyName u) =
- case lookupKnownKeyName u of
- Just n -> nameOccName n
- Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
- (ppr (unpkUnique u))
-
-
data HieSymbolTable = HieSymbolTable
{ hie_symtab_next :: !FastMutInt
, hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))
@@ -352,14 +314,6 @@ putName (HieSymbolTable next ref) bh name = do
-- ** 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
=====================================
compiler/GHC/Iface/Ext/Debug.hs
=====================================
@@ -15,7 +15,6 @@ import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Iface.Ext.Types
-import GHC.Iface.Ext.Binary
import GHC.Iface.Ext.Utils
import GHC.Types.Name
@@ -39,17 +38,18 @@ diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
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
- infoDiff = case infoDiff' of
+ infoDiff' i1 i2
+ = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2
+ ++ (diffList diffType `on` nodeType) i1 i2
+ ++ (diffIdents `on` nodeIdentifiers) i1 i2
+ sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo)
+ infoDiff = case sinfoDiff info1 info2 of
[] -> []
- xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)
- , "and", ppr (nodeIdentifiers info2,span2)
+ xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1)
+ , "and", ppr (sourcedNodeIdents info2,span2)
, "While comparing"
- , ppr (normalizeIdents $ nodeIdentifiers info1), "and"
- , ppr (normalizeIdents $ nodeIdentifiers info2)
+ , ppr (normalizeIdents $ sourcedNodeIdents info1), "and"
+ , ppr (normalizeIdents $ sourcedNodeIdents info2)
]
]
@@ -107,11 +107,24 @@ validAst (Node _ span children) = do
-- | Look for any identifiers which occur outside of their supposed scopes.
-- Returns a list of error messages.
validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]
-validateScopes mod asts = validScopes
+validateScopes mod asts = validScopes ++ validEvs
where
refMap = generateReferencesMap asts
-- We use a refmap for most of the computation
+ evs = M.keys
+ $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap
+
+ validEvs = do
+ i@(Right ev) <- evs
+ case M.lookup i refMap of
+ Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ]
+ Just refs
+ | nameIsLocalOrFrom mod ev
+ , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs)
+ -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"]
+ | otherwise -> []
+
-- Check if all the names occur in their calculated scopes
validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
valid (Left _) _ = []
@@ -122,15 +135,18 @@ validateScopes mod asts = validScopes
Just xs -> xs
Nothing -> []
inScope (sp, dets)
- | (definedInAsts asts n)
+ | (definedInAsts asts n || (any isEvidenceContext (identInfo dets)))
&& any isOccurrence (identInfo dets)
-- We validate scopes for names which are defined locally, and occur
- -- in this span
+ -- in this span, or are evidence variables
= case scopes of
- [] | (nameIsLocalOrFrom mod n
- && not (isDerivedOccName $ nameOccName n))
- -- If we don't get any scopes for a local name then its an error.
- -- We can ignore derived names.
+ [] | nameIsLocalOrFrom mod n
+ , ( not (isDerivedOccName $ nameOccName n)
+ || any isEvidenceContext (identInfo dets))
+ -- If we don't get any scopes for a local name or
+ -- an evidence variable, then its an error.
+ -- We can ignore other kinds of derived names as
+ -- long as we take evidence vars into account
-> return $ hsep $
[ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp
, "Doesn't have a calculated scope: ", ppr scopes]
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -17,13 +17,16 @@ import GHC.Prelude
import GHC.Settings.Config
import GHC.Utils.Binary
import GHC.Data.FastString ( FastString )
+import GHC.Builtin.Utils
import GHC.Iface.Type
-import GHC.Unit.Module ( ModuleName, Module )
-import GHC.Types.Name ( Name )
+import GHC.Unit.Module ( ModuleName, Module )
+import GHC.Types.Name
import GHC.Utils.Outputable hiding ( (<>) )
-import GHC.Types.SrcLoc ( RealSrcSpan )
+import GHC.Types.SrcLoc
import GHC.Types.Avail
+import GHC.Types.Unique
import qualified GHC.Utils.Outputable as O ( (<>) )
+import GHC.Utils.Misc
import qualified Data.Array as A
import qualified Data.Map as M
@@ -33,6 +36,8 @@ import Data.Data ( Typeable, Data )
import Data.Semigroup ( Semigroup(..) )
import Data.Word ( Word8 )
import Control.Applicative ( (<|>) )
+import Data.Coerce ( coerce )
+import Data.Function ( on )
type Span = RealSrcSpan
@@ -222,17 +227,16 @@ instance Outputable a => Outputable (HieASTs a) where
, rest
]
-
data HieAST a =
Node
- { nodeInfo :: NodeInfo a
+ { sourcedNodeInfo :: SourcedNodeInfo 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 $ sourcedNodeInfo ast
put_ bh $ nodeSpan ast
put_ bh $ nodeChildren ast
@@ -247,6 +251,38 @@ instance Outputable a => Outputable (HieAST a) where
header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni
rest = vcat (map ppr ch)
+
+-- | NodeInfos grouped by source
+newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) }
+ deriving (Functor, Foldable, Traversable)
+
+instance Binary (SourcedNodeInfo TypeIndex) where
+ put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts
+ get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh)
+
+instance Outputable a => Outputable (SourcedNodeInfo a) where
+ ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts
+ where
+ go k a rest = vcat $
+ [ "Source: " O.<> ppr k
+ , ppr a
+ , rest
+ ]
+
+-- | Source of node info
+data NodeOrigin
+ = SourceInfo
+ | GeneratedInfo
+ deriving (Eq, Enum, Ord)
+
+instance Outputable NodeOrigin where
+ ppr SourceInfo = text "From source"
+ ppr GeneratedInfo = text "generated by ghc"
+
+instance Binary NodeOrigin where
+ put_ bh b = putByte bh (fromIntegral (fromEnum b))
+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
-- | The information stored in one AST node.
--
-- The type parameter exists to provide flexibility in representation of types
@@ -314,7 +350,7 @@ instance Monoid (IdentifierDetails a) where
instance Binary (IdentifierDetails TypeIndex) where
put_ bh dets = do
put_ bh $ identType dets
- put_ bh $ S.toAscList $ identInfo dets
+ put_ bh $ S.toList $ identInfo dets
get bh = IdentifierDetails
<$> get bh
<*> fmap S.fromDistinctAscList (get bh)
@@ -363,6 +399,14 @@ data ContextInfo
-- | Record field
| RecField RecFieldContext (Maybe Span)
+ -- | Constraint/Dictionary evidence variable binding
+ | EvidenceVarBind
+ EvVarSource -- ^ how did this bind come into being
+ Scope -- ^ scope over which the value is bound
+ (Maybe Span) -- ^ span of the binding site
+
+ -- | Usage of evidence variable
+ | EvidenceVarUse
deriving (Eq, Ord)
instance Outputable ContextInfo where
@@ -385,10 +429,16 @@ instance Outputable ContextInfo where
<+> ppr sc1 <+> "," <+> ppr sc2
ppr (RecField ctx sp) =
text "record field" <+> ppr ctx <+> pprBindSpan sp
+ ppr (EvidenceVarBind ctx sc sp) =
+ text "evidence variable" <+> ppr ctx
+ $$ "with scope:" <+> ppr sc
+ $$ pprBindSpan sp
+ ppr (EvidenceVarUse) =
+ text "usage of evidence variable"
pprBindSpan :: Maybe Span -> SDoc
pprBindSpan Nothing = text ""
-pprBindSpan (Just sp) = text "at:" <+> ppr sp
+pprBindSpan (Just sp) = text "bound at:" <+> ppr sp
instance Binary ContextInfo where
put_ bh Use = putByte bh 0
@@ -422,6 +472,12 @@ instance Binary ContextInfo where
put_ bh a
put_ bh b
put_ bh MatchBind = putByte bh 9
+ put_ bh (EvidenceVarBind a b c) = do
+ putByte bh 10
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh EvidenceVarUse = putByte bh 11
get bh = do
(t :: Word8) <- get bh
@@ -436,8 +492,69 @@ instance Binary ContextInfo where
7 -> TyVarBind <$> get bh <*> get bh
8 -> RecField <$> get bh <*> get bh
9 -> return MatchBind
+ 10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh
+ 11 -> return EvidenceVarUse
_ -> panic "Binary ContextInfo: invalid tag"
+data EvVarSource
+ = EvPatternBind -- ^ bound by a pattern match
+ | EvSigBind -- ^ bound by a type signature
+ | EvWrapperBind -- ^ bound by a hswrapper
+ | EvImplicitBind -- ^ bound by an implicit variable
+ | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class
+ | EvLetBind EvBindDeps -- ^ A direct let binding
+ deriving (Eq,Ord)
+
+instance Binary EvVarSource where
+ put_ bh EvPatternBind = putByte bh 0
+ put_ bh EvSigBind = putByte bh 1
+ put_ bh EvWrapperBind = putByte bh 2
+ put_ bh EvImplicitBind = putByte bh 3
+ put_ bh (EvInstBind b cls) = do
+ putByte bh 4
+ put_ bh b
+ put_ bh cls
+ put_ bh (EvLetBind deps) = do
+ putByte bh 5
+ put_ bh deps
+
+ get bh = do
+ (t :: Word8) <- get bh
+ case t of
+ 0 -> pure EvPatternBind
+ 1 -> pure EvSigBind
+ 2 -> pure EvWrapperBind
+ 3 -> pure EvImplicitBind
+ 4 -> EvInstBind <$> get bh <*> get bh
+ 5 -> EvLetBind <$> get bh
+ _ -> panic "Binary EvVarSource: invalid tag"
+
+instance Outputable EvVarSource where
+ ppr EvPatternBind = text "bound by a pattern"
+ ppr EvSigBind = text "bound by a type signature"
+ ppr EvWrapperBind = text "bound by a HsWrapper"
+ ppr EvImplicitBind = text "bound by an implicit variable binding"
+ ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls
+ ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls
+ ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps
+
+-- | Eq/Ord instances compare on the converted HieName,
+-- as non-exported names may have different uniques after
+-- a roundtrip
+newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }
+ deriving Outputable
+
+instance Eq EvBindDeps where
+ (==) = coerce ((==) `on` map toHieName)
+
+instance Ord EvBindDeps where
+ compare = coerce (compare `on` map toHieName)
+
+instance Binary EvBindDeps where
+ put_ bh (EvBindDeps xs) = put_ bh xs
+ get bh = EvBindDeps <$> get bh
+
+
-- | Types of imports and exports
data IEType
= Import
@@ -587,3 +704,46 @@ instance Binary TyVarScope where
0 -> ResolvedScopes <$> get bh
1 -> UnresolvedScope <$> get bh <*> get bh
_ -> panic "Binary TyVarScope: invalid tag"
+
+-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
+-- these two types.
+data HieName
+ = ExternalName !Module !OccName !SrcSpan
+ | LocalName !OccName !SrcSpan
+ | KnownKeyName !Unique
+ deriving (Eq)
+
+instance Ord HieName where
+ compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f
+ -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
+ compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d
+ -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
+ compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
+ -- Not actually non deterministic as it is a KnownKey
+ compare ExternalName{} _ = LT
+ compare LocalName{} ExternalName{} = GT
+ compare LocalName{} _ = LT
+ compare KnownKeyName{} _ = GT
+
+instance Outputable HieName where
+ ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
+ ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
+ ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
+
+hieNameOcc :: HieName -> OccName
+hieNameOcc (ExternalName _ occ _) = occ
+hieNameOcc (LocalName occ _) = occ
+hieNameOcc (KnownKeyName u) =
+ case lookupKnownKeyName u of
+ Just n -> nameOccName n
+ Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
+ (ppr (unpkUnique u))
+
+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)
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -1,7 +1,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
module GHC.Iface.Ext.Utils where
import GHC.Prelude
@@ -11,7 +13,9 @@ import GHC.Driver.Session ( DynFlags )
import GHC.Data.FastString ( FastString, mkFastString )
import GHC.Iface.Type
import GHC.Types.Name hiding (varName)
-import GHC.Utils.Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext )
+import GHC.Types.Name.Set
+import GHC.Utils.Outputable hiding ( (<>) )
+import qualified GHC.Utils.Outputable as O
import GHC.Types.SrcLoc
import GHC.CoreToIface
import GHC.Core.TyCon
@@ -27,21 +31,26 @@ 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.Maybe ( maybeToList, mapMaybe)
import Data.Monoid
+import Data.List (find)
import Data.Traversable ( for )
+import Data.Coerce
import Control.Monad.Trans.State.Strict hiding (get)
+import Control.Monad.Trans.Reader
+import qualified Data.Tree as Tree
+type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]
generateReferencesMap
:: Foldable f
=> f (HieAST a)
- -> M.Map Identifier [(Span, IdentifierDetails a)]
+ -> RefMap a
generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
where
go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
where
- this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
+ this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast
renderHieType :: DynFlags -> HieTypeFix -> String
renderHieType dflags ht = renderWithStyle (initSDocContext dflags defaultUserStyle) (ppr $ hieTypeToIface ht)
@@ -72,6 +81,73 @@ resolveVisibility kind ty_args
foldType :: (HieType a -> a) -> HieTypeFix -> a
foldType f (Roll t) = f $ fmap (foldType f) t
+selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)
+selectPoint hf (sl,sc) = getFirst $
+ flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(fs,ast) -> First $
+ case selectSmallestContaining (sp fs) ast of
+ Nothing -> Nothing
+ Just ast' -> Just ast'
+ where
+ sloc fs = mkRealSrcLoc fs sl sc
+ sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
+
+findEvidenceUse :: NodeIdentifiers a -> [Name]
+findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)]
+ where
+ xs = M.toList ni
+
+data EvidenceInfo a
+ = EvidenceInfo
+ { evidenceVar :: Name
+ , evidenceSpan :: RealSrcSpan
+ , evidenceType :: a
+ , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)
+ } deriving (Eq,Ord,Functor)
+
+instance (Outputable a) => Outputable (EvidenceInfo a) where
+ ppr (EvidenceInfo name span typ dets) =
+ hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $
+ pdets $$ (pprDefinedAt name)
+ where
+ pdets = case dets of
+ Nothing -> text "is a usage of an external evidence variable"
+ Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn)
+
+getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a)
+getEvidenceTreesAtPoint hf refmap point =
+ [t | Just ast <- pure $ selectPoint hf point
+ , n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast)
+ , Just t <- pure $ getEvidenceTree refmap n
+ ]
+
+getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a))
+getEvidenceTree refmap var = go emptyNameSet var
+ where
+ go seen var
+ | var `elemNameSet` seen = Nothing
+ | otherwise = do
+ xs <- M.lookup (Right var) refmap
+ case find (any isEvidenceBind . identInfo . snd) xs of
+ Just (sp,dets) -> do
+ typ <- identType dets
+ (evdet,children) <- getFirst $ foldMap First $ do
+ det <- S.toList $ identInfo dets
+ case det of
+ EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn ->
+ pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs)
+ EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[])
+ _ -> pure Nothing
+ pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children
+ -- It is externally bound
+ Nothing -> getFirst $ foldMap First $ do
+ (sp,dets) <- xs
+ if (any isEvidenceUse $ identInfo dets)
+ then do
+ case identType dets of
+ Nothing -> pure Nothing
+ Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) []
+ else pure Nothing
+
hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface = foldType go
where
@@ -194,8 +270,10 @@ resolveTyVarScopeLocal ast asts = go ast
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
+ info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info)
+ updateNodeInfo i = i { nodeIdentifiers = idents }
+ where
+ idents = M.map resolveNameScope $ nodeIdentifiers i
getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
getNameBinding n asts = do
@@ -217,7 +295,7 @@ getNameBindingInClass n sp asts = do
getFirst $ foldMap First $ do
child <- flattenAst ast
dets <- maybeToList
- $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child
+ $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child
let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
return (getFirst binding)
@@ -232,7 +310,7 @@ getNameScopeAndBinding n asts = case nameSrcSpan n of
getFirst $ foldMap First $ do -- @[]
node <- flattenAst defNode
dets <- maybeToList
- $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node
+ $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node
scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
return $ Just (scopes, getFirst binding)
@@ -245,6 +323,7 @@ getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
getScopeFromContext (Decl _ _) = Just [ModuleScope]
getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
getScopeFromContext (TyVarBind a _) = Just [a]
+getScopeFromContext (EvidenceVarBind _ a _) = Just [a]
getScopeFromContext _ = Nothing
getBindSiteFromContext :: ContextInfo -> Maybe Span
@@ -292,8 +371,27 @@ definedInAsts asts n = case nameSrcSpan n of
RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts
_ -> False
+getEvidenceBindDeps :: ContextInfo -> [Name]
+getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) =
+ getEvBindDeps xs
+getEvidenceBindDeps _ = []
+
+isEvidenceBind :: ContextInfo -> Bool
+isEvidenceBind EvidenceVarBind{} = True
+isEvidenceBind _ = False
+
+isEvidenceContext :: ContextInfo -> Bool
+isEvidenceContext EvidenceVarUse = True
+isEvidenceContext EvidenceVarBind{} = True
+isEvidenceContext _ = False
+
+isEvidenceUse :: ContextInfo -> Bool
+isEvidenceUse EvidenceVarUse = True
+isEvidenceUse _ = False
+
isOccurrence :: ContextInfo -> Bool
isOccurrence Use = True
+isOccurrence EvidenceVarUse = True
isOccurrence _ = False
scopeContainsSpan :: Scope -> Span -> Bool
@@ -304,7 +402,7 @@ 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 == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys)
| aSpn `containsSpan` bSpn = combineAst b a
combineAst a (Node xs span children) = Node xs span (insertAst a children)
@@ -312,6 +410,18 @@ combineAst a (Node xs span children) = Node xs span (insertAst a children)
insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
insertAst x = mergeAsts [x]
+nodeInfo :: HieAST Type -> NodeInfo Type
+nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo
+
+emptyNodeInfo :: NodeInfo a
+emptyNodeInfo = NodeInfo S.empty [] M.empty
+
+sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a
+sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo
+
+combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type
+combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo
+
-- | Merge two nodes together.
--
-- Precondition and postcondition: elements in 'nodeType' are ordered.
@@ -404,11 +514,12 @@ mergeSortAsts = go . map pure
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 _ = []
+locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]
+locOnly (RealSrcSpan span _) = do
+ org <- ask
+ let e = mkSourcedNodeInfo org $ emptyNodeInfo
+ pure [Node e span []]
+locOnly _ = pure []
mkScope :: SrcSpan -> Scope
mkScope (RealSrcSpan sp _) = LocalScope sp
@@ -425,30 +536,37 @@ combineScopes x NoScope = x
combineScopes (LocalScope a) (LocalScope b) =
mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing)
+mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
+mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
+
{-# INLINEABLE makeNode #-}
makeNode
- :: (Applicative m, Data a)
+ :: (Monad 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 []]
- _ -> []
+ -> ReaderT NodeOrigin m [HieAST b]
+makeNode x spn = do
+ org <- ask
+ pure $ case spn of
+ RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]
+ _ -> []
where
cons = mkFastString . show . toConstr $ x
typ = mkFastString . show . typeRepTyCon . typeOf $ x
{-# INLINEABLE makeTypeNode #-}
makeTypeNode
- :: (Applicative m, Data a)
+ :: (Monad m, Data a)
=> a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-> SrcSpan -- ^ return an empty list if this is unhelpful
-> Type -- ^ type to associate with the node
- -> m [HieAST Type]
-makeTypeNode x spn etyp = pure $ case spn of
- RealSrcSpan span _ ->
- [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
- _ -> []
+ -> ReaderT NodeOrigin m [HieAST Type]
+makeTypeNode x spn etyp = do
+ org <- ask
+ pure $ case spn of
+ RealSrcSpan span _ ->
+ [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
+ _ -> []
where
cons = mkFastString . show . toConstr $ x
typ = mkFastString . show . typeRepTyCon . typeOf $ x
=====================================
testsuite/tests/hiefile/should_compile/Scopes.hs
=====================================
@@ -1,10 +1,33 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE RecordWildCards #-}
module Scopes where
+
+-- Verify that evidence bound by patern
+-- synonyms has correct scope
+pattern LL :: Num a => a -> a
+pattern LL x <- (subtract 1 -> x)
+ where
+ LL x = x + 1
+
data T = C { x :: Int, y :: Char }
--- Verify that names generated from record construction are in scope
+-- Verify that names generated from record construction
+-- have correct scope
foo = C { x = 1 , y = 'a' }
+-- Verify that implicit paramters have correct scope
+bar :: (?x :: Int) => Int
+bar = ?x + 1
+
+baz :: Int
+baz = bar + ?x
+ where ?x = 2
+
+-- Verify that variables bound in pattern
+-- synonyms have the correct scope
+pattern A a b = (a , b)
+
-- Verify that record wildcards are in scope
sdaf :: T
sdaf = C{..}
=====================================
testsuite/tests/hiefile/should_run/HieQueries.hs
=====================================
@@ -0,0 +1,82 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Main where
+
+import System.Environment
+
+import GHC.Types.Name.Cache
+import GHC.Types.SrcLoc
+import GHC.Types.Unique.Supply
+import GHC.Types.Name
+import Data.Tree
+import GHC.Iface.Ext.Binary
+import GHC.Iface.Ext.Types
+import GHC.Iface.Ext.Utils
+import Data.Maybe (fromJust)
+import GHC.Driver.Session
+import GHC.SysTools
+import GHC.Utils.Outputable ( Outputable, renderWithStyle, ppr, defaultUserStyle, initSDocContext, text)
+import qualified Data.Map as M
+import Data.Foldable
+
+class C a where
+ f :: a -> Char
+
+instance C Char where
+ f x = x
+
+instance C a => C [a] where
+ f x = 'a'
+
+foo :: C a => a -> Char
+foo x = f [x]
+-- ^ this is the point
+point :: (Int,Int)
+point = (31,9)
+
+bar :: Show x => x -> String
+bar x = show [(1,x,A)]
+-- ^ this is the point'
+point' :: (Int,Int)
+point' = (37,9)
+
+data A = A deriving Show
+
+makeNc :: IO NameCache
+makeNc = do
+ uniq_supply <- mkSplitUniqSupply 'z'
+ return $ initNameCache uniq_supply []
+
+dynFlagsForPrinting :: String -> IO DynFlags
+dynFlagsForPrinting libdir = do
+ systemSettings <- initSysTools libdir
+ return $ defaultDynFlags systemSettings (LlvmConfig [] [])
+
+main = do
+ libdir:_ <- getArgs
+ df <- dynFlagsForPrinting libdir
+ nc <- makeNc
+ hfr <- readHieFile (NCU (\f -> pure $ snd $ f nc)) "HieQueries.hie"
+ let hf = hie_file_result hfr
+ refmap = generateReferencesMap $ getAsts $ hie_asts hf
+ explainEv df hf refmap point
+ explainEv df hf refmap point'
+ return ()
+
+explainEv :: DynFlags -> HieFile -> RefMap Int -> (Int,Int) -> IO ()
+explainEv df hf refmap point = do
+ putStrLn $ replicate 26 '='
+ putStrLn $ "At point " ++ show point ++ ", we found:"
+ putStrLn $ replicate 26 '='
+ putStr $ drawForest ptrees
+ where
+ trees = getEvidenceTreesAtPoint hf refmap point
+
+ ptrees = fmap (pprint . fmap expandType) <$> trees
+
+ expandType = text . renderHieType df .
+ flip recoverFullType (hie_types hf)
+
+ pretty = unlines . (++["└"]) . ("┌":) . map ("│ "++) . lines
+
+ pprint = pretty . renderWithStyle (initSDocContext df sty) . ppr
+ sty = defaultUserStyle
=====================================
testsuite/tests/hiefile/should_run/HieQueries.stdout
=====================================
@@ -0,0 +1,98 @@
+==========================
+At point (31,9), we found:
+==========================
+┌
+│ $dC at HieQueries.hs:31:1-13, of type: C [a]
+│ is an evidence variable bound by a let, depending on: [$fC[], $dC]
+│ with scope: LocalScope HieQueries.hs:31:1-13
+│ bound at: HieQueries.hs:31:1-13
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ $fC[] at HieQueries.hs:27:10-21, of type: forall a. C a => C [a]
+| │ is an evidence variable bound by an instance of class C
+| │ with scope: ModuleScope
+| │
+| │ Defined at HieQueries.hs:27:10
+| └
+|
+`- ┌
+ │ $dC at HieQueries.hs:31:1-13, of type: C a
+ │ is an evidence variable bound by a type signature
+ │ with scope: LocalScope HieQueries.hs:31:1-13
+ │ bound at: HieQueries.hs:31:1-13
+ │ Defined at <no location info>
+ └
+
+==========================
+At point (37,9), we found:
+==========================
+┌
+│ $dShow at HieQueries.hs:37:1-22, of type: Show [(Integer, x, A)]
+│ is an evidence variable bound by a let, depending on: [$fShow[],
+│ $dShow]
+│ with scope: LocalScope HieQueries.hs:37:1-22
+│ bound at: HieQueries.hs:37:1-22
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ $fShow[] at HieQueries.hs:37:1-22, of type: forall a. Show a => Show [a]
+| │ is a usage of an external evidence variable
+| │ Defined in `GHC.Show'
+| └
+|
+`- ┌
+ │ $dShow at HieQueries.hs:37:1-22, of type: Show (Integer, x, A)
+ │ is an evidence variable bound by a let, depending on: [$fShow(,,),
+ │ $dShow, $dShow, $dShow]
+ │ with scope: LocalScope HieQueries.hs:37:1-22
+ │ bound at: HieQueries.hs:37:1-22
+ │ Defined at <no location info>
+ └
+ |
+ +- ┌
+ | │ $fShow(,,) at HieQueries.hs:37:1-22, of type: forall a b c. (Show a, Show b, Show c) => Show (a, b, c)
+ | │ is a usage of an external evidence variable
+ | │ Defined in `GHC.Show'
+ | └
+ |
+ +- ┌
+ | │ $dShow at HieQueries.hs:37:1-22, of type: Show Integer
+ | │ is an evidence variable bound by a let, depending on: [$fShowInteger]
+ | │ with scope: LocalScope HieQueries.hs:37:1-22
+ | │ bound at: HieQueries.hs:37:1-22
+ | │ Defined at <no location info>
+ | └
+ | |
+ | `- ┌
+ | │ $fShowInteger at HieQueries.hs:37:1-22, of type: Show Integer
+ | │ is a usage of an external evidence variable
+ | │ Defined in `GHC.Show'
+ | └
+ |
+ +- ┌
+ | │ $dShow at HieQueries.hs:37:1-22, of type: Show x
+ | │ is an evidence variable bound by a type signature
+ | │ with scope: LocalScope HieQueries.hs:37:1-22
+ | │ bound at: HieQueries.hs:37:1-22
+ | │ Defined at <no location info>
+ | └
+ |
+ `- ┌
+ │ $dShow at HieQueries.hs:37:1-22, of type: Show A
+ │ is an evidence variable bound by a let, depending on: [$fShowA]
+ │ with scope: LocalScope HieQueries.hs:37:1-22
+ │ bound at: HieQueries.hs:37:1-22
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ $fShowA at HieQueries.hs:42:21-24, of type: Show A
+ │ is an evidence variable bound by an instance of class Show
+ │ with scope: ModuleScope
+ │
+ │ Defined at HieQueries.hs:42:21
+ └
+
=====================================
testsuite/tests/hiefile/should_run/PatTypes.hs
=====================================
@@ -42,16 +42,9 @@ dynFlagsForPrinting libdir = do
systemSettings <- initSysTools libdir
return $ defaultDynFlags systemSettings (LlvmConfig [] [])
-selectPoint :: HieFile -> (Int,Int) -> HieAST Int
-selectPoint hf (sl,sc) = case M.toList (getAsts $ hie_asts hf) of
- [(fs,ast)] ->
- case selectSmallestContaining (sp fs) ast of
- Nothing -> error "point not found"
- Just ast' -> ast'
- _ -> error "map should only contain a single AST"
- where
- sloc fs = mkRealSrcLoc fs sl sc
- sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
+selectPoint' :: HieFile -> (Int,Int) -> HieAST Int
+selectPoint' hf loc =
+ maybe (error "point not found") id $ selectPoint hf loc
main = do
libdir:_ <- getArgs
@@ -61,6 +54,6 @@ main = do
let hf = hie_file_result hfr
forM_ [p1,p2,p3,p4] $ \point -> do
putStr $ "At " ++ show point ++ ", got type: "
- let types = nodeType $ nodeInfo $ selectPoint hf point
+ let types = concatMap nodeType $ getSourcedNodeInfo $ sourcedNodeInfo $ selectPoint' hf point
forM_ types $ \typ -> do
putStrLn (renderHieType df $ recoverFullType typ (hie_types hf))
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -1 +1,2 @@
test('PatTypes', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('HieQueries', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 8f340aef12df5f5df02d49ab5c6c5d7cccfa398b
+Subproject commit 8134a3be2c01ab5f1b88fed86c4ad7cc2f417f0a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53814a6424240ab50201fdde81a6e7832c1aad3d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53814a6424240ab50201fdde81a6e7832c1aad3d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200526/4d516d8a/attachment-0001.html>
More information about the ghc-commits
mailing list