Commit 3c650e55 authored by wz1000's avatar wz1000

Ensure getEvidenceTree terminates and make output easier for haddock to process

parent 5bc4e1cd
Pipeline #19264 failed with stages
in 53 minutes and 33 seconds
......@@ -18,6 +18,8 @@ Main functions for .hie file generation
module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where
import GHC.Utils.Outputable(ppr)
import GHC.Prelude
import GHC.Types.Avail ( Avails )
......@@ -49,6 +51,7 @@ 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
......@@ -222,12 +225,23 @@ addUnlocatedEvBind var ci = do
var (var,S.singleton ci)
}
getUnlocatedEvBinds :: HieM (NodeIdentifiers Type)
getUnlocatedEvBinds = do
getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type])
getUnlocatedEvBinds file = do
binds <- gets unlocated_ev_binds
let go (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci)
let elts = M.fromList $ map go $ dVarEnvElts binds
pure elts
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 (NodeInfo mempty [] $ M.fromList [mkNodeInfo e]) spn []
in (xs,node:ys)
_ -> (mkNodeInfo e : xs,ys)
(nis,asts) = foldr go ([],[]) elts
pure $ (M.fromList nis, asts)
initState :: HieState
initState = HieState emptyNameEnv emptyDVarEnv
......@@ -295,8 +309,8 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs =
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)
let spanFile file children = case children of
[] -> realSrcLocSpan (mkRealSrcLoc file 1 1)
_ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
(realSrcSpanEnd $ nodeSpan $ last children)
......@@ -307,21 +321,29 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs =
, exps
]
modulify xs' = do
let xs = mergeSortAsts xs'
let span = spanFile xs
modulify file xs' = do
top_ev_asts <-
toHie $ EvBindContext ModuleScope Nothing
$ L (RealSrcSpan span Nothing) $ EvBinds ev_bs
uloc_evs <- getUnlocatedEvBinds
let moduleInfo = (simpleNodeInfo "Module" "Module")
$ 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 = (simpleNodeInfo "Module" "Module")
{nodeIdentifiers = uloc_evs}
let moduleNode = Node moduleInfo span []
case mergeSortAsts $ moduleNode : top_ev_asts ++ xs of
moduleNode = Node moduleInfo span []
case mergeSortAsts $ moduleNode : xs of
[x] -> return x
_ -> panic "enrichHie: mergeSortAsts returned more than one result"
xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs)
asts' <- mapM modulify
asts' <- sequence
$ M.mapWithKey modulify
$ M.fromListWith (++)
$ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
......
......@@ -13,6 +13,7 @@ import GHC.Driver.Session ( DynFlags )
import GHC.Data.FastString ( FastString, mkFastString )
import GHC.Iface.Type
import GHC.Types.Name hiding (varName)
import GHC.Types.Name.Set
import GHC.Utils.Outputable hiding ( (<>) )
import qualified GHC.Utils.Outputable as O
import GHC.Types.SrcLoc
......@@ -119,19 +120,23 @@ getEvidenceTreesAtPoint hf refmap point =
]
getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a))
getEvidenceTree refmap var = 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 (getEvidenceTree refmap) xs)
EvidenceVarBind src scp spn -> pure ((src,scp,spn),[])
_ -> []
pure $ Tree.Node (EvidenceInfo var sp typ evdets) children
getEvidenceTree refmap var = go emptyNameSet var
where
go seen 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
hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface = foldType go
......
......@@ -10,7 +10,7 @@ At point (31,9), we found:
|
+- ┌
| │ $fC[] at HieQueries.hs:(4,1)-(82,26), of type: forall a. C a => C [a]
| │ $fC[] at HieQueries.hs:27:10-21, of type: forall a. C a => C [a]
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
......@@ -38,7 +38,7 @@ At point (37,9), we found:
|
+- ┌
| │ $fShow[] at HieQueries.hs:(4,1)-(82,26), of type: forall a. Show a => Show [a]
| │ $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
| │
......@@ -55,7 +55,7 @@ At point (37,9), we found:
|
+- ┌
| │ $fShow(,,) at HieQueries.hs:(4,1)-(82,26), of type: forall a b c. (Show a, Show b, Show c) => Show (a, b, c)
| │ $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
| │
......@@ -71,7 +71,7 @@ At point (37,9), we found:
| └
| |
| `- ┌
| │ $fShowInteger at HieQueries.hs:(4,1)-(82,26), of type: Show Integer
| │ $fShowInteger at HieQueries.hs:(1,1)-(82,26), of type: Show Integer
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
......@@ -95,7 +95,7 @@ At point (37,9), we found:
|
`- ┌
│ $fShowA at HieQueries.hs:(4,1)-(82,26), of type: Show A
│ $fShowA at HieQueries.hs:42:21-24, of type: Show A
│ is an evidence variable bound by an instance
│ with scope: ModuleScope
......
Subproject commit cc7c1b58a46097f6bf7bd0e18fda58290753869c
Subproject commit 8f074ccb0f94117328ce937264b17b2fa3abcf46
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