Commit 2dc45486 authored by wz1000's avatar wz1000

Mark NodeInfo with its origin(generated/source)

parent bca2dd07
Pipeline #19452 passed with stages
in 431 minutes and 7 seconds
This diff is collapsed.
......@@ -38,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)
]
]
......
......@@ -227,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
......@@ -252,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
......
......@@ -35,7 +35,9 @@ 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)]
......@@ -48,7 +50,7 @@ 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)
......@@ -89,10 +91,10 @@ selectPoint hf (sl,sc) = getFirst $
sloc fs = mkRealSrcLoc fs sl sc
sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
findEvidenceUse :: NodeInfo a -> [Name]
findEvidenceUse :: NodeIdentifiers a -> [Name]
findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)]
where
xs = M.toList $ nodeIdentifiers ni
xs = M.toList ni
data EvidenceInfo a
= EvidenceInfo
......@@ -115,7 +117,7 @@ instance (Outputable a) => Outputable (EvidenceInfo a) where
getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a)
getEvidenceTreesAtPoint hf refmap point =
[t | Just ast <- pure $ selectPoint hf point
, n <- findEvidenceUse (nodeInfo ast)
, n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast)
, Just t <- pure $ getEvidenceTree refmap n
]
......@@ -260,8 +262,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
......@@ -283,7 +287,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)
......@@ -298,7 +302,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)
......@@ -390,7 +394,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)
......@@ -398,6 +402,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.
......@@ -490,11 +506,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
......@@ -511,30 +528,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
......@@ -54,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))
Subproject commit ac4c673c7a51fc66a82805b907840277dc83fb66
Subproject commit 348f4698db403c160322cf85d1d199584765ac55
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