Commit 3a000043 authored by wz1000's avatar wz1000

record superclass parent selectors, improve validation

parent 5dfc34f8
Pipeline #19536 passed with stages
in 467 minutes and 30 seconds
......@@ -26,9 +26,10 @@ 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
......@@ -289,7 +290,8 @@ mkHieFileWithSource src_file src ms ts rs = do
let tc_binds = tcg_binds ts
top_ev_binds = tcg_ev_binds ts
insts = tcg_insts ts
(asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts
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
......@@ -300,22 +302,29 @@ mkHieFileWithSource src_file src ms ts rs = do
, hie_hs_src = src
}
getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst]
getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
-> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
getCompressedAsts ts rs top_ev_binds insts = do
asts <- enrichHie ts rs top_ev_binds insts
getCompressedAsts ts rs top_ev_binds insts tcs = do
asts <- enrichHie ts rs top_ev_binds insts tcs
return $ compressTypes asts
enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst]
enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
-> Hsc (HieASTs Type)
enrichHie ts (hsGrp, imports, exports, _) ev_bs insts =
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
-- Add Instance bindings
forM_ insts $ \i ->
addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind (is_cls_nm i)) ModuleScope Nothing)
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)
......@@ -652,7 +661,7 @@ instance ToHie (EvBindContext (Located TcEvBinds)) where
let evDeps = evVarsOfTermList $ eb_rhs evbind
depNames = EvBindDeps $ map varName evDeps
concatM $
[ toHie (C (EvidenceVarBind (EvLetBind depNames) sc sp)
[ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp)
(L span $ eb_lhs evbind))
, toHie $ map (C EvidenceVarUse . L span) $ evDeps
]
......@@ -943,9 +952,10 @@ instance ( a ~ GhcPass p
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 scope rsp)
, toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
. L ospan) ev_vars
]
_ -> pure []
......
......@@ -107,28 +107,23 @@ 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 ++ validEvLets
validateScopes mod asts = validScopes ++ validEvs
where
refMap = generateReferencesMap asts
-- We use a refmap for most of the computation
-- Check if everything on the RHS of an EvLet binding is also bound
-- somewhere in the AST
validEvLets = concatMap evVarInScope evletrhs
evs = M.keys
$ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap
-- Check if a given evidence variable is bound
evVarInScope n = case M.lookup (Right n) refMap of
Nothing -> return $ hsep ["Local evidence variable:", ppr n
, "occuring in the rhs of a EvLet doesn't appear in the refmap"]
Just xs
| any (any isEvidenceBind) (map (identInfo . snd) xs) -> []
| otherwise -> return $ hsep ["Local evidence variable:"
, ppr n, "occuring in the rhs of a EvLet isn't bound in the refmap"]
-- All the evidence variables occuring on the RHS of an EvLet
evletrhs = S.fromList $ concatMap (evLets . identInfo . snd)
$ concat $ M.elems refMap
evLets = concatMap getEvidenceBindDeps
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
......@@ -145,9 +140,9 @@ validateScopes mod asts = validScopes ++ validEvLets
-- We validate scopes for names which are defined locally, and occur
-- in this span, or are evidence variables
= case scopes of
[] | any isEvidenceContext (identInfo dets)
|| (nameIsLocalOrFrom mod n
&& not (isDerivedOccName $ nameOccName n))
[] | 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
......
......@@ -501,7 +501,7 @@ data EvVarSource
| EvSigBind -- ^ bound by a type signature
| EvWrapperBind -- ^ bound by a hswrapper
| EvImplicitBind -- ^ bound by an implicit variable
| EvInstBind Name -- ^ Bound by some instance of given class
| EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class
| EvLetBind EvBindDeps -- ^ A direct let binding
deriving (Eq,Ord)
......@@ -510,8 +510,9 @@ instance Binary EvVarSource where
put_ bh EvSigBind = putByte bh 1
put_ bh EvWrapperBind = putByte bh 2
put_ bh EvImplicitBind = putByte bh 3
put_ bh (EvInstBind cls) = do
put_ bh (EvInstBind b cls) = do
putByte bh 4
put_ bh b
put_ bh cls
put_ bh (EvLetBind deps) = do
putByte bh 5
......@@ -524,7 +525,7 @@ instance Binary EvVarSource where
1 -> pure EvSigBind
2 -> pure EvWrapperBind
3 -> pure EvImplicitBind
4 -> EvInstBind <$> get bh
4 -> EvInstBind <$> get bh <*> get bh
5 -> EvLetBind <$> get bh
_ -> panic "Binary EvVarSource: invalid tag"
......@@ -533,7 +534,8 @@ instance Outputable EvVarSource where
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 cls) = text "bound by an instance of class" <+> ppr cls
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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment