Commit 8caea8dc authored by wz1000's avatar wz1000

Don't mark external instances as evidence bindings

parent a984c8fd
Pipeline #19527 failed with stages
in 151 minutes and 51 seconds
......@@ -36,12 +36,13 @@ 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, nameUnique, isExternalName )
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.Tc.Types
import GHC.Tc.Types.Evidence
......@@ -62,7 +63,7 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.Data ( Data, Typeable )
import Data.List ( foldl1' )
import Control.Monad ( when, forM_ )
import Control.Monad ( forM_ )
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class ( lift )
......@@ -287,7 +288,8 @@ mkHieFileWithSource :: FilePath
mkHieFileWithSource src_file src ms ts rs = do
let tc_binds = tcg_binds ts
top_ev_binds = tcg_ev_binds ts
(asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds
insts = tcg_insts ts
(asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts
return $ HieFile
{ hie_hs_file = src_file
, hie_module = ms_mod ms
......@@ -298,20 +300,22 @@ mkHieFileWithSource src_file src ms ts rs = do
, hie_hs_src = src
}
getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind
getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst]
-> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
getCompressedAsts ts rs top_ev_binds = do
asts <- enrichHie ts rs top_ev_binds
getCompressedAsts ts rs top_ev_binds insts = do
asts <- enrichHie ts rs top_ev_binds insts
return $ compressTypes asts
enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind
enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst]
-> Hsc (HieASTs Type)
enrichHie ts (hsGrp, imports, exports, _) ev_bs =
enrichHie ts (hsGrp, imports, exports, _) ev_bs insts =
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
forM_ insts $ \i ->
addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind (is_cls_nm i)) ModuleScope Nothing)
let spanFile file children = case children of
[] -> realSrcLocSpan (mkRealSrcLoc file 1 1)
_ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
......@@ -647,14 +651,11 @@ instance ToHie (EvBindContext (Located TcEvBinds)) where
go evbind = do
let evDeps = evVarsOfTermList $ eb_rhs evbind
depNames = EvBindDeps $ map varName evDeps
-- We explictly add top level instance dictionaries in
-- the LHS
forM_ evDeps $ \id ->
when (isExternalName (varName id)) $
addUnlocatedEvBind id $
EvidenceVarBind EvExternalBind ModuleScope Nothing
toHie (C (EvidenceVarBind (EvLetBind depNames) sc sp)
(L span $ eb_lhs evbind))
concatM $
[ toHie (C (EvidenceVarBind (EvLetBind depNames) sc sp)
(L span $ eb_lhs evbind))
, toHie $ map (C EvidenceVarUse . L span) $ evDeps
]
toHie _ = pure []
instance ToHie (EvBindContext (Located NoExtField)) where
......
......@@ -501,7 +501,7 @@ data EvVarSource
| EvSigBind -- ^ bound by a type signature
| EvWrapperBind -- ^ bound by a hswrapper
| EvImplicitBind -- ^ bound by an implicit variable
| EvExternalBind -- ^ Bound by some instance
| EvInstBind Name -- ^ Bound by some instance of given class (type)
| EvLetBind EvBindDeps -- ^ A direct let binding
deriving (Eq,Ord)
......@@ -510,7 +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 EvExternalBind = putByte bh 4
put_ bh (EvInstBind cls) = do
putByte bh 4
put_ bh cls
put_ bh (EvLetBind deps) = do
putByte bh 5
put_ bh deps
......@@ -522,7 +524,7 @@ instance Binary EvVarSource where
1 -> pure EvSigBind
2 -> pure EvWrapperBind
3 -> pure EvImplicitBind
4 -> pure EvExternalBind
4 -> EvInstBind <$> get bh
5 -> EvLetBind <$> get bh
_ -> panic "Binary EvVarSource: invalid tag"
......@@ -531,7 +533,7 @@ 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 EvExternalBind = text "bound by an instance"
ppr (EvInstBind cls) = text "bound by an instance of class" <+> ppr cls
ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps
-- | Eq/Ord instances compare on the converted HieName,
......
......@@ -101,7 +101,7 @@ data EvidenceInfo a
{ evidenceVar :: Name
, evidenceSpan :: RealSrcSpan
, evidenceType :: a
, evidenceDetails :: [(EvVarSource, Scope, Maybe Span)]
, evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)
} deriving (Eq,Ord,Functor)
instance (Outputable a) => Outputable (EvidenceInfo a) where
......@@ -110,9 +110,8 @@ instance (Outputable a) => Outputable (EvidenceInfo a) where
pdets $$ (pprDefinedAt name)
where
pdets = case dets of
[] -> text "is a usage of an evidence variable"
xs -> text "is an" <+> (hsep $ punctuate (text "and/or") $
map (\(src,scp,spn) -> ppr (EvidenceVarBind src scp spn)) xs)
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 =
......@@ -128,17 +127,26 @@ getEvidenceTree refmap var = go emptyNameSet var
| var `elemNameSet` seen = Nothing
| otherwise = do
xs <- M.lookup (Right var) refmap
(sp,dets) <- find (any isEvidenceBind . identInfo . snd) xs
typ <- identType dets
let
(evdets,concat -> children) = unzip $ do
det <- S.toList $ identInfo dets
case det of
EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn ->
pure ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs)
EvidenceVarBind src scp spn -> pure ((src,scp,spn),[])
_ -> []
pure $ Tree.Node (EvidenceInfo var sp typ evdets) children
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
......
......@@ -11,7 +11,7 @@ At point (31,9), we found:
|
+- ┌
| │ $fC[] at HieQueries.hs:27:10-21, of type: forall a. C a => C [a]
| │ is an evidence variable bound by an instance
| │ is an evidence variable bound by an instance of class C
| │ with scope: ModuleScope
| │
| │ Defined at HieQueries.hs:27:10
......@@ -38,10 +38,8 @@ At point (37,9), we found:
|
+- ┌
| │ $fShow[] at HieQueries.hs:(1,1)-(82,26), of type: forall a. Show a => Show [a]
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
| │ $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'
| └
|
......@@ -55,10 +53,8 @@ At point (37,9), we found:
|
+- ┌
| │ $fShow(,,) at HieQueries.hs:(1,1)-(82,26), of type: forall a b c. (Show a, Show b, Show c) => Show (a, b, c)
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
| │ $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'
| └
|
......@@ -71,10 +67,8 @@ At point (37,9), we found:
| └
| |
| `- ┌
| │ $fShowInteger at HieQueries.hs:(1,1)-(82,26), of type: Show Integer
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
| │ $fShowInteger at HieQueries.hs:37:1-22, of type: Show Integer
| │ is a usage of an external evidence variable
| │ Defined in `GHC.Show'
| └
|
......@@ -96,7 +90,7 @@ At point (37,9), we found:
|
`- ┌
│ $fShowA at HieQueries.hs:42:21-24, of type: Show A
│ is an evidence variable bound by an instance
│ is an evidence variable bound by an instance of class Show
│ with scope: ModuleScope
│ Defined at HieQueries.hs:42:21
......
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