never executed always true always false
1 {-# LANGUAGE ScopedTypeVariables #-}
2 {-# LANGUAGE ViewPatterns #-}
3 {-# LANGUAGE TupleSections #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE DeriveFunctor #-}
7 module GHC.Iface.Ext.Utils where
8
9 import GHC.Prelude
10
11 import GHC.Core.Map.Type
12 import GHC.Driver.Session ( DynFlags )
13 import GHC.Driver.Ppr
14 import GHC.Data.FastString ( FastString, mkFastString )
15 import GHC.Iface.Type
16 import GHC.Core.Multiplicity
17 import GHC.Types.Name hiding (varName)
18 import GHC.Types.Name.Set
19 import GHC.Utils.Outputable hiding ( (<>) )
20 import qualified GHC.Utils.Outputable as O
21 import GHC.Types.SrcLoc
22 import GHC.CoreToIface
23 import GHC.Core.TyCon
24 import GHC.Core.TyCo.Rep
25 import GHC.Core.Type
26 import GHC.Types.Var
27 import GHC.Types.Var.Env
28 import GHC.Parser.Annotation
29 import qualified GHC.Data.Strict as Strict
30
31 import GHC.Iface.Ext.Types
32
33 import qualified Data.Map as M
34 import qualified Data.Set as S
35 import qualified Data.IntMap.Strict as IM
36 import qualified Data.Array as A
37 import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) )
38 import Data.Maybe ( maybeToList, mapMaybe)
39 import Data.Monoid
40 import Data.List (find)
41 import Data.Traversable ( for )
42 import Data.Coerce
43 import GHC.Utils.Monad.State.Strict hiding (get)
44 import Control.Monad.Trans.Reader
45 import qualified Data.Tree as Tree
46
47 type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]
48
49 generateReferencesMap
50 :: Foldable f
51 => f (HieAST a)
52 -> RefMap a
53 generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
54 where
55 go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
56 where
57 this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast
58
59 renderHieType :: DynFlags -> HieTypeFix -> String
60 renderHieType dflags ht = showSDoc dflags (ppr $ hieTypeToIface ht)
61
62 resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
63 resolveVisibility kind ty_args
64 = go (mkEmptyTCvSubst in_scope) kind ty_args
65 where
66 in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
67
68 go _ _ [] = []
69 go env ty ts
70 | Just ty' <- coreView ty
71 = go env ty' ts
72 go env (ForAllTy (Bndr tv vis) res) (t:ts)
73 | isVisibleArgFlag vis = (True , t) : ts'
74 | otherwise = (False, t) : ts'
75 where
76 ts' = go (extendTvSubst env tv t) res ts
77
78 go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps
79 = (True,t) : (go env res ts)
80
81 go env (TyVarTy tv) ts
82 | Just ki <- lookupTyVar env tv = go env ki ts
83 go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded
84
85 foldType :: (HieType a -> a) -> HieTypeFix -> a
86 foldType f (Roll t) = f $ fmap (foldType f) t
87
88 selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)
89 selectPoint hf (sl,sc) = getFirst $
90 flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(HiePath fs,ast) -> First $
91 case selectSmallestContaining (sp fs) ast of
92 Nothing -> Nothing
93 Just ast' -> Just ast'
94 where
95 sloc fs = mkRealSrcLoc fs sl sc
96 sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
97
98 findEvidenceUse :: NodeIdentifiers a -> [Name]
99 findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)]
100 where
101 xs = M.toList ni
102
103 data EvidenceInfo a
104 = EvidenceInfo
105 { evidenceVar :: Name
106 , evidenceSpan :: RealSrcSpan
107 , evidenceType :: a
108 , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)
109 } deriving (Eq,Ord,Functor)
110
111 instance (Outputable a) => Outputable (EvidenceInfo a) where
112 ppr (EvidenceInfo name span typ dets) =
113 hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $
114 pdets $$ (pprDefinedAt name)
115 where
116 pdets = case dets of
117 Nothing -> text "is a usage of an external evidence variable"
118 Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn)
119
120 getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a)
121 getEvidenceTreesAtPoint hf refmap point =
122 [t | Just ast <- pure $ selectPoint hf point
123 , n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast)
124 , Just t <- pure $ getEvidenceTree refmap n
125 ]
126
127 getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a))
128 getEvidenceTree refmap var = go emptyNameSet var
129 where
130 go seen var
131 | var `elemNameSet` seen = Nothing
132 | otherwise = do
133 xs <- M.lookup (Right var) refmap
134 case find (any isEvidenceBind . identInfo . snd) xs of
135 Just (sp,dets) -> do
136 typ <- identType dets
137 (evdet,children) <- getFirst $ foldMap First $ do
138 det <- S.toList $ identInfo dets
139 case det of
140 EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn ->
141 pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs)
142 EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[])
143 _ -> pure Nothing
144 pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children
145 -- It is externally bound
146 Nothing -> getFirst $ foldMap First $ do
147 (sp,dets) <- xs
148 if (any isEvidenceUse $ identInfo dets)
149 then do
150 case identType dets of
151 Nothing -> pure Nothing
152 Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) []
153 else pure Nothing
154
155 hieTypeToIface :: HieTypeFix -> IfaceType
156 hieTypeToIface = foldType go
157 where
158 go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
159 go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
160 go (HLitTy l) = IfaceLitTy l
161 go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
162 in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
163 go (HFunTy w a b) = IfaceFunTy VisArg w a b
164 go (HQualTy pred b) = IfaceFunTy InvisArg many_ty pred b
165 go (HCastTy a) = a
166 go HCoercionTy = IfaceTyVar "<coercion type>"
167 go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
168
169 -- This isn't fully faithful - we can't produce the 'Inferred' case
170 hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
171 hieToIfaceArgs (HieArgs xs) = go' xs
172 where
173 go' [] = IA_Nil
174 go' ((True ,x):xs) = IA_Arg x Required $ go' xs
175 go' ((False,x):xs) = IA_Arg x Specified $ go' xs
176
177 data HieTypeState
178 = HTS
179 { tyMap :: !(TypeMap TypeIndex)
180 , htyTable :: !(IM.IntMap HieTypeFlat)
181 , freshIndex :: !TypeIndex
182 }
183
184 initialHTS :: HieTypeState
185 initialHTS = HTS emptyTypeMap IM.empty 0
186
187 freshTypeIndex :: State HieTypeState TypeIndex
188 freshTypeIndex = do
189 index <- gets freshIndex
190 modify $ \hts -> hts { freshIndex = index+1 }
191 return index
192
193 compressTypes
194 :: HieASTs Type
195 -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
196 compressTypes asts = (a, arr)
197 where
198 (a, (HTS _ m i)) = flip runState initialHTS $
199 for asts $ \typ ->
200 getTypeIndex typ
201 arr = A.array (0,i-1) (IM.toList m)
202
203 recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix
204 recoverFullType i m = go i
205 where
206 go i = Roll $ fmap go (m A.! i)
207
208 getTypeIndex :: Type -> State HieTypeState TypeIndex
209 getTypeIndex t
210 | otherwise = do
211 tm <- gets tyMap
212 case lookupTypeMap tm t of
213 Just i -> return i
214 Nothing -> do
215 ht <- go t
216 extendHTS t ht
217 where
218 extendHTS t ht = do
219 i <- freshTypeIndex
220 modify $ \(HTS tm tt fi) ->
221 HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi
222 return i
223
224 go (TyVarTy v) = return $ HTyVarTy $ varName v
225 go ty@(AppTy _ _) = do
226 let (head,args) = splitAppTys ty
227 visArgs = HieArgs $ resolveVisibility (typeKind head) args
228 ai <- getTypeIndex head
229 argsi <- mapM getTypeIndex visArgs
230 return $ HAppTy ai argsi
231 go (TyConApp f xs) = do
232 let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs
233 is <- mapM getTypeIndex visArgs
234 return $ HTyConApp (toIfaceTyCon f) is
235 go (ForAllTy (Bndr v a) t) = do
236 k <- getTypeIndex (varType v)
237 i <- getTypeIndex t
238 return $ HForAllTy ((varName v,k),a) i
239 go (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) = do
240 ai <- getTypeIndex a
241 bi <- getTypeIndex b
242 wi <- getTypeIndex w
243 return $ case af of
244 InvisArg -> case w of Many -> HQualTy ai bi; _ -> error "Unexpected non-unrestricted predicate"
245 VisArg -> HFunTy wi ai bi
246 go (LitTy a) = return $ HLitTy $ toIfaceTyLit a
247 go (CastTy t _) = do
248 i <- getTypeIndex t
249 return $ HCastTy i
250 go (CoercionTy _) = return HCoercionTy
251
252 resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a)
253 resolveTyVarScopes asts = M.map go asts
254 where
255 go ast = resolveTyVarScopeLocal ast asts
256
257 resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a
258 resolveTyVarScopeLocal ast asts = go ast
259 where
260 resolveNameScope dets = dets{identInfo =
261 S.map resolveScope (identInfo dets)}
262 resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =
263 TyVarBind sc $ ResolvedScopes
264 [ LocalScope binding
265 | name <- names
266 , Just binding <- [getNameBinding name asts]
267 ]
268 resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =
269 TyVarBind sc $ ResolvedScopes
270 [ LocalScope binding
271 | name <- names
272 , Just binding <- [getNameBindingInClass name sp asts]
273 ]
274 resolveScope scope = scope
275 go (Node info span children) = Node info' span $ map go children
276 where
277 info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info)
278 updateNodeInfo i = i { nodeIdentifiers = idents }
279 where
280 idents = M.map resolveNameScope $ nodeIdentifiers i
281
282 getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span
283 getNameBinding n asts = do
284 (_,msp) <- getNameScopeAndBinding n asts
285 msp
286
287 getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope]
288 getNameScope n asts = do
289 (scopes,_) <- getNameScopeAndBinding n asts
290 return scopes
291
292 getNameBindingInClass
293 :: Name
294 -> Span
295 -> M.Map HiePath (HieAST a)
296 -> Maybe Span
297 getNameBindingInClass n sp asts = do
298 ast <- M.lookup (HiePath (srcSpanFile sp)) asts
299 getFirst $ foldMap First $ do
300 child <- flattenAst ast
301 dets <- maybeToList
302 $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child
303 let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
304 return (getFirst binding)
305
306 getNameScopeAndBinding
307 :: Name
308 -> M.Map HiePath (HieAST a)
309 -> Maybe ([Scope], Maybe Span)
310 getNameScopeAndBinding n asts = case nameSrcSpan n of
311 RealSrcSpan sp _ -> do -- @Maybe
312 ast <- M.lookup (HiePath (srcSpanFile sp)) asts
313 defNode <- selectLargestContainedBy sp ast
314 getFirst $ foldMap First $ do -- @[]
315 node <- flattenAst defNode
316 dets <- maybeToList
317 $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node
318 scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
319 let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
320 return $ Just (scopes, getFirst binding)
321 _ -> Nothing
322
323 getScopeFromContext :: ContextInfo -> Maybe [Scope]
324 getScopeFromContext (ValBind _ sc _) = Just [sc]
325 getScopeFromContext (PatternBind a b _) = Just [a, b]
326 getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
327 getScopeFromContext (Decl _ _) = Just [ModuleScope]
328 getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
329 getScopeFromContext (TyVarBind a _) = Just [a]
330 getScopeFromContext (EvidenceVarBind _ a _) = Just [a]
331 getScopeFromContext _ = Nothing
332
333 getBindSiteFromContext :: ContextInfo -> Maybe Span
334 getBindSiteFromContext (ValBind _ _ sp) = sp
335 getBindSiteFromContext (PatternBind _ _ sp) = sp
336 getBindSiteFromContext _ = Nothing
337
338 flattenAst :: HieAST a -> [HieAST a]
339 flattenAst n =
340 n : concatMap flattenAst (nodeChildren n)
341
342 smallestContainingSatisfying
343 :: Span
344 -> (HieAST a -> Bool)
345 -> HieAST a
346 -> Maybe (HieAST a)
347 smallestContainingSatisfying sp cond node
348 | nodeSpan node `containsSpan` sp = getFirst $ mconcat
349 [ foldMap (First . smallestContainingSatisfying sp cond) $
350 nodeChildren node
351 , First $ if cond node then Just node else Nothing
352 ]
353 | sp `containsSpan` nodeSpan node = Nothing
354 | otherwise = Nothing
355
356 selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)
357 selectLargestContainedBy sp node
358 | sp `containsSpan` nodeSpan node = Just node
359 | nodeSpan node `containsSpan` sp =
360 getFirst $ foldMap (First . selectLargestContainedBy sp) $
361 nodeChildren node
362 | otherwise = Nothing
363
364 selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)
365 selectSmallestContaining sp node
366 | nodeSpan node `containsSpan` sp = getFirst $ mconcat
367 [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node
368 , First (Just node)
369 ]
370 | sp `containsSpan` nodeSpan node = Nothing
371 | otherwise = Nothing
372
373 definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool
374 definedInAsts asts n = case nameSrcSpan n of
375 RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts
376 _ -> False
377
378 getEvidenceBindDeps :: ContextInfo -> [Name]
379 getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) =
380 getEvBindDeps xs
381 getEvidenceBindDeps _ = []
382
383 isEvidenceBind :: ContextInfo -> Bool
384 isEvidenceBind EvidenceVarBind{} = True
385 isEvidenceBind _ = False
386
387 isEvidenceContext :: ContextInfo -> Bool
388 isEvidenceContext EvidenceVarUse = True
389 isEvidenceContext EvidenceVarBind{} = True
390 isEvidenceContext _ = False
391
392 isEvidenceUse :: ContextInfo -> Bool
393 isEvidenceUse EvidenceVarUse = True
394 isEvidenceUse _ = False
395
396 isOccurrence :: ContextInfo -> Bool
397 isOccurrence Use = True
398 isOccurrence EvidenceVarUse = True
399 isOccurrence _ = False
400
401 scopeContainsSpan :: Scope -> Span -> Bool
402 scopeContainsSpan NoScope _ = False
403 scopeContainsSpan ModuleScope _ = True
404 scopeContainsSpan (LocalScope a) b = a `containsSpan` b
405
406 -- | One must contain the other. Leaf nodes cannot contain anything
407 combineAst :: HieAST Type -> HieAST Type -> HieAST Type
408 combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)
409 | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys)
410 | aSpn `containsSpan` bSpn = combineAst b a
411 combineAst a (Node xs span children) = Node xs span (insertAst a children)
412
413 -- | Insert an AST in a sorted list of disjoint Asts
414 insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
415 insertAst x = mergeAsts [x]
416
417 nodeInfo :: HieAST Type -> NodeInfo Type
418 nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo
419
420 emptyNodeInfo :: NodeInfo a
421 emptyNodeInfo = NodeInfo S.empty [] M.empty
422
423 sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a
424 sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo
425
426 combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type
427 combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo
428
429 -- | Merge two nodes together.
430 --
431 -- Precondition and postcondition: elements in 'nodeType' are ordered.
432 combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
433 (NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =
434 NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)
435 where
436 mergeSorted :: [Type] -> [Type] -> [Type]
437 mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of
438 LT -> a : mergeSorted as lb
439 EQ -> a : mergeSorted as bs
440 GT -> b : mergeSorted la bs
441 mergeSorted as [] = as
442 mergeSorted [] bs = bs
443
444
445 {- | Merge two sorted, disjoint lists of ASTs, combining when necessary.
446
447 In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),
448 different nodes in an AST tree should either have disjoint spans (in
449 which case you can say for sure which one comes first) or one span
450 should be completely contained in the other (in which case the contained
451 span corresponds to some child node).
452
453 However, since Haskell does have position-altering pragmas it /is/
454 possible for spans to be overlapping. Here is an example of a source file
455 in which @foozball@ and @quuuuuux@ have overlapping spans:
456
457 @
458 module Baz where
459
460 # line 3 "Baz.hs"
461 foozball :: Int
462 foozball = 0
463
464 # line 3 "Baz.hs"
465 bar, quuuuuux :: Int
466 bar = 1
467 quuuuuux = 2
468 @
469
470 In these cases, we just do our best to produce sensible `HieAST`'s. The blame
471 should be laid at the feet of whoever wrote the line pragmas in the first place
472 (usually the C preprocessor...).
473 -}
474 mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
475 mergeAsts xs [] = xs
476 mergeAsts [] ys = ys
477 mergeAsts xs@(a:as) ys@(b:bs)
478 | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs
479 | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs)
480 | span_a `rightOf` span_b = b : mergeAsts xs bs
481 | span_a `leftOf` span_b = a : mergeAsts as ys
482
483 -- These cases are to work around ASTs that are not fully disjoint
484 | span_a `startsRightOf` span_b = b : mergeAsts as ys
485 | otherwise = a : mergeAsts as ys
486 where
487 span_a = nodeSpan a
488 span_b = nodeSpan b
489
490 rightOf :: Span -> Span -> Bool
491 rightOf s1 s2
492 = (srcSpanStartLine s1, srcSpanStartCol s1)
493 >= (srcSpanEndLine s2, srcSpanEndCol s2)
494 && (srcSpanFile s1 == srcSpanFile s2)
495
496 leftOf :: Span -> Span -> Bool
497 leftOf s1 s2
498 = (srcSpanEndLine s1, srcSpanEndCol s1)
499 <= (srcSpanStartLine s2, srcSpanStartCol s2)
500 && (srcSpanFile s1 == srcSpanFile s2)
501
502 startsRightOf :: Span -> Span -> Bool
503 startsRightOf s1 s2
504 = (srcSpanStartLine s1, srcSpanStartCol s1)
505 >= (srcSpanStartLine s2, srcSpanStartCol s2)
506
507 -- | combines and sorts ASTs using a merge sort
508 mergeSortAsts :: [HieAST Type] -> [HieAST Type]
509 mergeSortAsts = go . map pure
510 where
511 go [] = []
512 go [xs] = xs
513 go xss = go (mergePairs xss)
514 mergePairs [] = []
515 mergePairs [xs] = [xs]
516 mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss
517
518 simpleNodeInfo :: FastString -> FastString -> NodeInfo a
519 simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty
520
521 locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]
522 locOnly (RealSrcSpan span _) = do
523 org <- ask
524 let e = mkSourcedNodeInfo org $ emptyNodeInfo
525 pure [Node e span []]
526 locOnly _ = pure []
527
528 mkScopeA :: SrcSpanAnn' ann -> Scope
529 mkScopeA l = mkScope (locA l)
530
531 mkScope :: SrcSpan -> Scope
532 mkScope (RealSrcSpan sp _) = LocalScope sp
533 mkScope _ = NoScope
534
535 mkLScope :: Located a -> Scope
536 mkLScope = mkScope . getLoc
537
538 mkLScopeA :: GenLocated (SrcSpanAnn' a) e -> Scope
539 mkLScopeA = mkScope . locA . getLoc
540
541 mkLScopeN :: LocatedN a -> Scope
542 mkLScopeN = mkScope . getLocA
543
544 combineScopes :: Scope -> Scope -> Scope
545 combineScopes ModuleScope _ = ModuleScope
546 combineScopes _ ModuleScope = ModuleScope
547 combineScopes NoScope x = x
548 combineScopes x NoScope = x
549 combineScopes (LocalScope a) (LocalScope b) =
550 mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing)
551
552 mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
553 mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
554
555 {-# INLINEABLE makeNodeA #-}
556 makeNodeA
557 :: (Monad m, Data a)
558 => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
559 -> SrcSpanAnn' ann -- ^ return an empty list if this is unhelpful
560 -> ReaderT NodeOrigin m [HieAST b]
561 makeNodeA x spn = makeNode x (locA spn)
562
563 {-# INLINEABLE makeNode #-}
564 makeNode
565 :: (Monad m, Data a)
566 => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
567 -> SrcSpan -- ^ return an empty list if this is unhelpful
568 -> ReaderT NodeOrigin m [HieAST b]
569 makeNode x spn = do
570 org <- ask
571 pure $ case spn of
572 RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]
573 _ -> []
574 where
575 cons = mkFastString . show . toConstr $ x
576 typ = mkFastString . show . typeRepTyCon . typeOf $ x
577
578 {-# INLINEABLE makeTypeNodeA #-}
579 makeTypeNodeA
580 :: (Monad m, Data a)
581 => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
582 -> SrcSpanAnnA -- ^ return an empty list if this is unhelpful
583 -> Type -- ^ type to associate with the node
584 -> ReaderT NodeOrigin m [HieAST Type]
585 makeTypeNodeA x spn etyp = makeTypeNode x (locA spn) etyp
586
587 {-# INLINEABLE makeTypeNode #-}
588 makeTypeNode
589 :: (Monad m, Data a)
590 => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
591 -> SrcSpan -- ^ return an empty list if this is unhelpful
592 -> Type -- ^ type to associate with the node
593 -> ReaderT NodeOrigin m [HieAST Type]
594 makeTypeNode x spn etyp = do
595 org <- ask
596 pure $ case spn of
597 RealSrcSpan span _ ->
598 [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []]
599 _ -> []
600 where
601 cons = mkFastString . show . toConstr $ x
602 typ = mkFastString . show . typeRepTyCon . typeOf $ x