2ab2acbe3fa6bb355d0a0ea1f59ab92a6df69d2b
[ghc.git] / compiler / hieFile / HieAst.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE TypeSynonymInstances #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeFamilies #-}
8 {-# LANGUAGE TypeApplications #-}
9 {-# LANGUAGE AllowAmbiguousTypes #-}
10 {-# LANGUAGE ViewPatterns #-}
11 {-# LANGUAGE DeriveDataTypeable #-}
12 module HieAst ( mkHieFile ) where
13
14 import GhcPrelude
15
16 import Avail ( Avails )
17 import Bag ( Bag, bagToList )
18 import BasicTypes
19 import BooleanFormula
20 import Class ( FunDep )
21 import CoreUtils ( exprType )
22 import ConLike ( conLikeName )
23 import Config ( cProjectVersion )
24 import Desugar ( deSugarExpr )
25 import FieldLabel
26 import HsSyn
27 import HscTypes
28 import Module ( ModuleName, ml_hs_file )
29 import MonadUtils ( concatMapM, liftIO )
30 import Name ( Name, nameSrcSpan, setNameLoc )
31 import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
32 import SrcLoc
33 import TcHsSyn ( hsLitType, hsPatType )
34 import Type ( mkVisFunTys, Type )
35 import TysWiredIn ( mkListTy, mkSumTy )
36 import Var ( Id, Var, setVarName, varName, varType )
37 import TcRnTypes
38 import MkIface ( mkIfaceExports )
39
40 import HieTypes
41 import HieUtils
42
43 import qualified Data.Array as A
44 import qualified Data.ByteString as BS
45 import qualified Data.ByteString.Char8 as BSC
46 import qualified Data.Map as M
47 import qualified Data.Set as S
48 import Data.Data ( Data, Typeable )
49 import Data.List ( foldl1' )
50 import Data.Maybe ( listToMaybe )
51 import Control.Monad.Trans.Reader
52 import Control.Monad.Trans.Class ( lift )
53
54 -- These synonyms match those defined in main/GHC.hs
55 type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
56 , Maybe [(LIE GhcRn, Avails)]
57 , Maybe LHsDocString )
58 type TypecheckedSource = LHsBinds GhcTc
59
60
61 {- Note [Name Remapping]
62 The Typechecker introduces new names for mono names in AbsBinds.
63 We don't care about the distinction between mono and poly bindings,
64 so we replace all occurrences of the mono name with the poly name.
65 -}
66 newtype HieState = HieState
67 { name_remapping :: NameEnv Id
68 }
69
70 initState :: HieState
71 initState = HieState emptyNameEnv
72
73 class ModifyState a where -- See Note [Name Remapping]
74 addSubstitution :: a -> a -> HieState -> HieState
75
76 instance ModifyState Name where
77 addSubstitution _ _ hs = hs
78
79 instance ModifyState Id where
80 addSubstitution mono poly hs =
81 hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
82
83 modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
84 modifyState = foldr go id
85 where
86 go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
87 go _ f = f
88
89 type HieM = ReaderT HieState Hsc
90
91 -- | Construct an 'HieFile' from the outputs of the typechecker.
92 mkHieFile :: ModSummary
93 -> TcGblEnv
94 -> RenamedSource -> Hsc HieFile
95 mkHieFile ms ts rs = do
96 let tc_binds = tcg_binds ts
97 (asts', arr) <- getCompressedAsts tc_binds rs
98 let Just src_file = ml_hs_file $ ms_location ms
99 src <- liftIO $ BS.readFile src_file
100 return $ HieFile
101 { hie_version = curHieVersion
102 , hie_ghc_version = BSC.pack cProjectVersion
103 , hie_hs_file = src_file
104 , hie_module = ms_mod ms
105 , hie_types = arr
106 , hie_asts = asts'
107 -- mkIfaceExports sorts the AvailInfos for stability
108 , hie_exports = mkIfaceExports (tcg_exports ts)
109 , hie_hs_src = src
110 }
111
112 getCompressedAsts :: TypecheckedSource -> RenamedSource
113 -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
114 getCompressedAsts ts rs = do
115 asts <- enrichHie ts rs
116 return $ compressTypes asts
117
118 enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
119 enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
120 tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
121 rasts <- processGrp hsGrp
122 imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
123 exps <- toHie $ fmap (map $ IEC Export . fst) exports
124 let spanFile children = case children of
125 [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
126 _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
127 (realSrcSpanEnd $ nodeSpan $ last children)
128
129 modulify xs =
130 Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
131
132 asts = HieASTs
133 $ resolveTyVarScopes
134 $ M.map (modulify . mergeSortAsts)
135 $ M.fromListWith (++)
136 $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
137
138 flat_asts = concat
139 [ tasts
140 , rasts
141 , imps
142 , exps
143 ]
144 return asts
145 where
146 processGrp grp = concatM
147 [ toHie $ fmap (RS ModuleScope ) hs_valds grp
148 , toHie $ hs_splcds grp
149 , toHie $ hs_tyclds grp
150 , toHie $ hs_derivds grp
151 , toHie $ hs_fixds grp
152 , toHie $ hs_defds grp
153 , toHie $ hs_fords grp
154 , toHie $ hs_warnds grp
155 , toHie $ hs_annds grp
156 , toHie $ hs_ruleds grp
157 ]
158
159 getRealSpan :: SrcSpan -> Maybe Span
160 getRealSpan (RealSrcSpan sp) = Just sp
161 getRealSpan _ = Nothing
162
163 grhss_span :: GRHSs p body -> SrcSpan
164 grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
165 grhss_span (XGRHSs _) = error "XGRHS has no span"
166
167 bindingsOnly :: [Context Name] -> [HieAST a]
168 bindingsOnly [] = []
169 bindingsOnly (C c n : xs) = case nameSrcSpan n of
170 RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
171 where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
172 info = mempty{identInfo = S.singleton c}
173 _ -> bindingsOnly xs
174
175 concatM :: Monad m => [m [a]] -> m [a]
176 concatM xs = concat <$> sequence xs
177
178 {- Note [Capturing Scopes and other non local information]
179 toHie is a local tranformation, but scopes of bindings cannot be known locally,
180 hence we have to push the relevant info down into the binding nodes.
181 We use the following types (*Context and *Scoped) to wrap things and
182 carry the required info
183 (Maybe Span) always carries the span of the entire binding, including rhs
184 -}
185 data Context a = C ContextInfo a -- Used for names and bindings
186
187 data RContext a = RC RecFieldContext a
188 data RFContext a = RFC RecFieldContext (Maybe Span) a
189 -- ^ context for record fields
190
191 data IEContext a = IEC IEType a
192 -- ^ context for imports/exports
193
194 data BindContext a = BC BindType Scope a
195 -- ^ context for imports/exports
196
197 data PatSynFieldContext a = PSC (Maybe Span) a
198 -- ^ context for pattern synonym fields.
199
200 data SigContext a = SC SigInfo a
201 -- ^ context for type signatures
202
203 data SigInfo = SI SigType (Maybe Span)
204
205 data SigType = BindSig | ClassSig | InstSig
206
207 data RScoped a = RS Scope a
208 -- ^ Scope spans over everything to the right of a, (mostly) not
209 -- including a itself
210 -- (Includes a in a few special cases like recursive do bindings) or
211 -- let/where bindings
212
213 -- | Pattern scope
214 data PScoped a = PS (Maybe Span)
215 Scope -- ^ use site of the pattern
216 Scope -- ^ pattern to the right of a, not including a
217 a
218 deriving (Typeable, Data) -- Pattern Scope
219
220 {- Note [TyVar Scopes]
221 Due to -XScopedTypeVariables, type variables can be in scope quite far from
222 their original binding. We resolve the scope of these type variables
223 in a separate pass
224 -}
225 data TScoped a = TS TyVarScope a -- TyVarScope
226
227 data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
228 -- ^ First scope remains constant
229 -- Second scope is used to build up the scope of a tyvar over
230 -- things to its right, ala RScoped
231
232 -- | Each element scopes over the elements to the right
233 listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
234 listScopes _ [] = []
235 listScopes rhsScope [pat] = [RS rhsScope pat]
236 listScopes rhsScope (pat : pats) = RS sc pat : pats'
237 where
238 pats'@((RS scope p):_) = listScopes rhsScope pats
239 sc = combineScopes scope $ mkScope $ getLoc p
240
241 -- | 'listScopes' specialised to 'PScoped' things
242 patScopes
243 :: Maybe Span
244 -> Scope
245 -> Scope
246 -> [LPat (GhcPass p)]
247 -> [PScoped (LPat (GhcPass p))]
248 patScopes rsp useScope patScope xs =
249 map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
250 listScopes patScope (map dL xs)
251
252 -- | 'listScopes' specialised to 'TVScoped' things
253 tvScopes
254 :: TyVarScope
255 -> Scope
256 -> [LHsTyVarBndr a]
257 -> [TVScoped (LHsTyVarBndr a)]
258 tvScopes tvScope rhsScope xs =
259 map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
260
261 {- Note [Scoping Rules for SigPat]
262 Explicitly quantified variables in pattern type signatures are not
263 brought into scope in the rhs, but implicitly quantified variables
264 are (HsWC and HsIB).
265 This is unlike other signatures, where explicitly quantified variables
266 are brought into the RHS Scope
267 For example
268 foo :: forall a. ...;
269 foo = ... -- a is in scope here
270
271 bar (x :: forall a. a -> a) = ... -- a is not in scope here
272 -- ^ a is in scope here (pattern body)
273
274 bax (x :: a) = ... -- a is in scope here
275 Because of HsWC and HsIB pass on their scope to their children
276 we must wrap the LHsType in pattern signatures in a
277 Shielded explictly, so that the HsWC/HsIB scope is not passed
278 on the the LHsType
279 -}
280
281 data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
282
283 type family ProtectedSig a where
284 ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
285 GhcRn
286 (Shielded (LHsType GhcRn)))
287 ProtectedSig GhcTc = NoExt
288
289 class ProtectSig a where
290 protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
291
292 instance (HasLoc a) => HasLoc (Shielded a) where
293 loc (SH _ a) = loc a
294
295 instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
296 toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
297
298 instance ProtectSig GhcTc where
299 protectSig _ _ = NoExt
300
301 instance ProtectSig GhcRn where
302 protectSig sc (HsWC a (HsIB b sig)) =
303 HsWC a (HsIB b (SH sc sig))
304 protectSig _ _ = error "protectSig not given HsWC (HsIB)"
305
306 class HasLoc a where
307 -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
308 -- know what their implicit bindings are scoping over
309 loc :: a -> SrcSpan
310
311 instance HasLoc thing => HasLoc (TScoped thing) where
312 loc (TS _ a) = loc a
313
314 instance HasLoc thing => HasLoc (PScoped thing) where
315 loc (PS _ _ _ a) = loc a
316
317 instance HasLoc (LHsQTyVars GhcRn) where
318 loc (HsQTvs _ vs) = loc vs
319 loc _ = noSrcSpan
320
321 instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
322 loc (HsIB _ a) = loc a
323 loc _ = noSrcSpan
324
325 instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
326 loc (HsWC _ a) = loc a
327 loc _ = noSrcSpan
328
329 instance HasLoc (Located a) where
330 loc (L l _) = l
331
332 instance HasLoc a => HasLoc [a] where
333 loc [] = noSrcSpan
334 loc xs = foldl1' combineSrcSpans $ map loc xs
335
336 instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
337 loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
338 loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
339 [loc a, loc tvs, loc b, loc c]
340 loc _ = noSrcSpan
341 instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
342 loc (HsValArg tm) = loc tm
343 loc (HsTypeArg _ ty) = loc ty
344 loc (HsArgPar sp) = sp
345
346 instance HasLoc (HsDataDefn GhcRn) where
347 loc def@(HsDataDefn{}) = loc $ dd_cons def
348 -- Only used for data family instances, so we only need rhs
349 -- Most probably the rest will be unhelpful anyway
350 loc _ = noSrcSpan
351
352 instance HasLoc (Pat (GhcPass a)) where
353 loc (dL -> L l _) = l
354
355 -- | The main worker class
356 class ToHie a where
357 toHie :: a -> HieM [HieAST Type]
358
359 -- | Used to collect type info
360 class Data a => HasType a where
361 getTypeNode :: a -> HieM [HieAST Type]
362
363 instance (ToHie a) => ToHie [a] where
364 toHie = concatMapM toHie
365
366 instance (ToHie a) => ToHie (Bag a) where
367 toHie = toHie . bagToList
368
369 instance (ToHie a) => ToHie (Maybe a) where
370 toHie = maybe (pure []) toHie
371
372 instance ToHie (Context (Located NoExt)) where
373 toHie _ = pure []
374
375 instance ToHie (TScoped NoExt) where
376 toHie _ = pure []
377
378 instance ToHie (IEContext (Located ModuleName)) where
379 toHie (IEC c (L (RealSrcSpan span) mname)) =
380 pure $ [Node (NodeInfo S.empty [] idents) span []]
381 where details = mempty{identInfo = S.singleton (IEThing c)}
382 idents = M.singleton (Left mname) details
383 toHie _ = pure []
384
385 instance ToHie (Context (Located Var)) where
386 toHie c = case c of
387 C context (L (RealSrcSpan span) name')
388 -> do
389 m <- asks name_remapping
390 let name = case lookupNameEnv m (varName name') of
391 Just var -> var
392 Nothing-> name'
393 pure
394 [Node
395 (NodeInfo S.empty [] $
396 M.singleton (Right $ varName name)
397 (IdentifierDetails (Just $ varType name')
398 (S.singleton context)))
399 span
400 []]
401 _ -> pure []
402
403 instance ToHie (Context (Located Name)) where
404 toHie c = case c of
405 C context (L (RealSrcSpan span) name') -> do
406 m <- asks name_remapping
407 let name = case lookupNameEnv m name' of
408 Just var -> varName var
409 Nothing -> name'
410 pure
411 [Node
412 (NodeInfo S.empty [] $
413 M.singleton (Right name)
414 (IdentifierDetails Nothing
415 (S.singleton context)))
416 span
417 []]
418 _ -> pure []
419
420 -- | Dummy instances - never called
421 instance ToHie (TScoped (LHsSigWcType GhcTc)) where
422 toHie _ = pure []
423 instance ToHie (TScoped (LHsWcType GhcTc)) where
424 toHie _ = pure []
425 instance ToHie (SigContext (LSig GhcTc)) where
426 toHie _ = pure []
427 instance ToHie (TScoped Type) where
428 toHie _ = pure []
429
430 instance HasType (LHsBind GhcRn) where
431 getTypeNode (L spn bind) = makeNode bind spn
432
433 instance HasType (LHsBind GhcTc) where
434 getTypeNode (L spn bind) = case bind of
435 FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
436 _ -> makeNode bind spn
437
438 instance HasType (LPat GhcRn) where
439 getTypeNode (dL -> L spn pat) = makeNode pat spn
440
441 instance HasType (LPat GhcTc) where
442 getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
443
444 instance HasType (LHsExpr GhcRn) where
445 getTypeNode (L spn e) = makeNode e spn
446
447 -- | This instance tries to construct 'HieAST' nodes which include the type of
448 -- the expression. It is not yet possible to do this efficiently for all
449 -- expression forms, so we skip filling in the type for those inputs.
450 --
451 -- 'HsApp', for example, doesn't have any type information available directly on
452 -- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
453 -- query the type of that. Yet both the desugaring call and the type query both
454 -- involve recursive calls to the function and argument! This is particularly
455 -- problematic when you realize that the HIE traversal will eventually visit
456 -- those nodes too and ask for their types again.
457 --
458 -- Since the above is quite costly, we just skip cases where computing the
459 -- expression's type is going to be expensive.
460 --
461 -- See #16233
462 instance HasType (LHsExpr GhcTc) where
463 getTypeNode e@(L spn e') = lift $
464 -- Some expression forms have their type immediately available
465 let tyOpt = case e' of
466 HsLit _ l -> Just (hsLitType l)
467 HsOverLit _ o -> Just (overLitType o)
468
469 HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
470 HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
471 HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
472
473 ExplicitList ty _ _ -> Just (mkListTy ty)
474 ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
475 HsDo ty _ _ -> Just ty
476 HsMultiIf ty _ -> Just ty
477
478 _ -> Nothing
479
480 in
481 case tyOpt of
482 _ | skipDesugaring e' -> fallback
483 | otherwise -> do
484 hs_env <- Hsc $ \e w -> return (e,w)
485 (_,mbe) <- liftIO $ deSugarExpr hs_env e
486 maybe fallback (makeTypeNode e' spn . exprType) mbe
487 where
488 fallback = makeNode e' spn
489
490 matchGroupType :: MatchGroupTc -> Type
491 matchGroupType (MatchGroupTc args res) = mkVisFunTys args res
492
493 -- | Skip desugaring of these expressions for performance reasons.
494 --
495 -- See impact on Haddock output (esp. missing type annotations or links)
496 -- before marking more things here as 'False'. See impact on Haddock
497 -- performance before marking more things as 'True'.
498 skipDesugaring :: HsExpr a -> Bool
499 skipDesugaring e = case e of
500 HsVar{} -> False
501 HsUnboundVar{} -> False
502 HsConLikeOut{} -> False
503 HsRecFld{} -> False
504 HsOverLabel{} -> False
505 HsIPVar{} -> False
506 HsWrap{} -> False
507 _ -> True
508
509 instance ( ToHie (Context (Located (IdP a)))
510 , ToHie (MatchGroup a (LHsExpr a))
511 , ToHie (PScoped (LPat a))
512 , ToHie (GRHSs a (LHsExpr a))
513 , ToHie (LHsExpr a)
514 , ToHie (Located (PatSynBind a a))
515 , HasType (LHsBind a)
516 , ModifyState (IdP a)
517 , Data (HsBind a)
518 ) => ToHie (BindContext (LHsBind a)) where
519 toHie (BC context scope b@(L span bind)) =
520 concatM $ getTypeNode b : case bind of
521 FunBind{fun_id = name, fun_matches = matches} ->
522 [ toHie $ C (ValBind context scope $ getRealSpan span) name
523 , toHie matches
524 ]
525 PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
526 [ toHie $ PS (getRealSpan span) scope NoScope lhs
527 , toHie rhs
528 ]
529 VarBind{var_rhs = expr} ->
530 [ toHie expr
531 ]
532 AbsBinds{abs_exports = xs, abs_binds = binds} ->
533 [ local (modifyState xs) $ -- Note [Name Remapping]
534 toHie $ fmap (BC context scope) binds
535 ]
536 PatSynBind _ psb ->
537 [ toHie $ L span psb -- PatSynBinds only occur at the top level
538 ]
539 XHsBindsLR _ -> []
540
541 instance ( ToHie (LMatch a body)
542 ) => ToHie (MatchGroup a body) where
543 toHie mg = concatM $ case mg of
544 MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
545 [ pure $ locOnly span
546 , toHie alts
547 ]
548 MG{} -> []
549 XMatchGroup _ -> []
550
551 instance ( ToHie (Context (Located (IdP a)))
552 , ToHie (PScoped (LPat a))
553 , ToHie (HsPatSynDir a)
554 ) => ToHie (Located (PatSynBind a a)) where
555 toHie (L sp psb) = concatM $ case psb of
556 PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
557 [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
558 , toHie $ toBind dets
559 , toHie $ PS Nothing lhsScope NoScope pat
560 , toHie dir
561 ]
562 where
563 lhsScope = combineScopes varScope detScope
564 varScope = mkLScope var
565 detScope = case dets of
566 (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
567 (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
568 (RecCon r) -> foldr go NoScope r
569 go (RecordPatSynField a b) c = combineScopes c
570 $ combineScopes (mkLScope a) (mkLScope b)
571 detSpan = case detScope of
572 LocalScope a -> Just a
573 _ -> Nothing
574 toBind (PrefixCon args) = PrefixCon $ map (C Use) args
575 toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
576 toBind (RecCon r) = RecCon $ map (PSC detSpan) r
577 XPatSynBind _ -> []
578
579 instance ( ToHie (MatchGroup a (LHsExpr a))
580 ) => ToHie (HsPatSynDir a) where
581 toHie dir = case dir of
582 ExplicitBidirectional mg -> toHie mg
583 _ -> pure []
584
585 instance ( a ~ GhcPass p
586 , ToHie body
587 , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
588 , ToHie (PScoped (LPat a))
589 , ToHie (GRHSs a body)
590 , Data (Match a body)
591 ) => ToHie (LMatch (GhcPass p) body) where
592 toHie (L span m ) = concatM $ makeNode m span : case m of
593 Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
594 [ toHie mctx
595 , let rhsScope = mkScope $ grhss_span grhss
596 in toHie $ patScopes Nothing rhsScope NoScope pats
597 , toHie grhss
598 ]
599 XMatch _ -> []
600
601 instance ( ToHie (Context (Located a))
602 ) => ToHie (HsMatchContext a) where
603 toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
604 toHie (StmtCtxt a) = toHie a
605 toHie _ = pure []
606
607 instance ( ToHie (HsMatchContext a)
608 ) => ToHie (HsStmtContext a) where
609 toHie (PatGuard a) = toHie a
610 toHie (ParStmtCtxt a) = toHie a
611 toHie (TransStmtCtxt a) = toHie a
612 toHie _ = pure []
613
614 instance ( a ~ GhcPass p
615 , ToHie (Context (Located (IdP a)))
616 , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
617 , ToHie (LHsExpr a)
618 , ToHie (TScoped (LHsSigWcType a))
619 , ProtectSig a
620 , ToHie (TScoped (ProtectedSig a))
621 , HasType (LPat a)
622 , Data (HsSplice a)
623 ) => ToHie (PScoped (LPat (GhcPass p))) where
624 toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
625 concatM $ getTypeNode lpat : case opat of
626 WildPat _ ->
627 []
628 VarPat _ lname ->
629 [ toHie $ C (PatternBind scope pscope rsp) lname
630 ]
631 LazyPat _ p ->
632 [ toHie $ PS rsp scope pscope p
633 ]
634 AsPat _ lname pat ->
635 [ toHie $ C (PatternBind scope
636 (combineScopes (mkLScope (dL pat)) pscope)
637 rsp)
638 lname
639 , toHie $ PS rsp scope pscope pat
640 ]
641 ParPat _ pat ->
642 [ toHie $ PS rsp scope pscope pat
643 ]
644 BangPat _ pat ->
645 [ toHie $ PS rsp scope pscope pat
646 ]
647 ListPat _ pats ->
648 [ toHie $ patScopes rsp scope pscope pats
649 ]
650 TuplePat _ pats _ ->
651 [ toHie $ patScopes rsp scope pscope pats
652 ]
653 SumPat _ pat _ _ ->
654 [ toHie $ PS rsp scope pscope pat
655 ]
656 ConPatIn c dets ->
657 [ toHie $ C Use c
658 , toHie $ contextify dets
659 ]
660 ConPatOut {pat_con = con, pat_args = dets}->
661 [ toHie $ C Use $ fmap conLikeName con
662 , toHie $ contextify dets
663 ]
664 ViewPat _ expr pat ->
665 [ toHie expr
666 , toHie $ PS rsp scope pscope pat
667 ]
668 SplicePat _ sp ->
669 [ toHie $ L ospan sp
670 ]
671 LitPat _ _ ->
672 []
673 NPat _ _ _ _ ->
674 []
675 NPlusKPat _ n _ _ _ _ ->
676 [ toHie $ C (PatternBind scope pscope rsp) n
677 ]
678 SigPat _ pat sig ->
679 [ toHie $ PS rsp scope pscope pat
680 , let cscope = mkLScope (dL pat) in
681 toHie $ TS (ResolvedScopes [cscope, scope, pscope])
682 (protectSig @a cscope sig)
683 -- See Note [Scoping Rules for SigPat]
684 ]
685 CoPat _ _ _ _ ->
686 []
687 XPat _ -> []
688 where
689 contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
690 contextify (InfixCon a b) = InfixCon a' b'
691 where [a', b'] = patScopes rsp scope pscope [a,b]
692 contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
693 contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
694 where
695 go (RS fscope (L spn (HsRecField lbl pat pun))) =
696 L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
697 scoped_fds = listScopes pscope fds
698
699 instance ( ToHie body
700 , ToHie (LGRHS a body)
701 , ToHie (RScoped (LHsLocalBinds a))
702 ) => ToHie (GRHSs a body) where
703 toHie grhs = concatM $ case grhs of
704 GRHSs _ grhss binds ->
705 [ toHie grhss
706 , toHie $ RS (mkScope $ grhss_span grhs) binds
707 ]
708 XGRHSs _ -> []
709
710 instance ( ToHie (Located body)
711 , ToHie (RScoped (GuardLStmt a))
712 , Data (GRHS a (Located body))
713 ) => ToHie (LGRHS a (Located body)) where
714 toHie (L span g) = concatM $ makeNode g span : case g of
715 GRHS _ guards body ->
716 [ toHie $ listScopes (mkLScope body) guards
717 , toHie body
718 ]
719 XGRHS _ -> []
720
721 instance ( a ~ GhcPass p
722 , ToHie (Context (Located (IdP a)))
723 , HasType (LHsExpr a)
724 , ToHie (PScoped (LPat a))
725 , ToHie (MatchGroup a (LHsExpr a))
726 , ToHie (LGRHS a (LHsExpr a))
727 , ToHie (RContext (HsRecordBinds a))
728 , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
729 , ToHie (ArithSeqInfo a)
730 , ToHie (LHsCmdTop a)
731 , ToHie (RScoped (GuardLStmt a))
732 , ToHie (RScoped (LHsLocalBinds a))
733 , ToHie (TScoped (LHsWcType (NoGhcTc a)))
734 , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
735 , Data (HsExpr a)
736 , Data (HsSplice a)
737 , Data (HsTupArg a)
738 , Data (AmbiguousFieldOcc a)
739 ) => ToHie (LHsExpr (GhcPass p)) where
740 toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
741 HsVar _ (L _ var) ->
742 [ toHie $ C Use (L mspan var)
743 -- Patch up var location since typechecker removes it
744 ]
745 HsUnboundVar _ _ ->
746 []
747 HsConLikeOut _ con ->
748 [ toHie $ C Use $ L mspan $ conLikeName con
749 ]
750 HsRecFld _ fld ->
751 [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
752 ]
753 HsOverLabel _ _ _ -> []
754 HsIPVar _ _ -> []
755 HsOverLit _ _ -> []
756 HsLit _ _ -> []
757 HsLam _ mg ->
758 [ toHie mg
759 ]
760 HsLamCase _ mg ->
761 [ toHie mg
762 ]
763 HsApp _ a b ->
764 [ toHie a
765 , toHie b
766 ]
767 HsAppType _ expr sig ->
768 [ toHie expr
769 , toHie $ TS (ResolvedScopes []) sig
770 ]
771 OpApp _ a b c ->
772 [ toHie a
773 , toHie b
774 , toHie c
775 ]
776 NegApp _ a _ ->
777 [ toHie a
778 ]
779 HsPar _ a ->
780 [ toHie a
781 ]
782 SectionL _ a b ->
783 [ toHie a
784 , toHie b
785 ]
786 SectionR _ a b ->
787 [ toHie a
788 , toHie b
789 ]
790 ExplicitTuple _ args _ ->
791 [ toHie args
792 ]
793 ExplicitSum _ _ _ expr ->
794 [ toHie expr
795 ]
796 HsCase _ expr matches ->
797 [ toHie expr
798 , toHie matches
799 ]
800 HsIf _ _ a b c ->
801 [ toHie a
802 , toHie b
803 , toHie c
804 ]
805 HsMultiIf _ grhss ->
806 [ toHie grhss
807 ]
808 HsLet _ binds expr ->
809 [ toHie $ RS (mkLScope expr) binds
810 , toHie expr
811 ]
812 HsDo _ _ (L ispan stmts) ->
813 [ pure $ locOnly ispan
814 , toHie $ listScopes NoScope stmts
815 ]
816 ExplicitList _ _ exprs ->
817 [ toHie exprs
818 ]
819 RecordCon {rcon_con_name = name, rcon_flds = binds}->
820 [ toHie $ C Use name
821 , toHie $ RC RecFieldAssign $ binds
822 ]
823 RecordUpd {rupd_expr = expr, rupd_flds = upds}->
824 [ toHie expr
825 , toHie $ map (RC RecFieldAssign) upds
826 ]
827 ExprWithTySig _ expr sig ->
828 [ toHie expr
829 , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
830 ]
831 ArithSeq _ _ info ->
832 [ toHie info
833 ]
834 HsSCC _ _ _ expr ->
835 [ toHie expr
836 ]
837 HsCoreAnn _ _ _ expr ->
838 [ toHie expr
839 ]
840 HsProc _ pat cmdtop ->
841 [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
842 , toHie cmdtop
843 ]
844 HsStatic _ expr ->
845 [ toHie expr
846 ]
847 HsTick _ _ expr ->
848 [ toHie expr
849 ]
850 HsBinTick _ _ _ expr ->
851 [ toHie expr
852 ]
853 HsTickPragma _ _ _ _ expr ->
854 [ toHie expr
855 ]
856 HsWrap _ _ a ->
857 [ toHie $ L mspan a
858 ]
859 HsBracket _ b ->
860 [ toHie b
861 ]
862 HsRnBracketOut _ b p ->
863 [ toHie b
864 , toHie p
865 ]
866 HsTcBracketOut _ b p ->
867 [ toHie b
868 , toHie p
869 ]
870 HsSpliceE _ x ->
871 [ toHie $ L mspan x
872 ]
873 EWildPat _ -> []
874 EAsPat _ a b ->
875 [ toHie $ C Use a
876 , toHie b
877 ]
878 EViewPat _ a b ->
879 [ toHie a
880 , toHie b
881 ]
882 ELazyPat _ a ->
883 [ toHie a
884 ]
885 XExpr _ -> []
886
887 instance ( a ~ GhcPass p
888 , ToHie (LHsExpr a)
889 , Data (HsTupArg a)
890 ) => ToHie (LHsTupArg (GhcPass p)) where
891 toHie (L span arg) = concatM $ makeNode arg span : case arg of
892 Present _ expr ->
893 [ toHie expr
894 ]
895 Missing _ -> []
896 XTupArg _ -> []
897
898 instance ( a ~ GhcPass p
899 , ToHie (PScoped (LPat a))
900 , ToHie (LHsExpr a)
901 , ToHie (SigContext (LSig a))
902 , ToHie (RScoped (LHsLocalBinds a))
903 , ToHie (RScoped (ApplicativeArg a))
904 , ToHie (Located body)
905 , Data (StmtLR a a (Located body))
906 , Data (StmtLR a a (Located (HsExpr a)))
907 ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
908 toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
909 LastStmt _ body _ _ ->
910 [ toHie body
911 ]
912 BindStmt _ pat body _ _ ->
913 [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
914 , toHie body
915 ]
916 ApplicativeStmt _ stmts _ ->
917 [ concatMapM (toHie . RS scope . snd) stmts
918 ]
919 BodyStmt _ body _ _ ->
920 [ toHie body
921 ]
922 LetStmt _ binds ->
923 [ toHie $ RS scope binds
924 ]
925 ParStmt _ parstmts _ _ ->
926 [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
927 toHie $ listScopes NoScope stmts)
928 parstmts
929 ]
930 TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
931 [ toHie $ listScopes scope stmts
932 , toHie using
933 , toHie by
934 ]
935 RecStmt {recS_stmts = stmts} ->
936 [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
937 ]
938 XStmtLR _ -> []
939
940 instance ( ToHie (LHsExpr a)
941 , ToHie (PScoped (LPat a))
942 , ToHie (BindContext (LHsBind a))
943 , ToHie (SigContext (LSig a))
944 , ToHie (RScoped (HsValBindsLR a a))
945 , Data (HsLocalBinds a)
946 ) => ToHie (RScoped (LHsLocalBinds a)) where
947 toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
948 EmptyLocalBinds _ -> []
949 HsIPBinds _ _ -> []
950 HsValBinds _ valBinds ->
951 [ toHie $ RS (combineScopes scope $ mkScope sp)
952 valBinds
953 ]
954 XHsLocalBindsLR _ -> []
955
956 instance ( ToHie (BindContext (LHsBind a))
957 , ToHie (SigContext (LSig a))
958 , ToHie (RScoped (XXValBindsLR a a))
959 ) => ToHie (RScoped (HsValBindsLR a a)) where
960 toHie (RS sc v) = concatM $ case v of
961 ValBinds _ binds sigs ->
962 [ toHie $ fmap (BC RegularBind sc) binds
963 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
964 ]
965 XValBindsLR x -> [ toHie $ RS sc x ]
966
967 instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
968 toHie (RS sc (NValBinds binds sigs)) = concatM $
969 [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
970 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
971 ]
972 instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
973 toHie (RS sc (NValBinds binds sigs)) = concatM $
974 [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
975 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
976 ]
977
978 instance ( ToHie (RContext (LHsRecField a arg))
979 ) => ToHie (RContext (HsRecFields a arg)) where
980 toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
981
982 instance ( ToHie (RFContext (Located label))
983 , ToHie arg
984 , HasLoc arg
985 , Data label
986 , Data arg
987 ) => ToHie (RContext (LHsRecField' label arg)) where
988 toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
989 HsRecField label expr _ ->
990 [ toHie $ RFC c (getRealSpan $ loc expr) label
991 , toHie expr
992 ]
993
994 removeDefSrcSpan :: Name -> Name
995 removeDefSrcSpan n = setNameLoc n noSrcSpan
996
997 instance ToHie (RFContext (LFieldOcc GhcRn)) where
998 toHie (RFC c rhs (L nspan f)) = concatM $ case f of
999 FieldOcc name _ ->
1000 [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
1001 ]
1002 XFieldOcc _ -> []
1003
1004 instance ToHie (RFContext (LFieldOcc GhcTc)) where
1005 toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1006 FieldOcc var _ ->
1007 let var' = setVarName var (removeDefSrcSpan $ varName var)
1008 in [ toHie $ C (RecField c rhs) (L nspan var')
1009 ]
1010 XFieldOcc _ -> []
1011
1012 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
1013 toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1014 Unambiguous name _ ->
1015 [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
1016 ]
1017 Ambiguous _name _ ->
1018 [ ]
1019 XAmbiguousFieldOcc _ -> []
1020
1021 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
1022 toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1023 Unambiguous var _ ->
1024 let var' = setVarName var (removeDefSrcSpan $ varName var)
1025 in [ toHie $ C (RecField c rhs) (L nspan var')
1026 ]
1027 Ambiguous var _ ->
1028 let var' = setVarName var (removeDefSrcSpan $ varName var)
1029 in [ toHie $ C (RecField c rhs) (L nspan var')
1030 ]
1031 XAmbiguousFieldOcc _ -> []
1032
1033 instance ( a ~ GhcPass p
1034 , ToHie (PScoped (LPat a))
1035 , ToHie (BindContext (LHsBind a))
1036 , ToHie (LHsExpr a)
1037 , ToHie (SigContext (LSig a))
1038 , ToHie (RScoped (HsValBindsLR a a))
1039 , Data (StmtLR a a (Located (HsExpr a)))
1040 , Data (HsLocalBinds a)
1041 ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
1042 toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
1043 [ toHie $ PS Nothing sc NoScope pat
1044 , toHie expr
1045 ]
1046 toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
1047 [ toHie $ listScopes NoScope stmts
1048 , toHie $ PS Nothing sc NoScope pat
1049 ]
1050 toHie (RS _ (XApplicativeArg _)) = pure []
1051
1052 instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
1053 toHie (PrefixCon args) = toHie args
1054 toHie (RecCon rec) = toHie rec
1055 toHie (InfixCon a b) = concatM [ toHie a, toHie b]
1056
1057 instance ( ToHie (LHsCmd a)
1058 , Data (HsCmdTop a)
1059 ) => ToHie (LHsCmdTop a) where
1060 toHie (L span top) = concatM $ makeNode top span : case top of
1061 HsCmdTop _ cmd ->
1062 [ toHie cmd
1063 ]
1064 XCmdTop _ -> []
1065
1066 instance ( a ~ GhcPass p
1067 , ToHie (PScoped (LPat a))
1068 , ToHie (BindContext (LHsBind a))
1069 , ToHie (LHsExpr a)
1070 , ToHie (MatchGroup a (LHsCmd a))
1071 , ToHie (SigContext (LSig a))
1072 , ToHie (RScoped (HsValBindsLR a a))
1073 , Data (HsCmd a)
1074 , Data (HsCmdTop a)
1075 , Data (StmtLR a a (Located (HsCmd a)))
1076 , Data (HsLocalBinds a)
1077 , Data (StmtLR a a (Located (HsExpr a)))
1078 ) => ToHie (LHsCmd (GhcPass p)) where
1079 toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
1080 HsCmdArrApp _ a b _ _ ->
1081 [ toHie a
1082 , toHie b
1083 ]
1084 HsCmdArrForm _ a _ _ cmdtops ->
1085 [ toHie a
1086 , toHie cmdtops
1087 ]
1088 HsCmdApp _ a b ->
1089 [ toHie a
1090 , toHie b
1091 ]
1092 HsCmdLam _ mg ->
1093 [ toHie mg
1094 ]
1095 HsCmdPar _ a ->
1096 [ toHie a
1097 ]
1098 HsCmdCase _ expr alts ->
1099 [ toHie expr
1100 , toHie alts
1101 ]
1102 HsCmdIf _ _ a b c ->
1103 [ toHie a
1104 , toHie b
1105 , toHie c
1106 ]
1107 HsCmdLet _ binds cmd' ->
1108 [ toHie $ RS (mkLScope cmd') binds
1109 , toHie cmd'
1110 ]
1111 HsCmdDo _ (L ispan stmts) ->
1112 [ pure $ locOnly ispan
1113 , toHie $ listScopes NoScope stmts
1114 ]
1115 HsCmdWrap _ _ _ -> []
1116 XCmd _ -> []
1117
1118 instance ToHie (TyClGroup GhcRn) where
1119 toHie (TyClGroup _ classes roles instances) = concatM
1120 [ toHie classes
1121 , toHie roles
1122 , toHie instances
1123 ]
1124 toHie (XTyClGroup _) = pure []
1125
1126 instance ToHie (LTyClDecl GhcRn) where
1127 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1128 FamDecl {tcdFam = fdecl} ->
1129 [ toHie (L span fdecl)
1130 ]
1131 SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1132 [ toHie $ C (Decl SynDec $ getRealSpan span) name
1133 , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
1134 , toHie typ
1135 ]
1136 DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1137 [ toHie $ C (Decl DataDec $ getRealSpan span) name
1138 , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1139 , toHie defn
1140 ]
1141 where
1142 quant_scope = mkLScope $ dd_ctxt defn
1143 rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1144 sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
1145 con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
1146 deriv_sc = mkLScope $ dd_derivs defn
1147 ClassDecl { tcdCtxt = context
1148 , tcdLName = name
1149 , tcdTyVars = vars
1150 , tcdFDs = deps
1151 , tcdSigs = sigs
1152 , tcdMeths = meths
1153 , tcdATs = typs
1154 , tcdATDefs = deftyps
1155 } ->
1156 [ toHie $ C (Decl ClassDec $ getRealSpan span) name
1157 , toHie context
1158 , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1159 , toHie deps
1160 , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
1161 , toHie $ fmap (BC InstanceBind ModuleScope) meths
1162 , toHie typs
1163 , concatMapM (pure . locOnly . getLoc) deftyps
1164 , toHie $ map (go . unLoc) deftyps
1165 ]
1166 where
1167 context_scope = mkLScope context
1168 rhs_scope = foldl1' combineScopes $ map mkScope
1169 [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1170
1171 go :: TyFamDefltEqn GhcRn
1172 -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
1173 go (FamEqn a var bndrs pat b rhs) =
1174 FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
1175 go (XFamEqn NoExt) = XFamEqn NoExt
1176 XTyClDecl _ -> []
1177
1178 instance ToHie (LFamilyDecl GhcRn) where
1179 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1180 FamilyDecl _ info name vars _ sig inj ->
1181 [ toHie $ C (Decl FamDec $ getRealSpan span) name
1182 , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1183 , toHie info
1184 , toHie $ RS injSpan sig
1185 , toHie inj
1186 ]
1187 where
1188 rhsSpan = sigSpan `combineScopes` injSpan
1189 sigSpan = mkScope $ getLoc sig
1190 injSpan = maybe NoScope (mkScope . getLoc) inj
1191 XFamilyDecl _ -> []
1192
1193 instance ToHie (FamilyInfo GhcRn) where
1194 toHie (ClosedTypeFamily (Just eqns)) = concatM $
1195 [ concatMapM (pure . locOnly . getLoc) eqns
1196 , toHie $ map go eqns
1197 ]
1198 where
1199 go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
1200 toHie _ = pure []
1201
1202 instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
1203 toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
1204 NoSig _ ->
1205 []
1206 KindSig _ k ->
1207 [ toHie k
1208 ]
1209 TyVarSig _ bndr ->
1210 [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1211 ]
1212 XFamilyResultSig _ -> []
1213
1214 instance ToHie (Located (FunDep (Located Name))) where
1215 toHie (L span fd@(lhs, rhs)) = concatM $
1216 [ makeNode fd span
1217 , toHie $ map (C Use) lhs
1218 , toHie $ map (C Use) rhs
1219 ]
1220
1221 instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
1222 => ToHie (TScoped (FamEqn GhcRn pats rhs)) where
1223 toHie (TS _ f) = toHie f
1224
1225 instance ( ToHie pats
1226 , ToHie rhs
1227 , HasLoc pats
1228 , HasLoc rhs
1229 ) => ToHie (FamEqn GhcRn pats rhs) where
1230 toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
1231 [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1232 , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1233 , toHie pats
1234 , toHie rhs
1235 ]
1236 where scope = combineScopes patsScope rhsScope
1237 patsScope = mkScope (loc pats)
1238 rhsScope = mkScope (loc rhs)
1239 toHie (XFamEqn _) = pure []
1240
1241 instance ToHie (LInjectivityAnn GhcRn) where
1242 toHie (L span ann) = concatM $ makeNode ann span : case ann of
1243 InjectivityAnn lhs rhs ->
1244 [ toHie $ C Use lhs
1245 , toHie $ map (C Use) rhs
1246 ]
1247
1248 instance ToHie (HsDataDefn GhcRn) where
1249 toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1250 [ toHie ctx
1251 , toHie mkind
1252 , toHie cons
1253 , toHie derivs
1254 ]
1255 toHie (XHsDataDefn _) = pure []
1256
1257 instance ToHie (HsDeriving GhcRn) where
1258 toHie (L span clauses) = concatM
1259 [ pure $ locOnly span
1260 , toHie clauses
1261 ]
1262
1263 instance ToHie (LHsDerivingClause GhcRn) where
1264 toHie (L span cl) = concatM $ makeNode cl span : case cl of
1265 HsDerivingClause _ strat (L ispan tys) ->
1266 [ toHie strat
1267 , pure $ locOnly ispan
1268 , toHie $ map (TS (ResolvedScopes [])) tys
1269 ]
1270 XHsDerivingClause _ -> []
1271
1272 instance ToHie (Located (DerivStrategy GhcRn)) where
1273 toHie (L span strat) = concatM $ makeNode strat span : case strat of
1274 StockStrategy -> []
1275 AnyclassStrategy -> []
1276 NewtypeStrategy -> []
1277 ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
1278
1279 instance ToHie (Located OverlapMode) where
1280 toHie (L span _) = pure $ locOnly span
1281
1282 instance ToHie (LConDecl GhcRn) where
1283 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1284 ConDeclGADT { con_names = names, con_qvars = qvars
1285 , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
1286 [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
1287 , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
1288 , toHie ctx
1289 , toHie args
1290 , toHie typ
1291 ]
1292 where
1293 rhsScope = combineScopes argsScope tyScope
1294 ctxScope = maybe NoScope mkLScope ctx
1295 argsScope = condecl_scope args
1296 tyScope = mkLScope typ
1297 ConDeclH98 { con_name = name, con_ex_tvs = qvars
1298 , con_mb_cxt = ctx, con_args = dets } ->
1299 [ toHie $ C (Decl ConDec $ getRealSpan span) name
1300 , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1301 , toHie ctx
1302 , toHie dets
1303 ]
1304 where
1305 rhsScope = combineScopes ctxScope argsScope
1306 ctxScope = maybe NoScope mkLScope ctx
1307 argsScope = condecl_scope dets
1308 XConDecl _ -> []
1309 where condecl_scope args = case args of
1310 PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
1311 InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
1312 RecCon x -> mkLScope x
1313
1314 instance ToHie (Located [LConDeclField GhcRn]) where
1315 toHie (L span decls) = concatM $
1316 [ pure $ locOnly span
1317 , toHie decls
1318 ]
1319
1320 instance ( HasLoc thing
1321 , ToHie (TScoped thing)
1322 ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
1323 toHie (TS sc (HsIB ibrn a)) = concatM $
1324 [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
1325 , toHie $ TS sc a
1326 ]
1327 where span = loc a
1328 toHie (TS _ (XHsImplicitBndrs _)) = pure []
1329
1330 instance ( HasLoc thing
1331 , ToHie (TScoped thing)
1332 ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
1333 toHie (TS sc (HsWC names a)) = concatM $
1334 [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1335 , toHie $ TS sc a
1336 ]
1337 where span = loc a
1338 toHie (TS _ (XHsWildCardBndrs _)) = pure []
1339
1340 instance ToHie (SigContext (LSig GhcRn)) where
1341 toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
1342 TypeSig _ names typ ->
1343 [ toHie $ map (C TyDecl) names
1344 , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1345 ]
1346 PatSynSig _ names typ ->
1347 [ toHie $ map (C TyDecl) names
1348 , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1349 ]
1350 ClassOpSig _ _ names typ ->
1351 [ case styp of
1352 ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
1353 _ -> toHie $ map (C $ TyDecl) names
1354 , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1355 ]
1356 IdSig _ _ -> []
1357 FixSig _ fsig ->
1358 [ toHie $ L sp fsig
1359 ]
1360 InlineSig _ name _ ->
1361 [ toHie $ (C Use) name
1362 ]
1363 SpecSig _ name typs _ ->
1364 [ toHie $ (C Use) name
1365 , toHie $ map (TS (ResolvedScopes [])) typs
1366 ]
1367 SpecInstSig _ _ typ ->
1368 [ toHie $ TS (ResolvedScopes []) typ
1369 ]
1370 MinimalSig _ _ form ->
1371 [ toHie form
1372 ]
1373 SCCFunSig _ _ name mtxt ->
1374 [ toHie $ (C Use) name
1375 , pure $ maybe [] (locOnly . getLoc) mtxt
1376 ]
1377 CompleteMatchSig _ _ (L ispan names) typ ->
1378 [ pure $ locOnly ispan
1379 , toHie $ map (C Use) names
1380 , toHie $ fmap (C Use) typ
1381 ]
1382 XSig _ -> []
1383
1384 instance ToHie (LHsType GhcRn) where
1385 toHie x = toHie $ TS (ResolvedScopes []) x
1386
1387 instance ToHie (TScoped (LHsType GhcRn)) where
1388 toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
1389 HsForAllTy _ _ bndrs body ->
1390 [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
1391 , toHie body
1392 ]
1393 HsQualTy _ ctx body ->
1394 [ toHie ctx
1395 , toHie body
1396 ]
1397 HsTyVar _ _ var ->
1398 [ toHie $ C Use var
1399 ]
1400 HsAppTy _ a b ->
1401 [ toHie a
1402 , toHie b
1403 ]
1404 HsAppKindTy _ ty ki ->
1405 [ toHie ty
1406 , toHie $ TS (ResolvedScopes []) ki
1407 ]
1408 HsFunTy _ a b ->
1409 [ toHie a
1410 , toHie b
1411 ]
1412 HsListTy _ a ->
1413 [ toHie a
1414 ]
1415 HsTupleTy _ _ tys ->
1416 [ toHie tys
1417 ]
1418 HsSumTy _ tys ->
1419 [ toHie tys
1420 ]
1421 HsOpTy _ a op b ->
1422 [ toHie a
1423 , toHie $ C Use op
1424 , toHie b
1425 ]
1426 HsParTy _ a ->
1427 [ toHie a
1428 ]
1429 HsIParamTy _ ip ty ->
1430 [ toHie ip
1431 , toHie ty
1432 ]
1433 HsKindSig _ a b ->
1434 [ toHie a
1435 , toHie b
1436 ]
1437 HsSpliceTy _ a ->
1438 [ toHie $ L span a
1439 ]
1440 HsDocTy _ a _ ->
1441 [ toHie a
1442 ]
1443 HsBangTy _ _ ty ->
1444 [ toHie ty
1445 ]
1446 HsRecTy _ fields ->
1447 [ toHie fields
1448 ]
1449 HsExplicitListTy _ _ tys ->
1450 [ toHie tys
1451 ]
1452 HsExplicitTupleTy _ tys ->
1453 [ toHie tys
1454 ]
1455 HsTyLit _ _ -> []
1456 HsWildCardTy _ -> []
1457 HsStarTy _ _ -> []
1458 XHsType _ -> []
1459
1460 instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1461 toHie (HsValArg tm) = toHie tm
1462 toHie (HsTypeArg _ ty) = toHie ty
1463 toHie (HsArgPar sp) = pure $ locOnly sp
1464
1465 instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
1466 toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1467 UserTyVar _ var ->
1468 [ toHie $ C (TyVarBind sc tsc) var
1469 ]
1470 KindedTyVar _ var kind ->
1471 [ toHie $ C (TyVarBind sc tsc) var
1472 , toHie kind
1473 ]
1474 XTyVarBndr _ -> []
1475
1476 instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1477 toHie (TS sc (HsQTvs implicits vars)) = concatM $
1478 [ pure $ bindingsOnly bindings
1479 , toHie $ tvScopes sc NoScope vars
1480 ]
1481 where
1482 varLoc = loc vars
1483 bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1484 toHie (TS _ (XLHsQTyVars _)) = pure []
1485
1486 instance ToHie (LHsContext GhcRn) where
1487 toHie (L span tys) = concatM $
1488 [ pure $ locOnly span
1489 , toHie tys
1490 ]
1491
1492 instance ToHie (LConDeclField GhcRn) where
1493 toHie (L span field) = concatM $ makeNode field span : case field of
1494 ConDeclField _ fields typ _ ->
1495 [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1496 , toHie typ
1497 ]
1498 XConDeclField _ -> []
1499
1500 instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1501 toHie (From expr) = toHie expr
1502 toHie (FromThen a b) = concatM $
1503 [ toHie a
1504 , toHie b
1505 ]
1506 toHie (FromTo a b) = concatM $
1507 [ toHie a
1508 , toHie b
1509 ]
1510 toHie (FromThenTo a b c) = concatM $
1511 [ toHie a
1512 , toHie b
1513 , toHie c
1514 ]
1515
1516 instance ToHie (LSpliceDecl GhcRn) where
1517 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1518 SpliceDecl _ splice _ ->
1519 [ toHie splice
1520 ]
1521 XSpliceDecl _ -> []
1522
1523 instance ToHie (HsBracket a) where
1524 toHie _ = pure []
1525
1526 instance ToHie PendingRnSplice where
1527 toHie _ = pure []
1528
1529 instance ToHie PendingTcSplice where
1530 toHie _ = pure []
1531
1532 instance ToHie (LBooleanFormula (Located Name)) where
1533 toHie (L span form) = concatM $ makeNode form span : case form of
1534 Var a ->
1535 [ toHie $ C Use a
1536 ]
1537 And forms ->
1538 [ toHie forms
1539 ]
1540 Or forms ->
1541 [ toHie forms
1542 ]
1543 Parens f ->
1544 [ toHie f
1545 ]
1546
1547 instance ToHie (Located HsIPName) where
1548 toHie (L span e) = makeNode e span
1549
1550 instance ( ToHie (LHsExpr a)
1551 , Data (HsSplice a)
1552 ) => ToHie (Located (HsSplice a)) where
1553 toHie (L span sp) = concatM $ makeNode sp span : case sp of
1554 HsTypedSplice _ _ _ expr ->
1555 [ toHie expr
1556 ]
1557 HsUntypedSplice _ _ _ expr ->
1558 [ toHie expr
1559 ]
1560 HsQuasiQuote _ _ _ ispan _ ->
1561 [ pure $ locOnly ispan
1562 ]
1563 HsSpliced _ _ _ ->
1564 []
1565 HsSplicedT _ ->
1566 []
1567 XSplice _ -> []
1568
1569 instance ToHie (LRoleAnnotDecl GhcRn) where
1570 toHie (L span annot) = concatM $ makeNode annot span : case annot of
1571 RoleAnnotDecl _ var roles ->
1572 [ toHie $ C Use var
1573 , concatMapM (pure . locOnly . getLoc) roles
1574 ]
1575 XRoleAnnotDecl _ -> []
1576
1577 instance ToHie (LInstDecl GhcRn) where
1578 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1579 ClsInstD _ d ->
1580 [ toHie $ L span d
1581 ]
1582 DataFamInstD _ d ->
1583 [ toHie $ L span d
1584 ]
1585 TyFamInstD _ d ->
1586 [ toHie $ L span d
1587 ]
1588 XInstDecl _ -> []
1589
1590 instance ToHie (LClsInstDecl GhcRn) where
1591 toHie (L span decl) = concatM
1592 [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
1593 , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1594 , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
1595 , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
1596 , toHie $ cid_tyfam_insts decl
1597 , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
1598 , toHie $ cid_datafam_insts decl
1599 , toHie $ cid_overlap_mode decl
1600 ]
1601
1602 instance ToHie (LDataFamInstDecl GhcRn) where
1603 toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1604
1605 instance ToHie (LTyFamInstDecl GhcRn) where
1606 toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1607
1608 instance ToHie (Context a)
1609 => ToHie (PatSynFieldContext (RecordPatSynField a)) where
1610 toHie (PSC sp (RecordPatSynField a b)) = concatM $
1611 [ toHie $ C (RecField RecFieldDecl sp) a
1612 , toHie $ C Use b
1613 ]
1614
1615 instance ToHie (LDerivDecl GhcRn) where
1616 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1617 DerivDecl _ typ strat overlap ->
1618 [ toHie $ TS (ResolvedScopes []) typ
1619 , toHie strat
1620 , toHie overlap
1621 ]
1622 XDerivDecl _ -> []
1623
1624 instance ToHie (LFixitySig GhcRn) where
1625 toHie (L span sig) = concatM $ makeNode sig span : case sig of
1626 FixitySig _ vars _ ->
1627 [ toHie $ map (C Use) vars
1628 ]
1629 XFixitySig _ -> []
1630
1631 instance ToHie (LDefaultDecl GhcRn) where
1632 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1633 DefaultDecl _ typs ->
1634 [ toHie typs
1635 ]
1636 XDefaultDecl _ -> []
1637
1638 instance ToHie (LForeignDecl GhcRn) where
1639 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1640 ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1641 [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
1642 , toHie $ TS (ResolvedScopes []) sig
1643 , toHie fi
1644 ]
1645 ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1646 [ toHie $ C Use name
1647 , toHie $ TS (ResolvedScopes []) sig
1648 , toHie fe
1649 ]
1650 XForeignDecl _ -> []
1651
1652 instance ToHie ForeignImport where
1653 toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
1654 [ locOnly a
1655 , locOnly b
1656 , locOnly c
1657 ]
1658
1659 instance ToHie ForeignExport where
1660 toHie (CExport (L a _) (L b _)) = pure $ concat $
1661 [ locOnly a
1662 , locOnly b
1663 ]
1664
1665 instance ToHie (LWarnDecls GhcRn) where
1666 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1667 Warnings _ _ warnings ->
1668 [ toHie warnings
1669 ]
1670 XWarnDecls _ -> []
1671
1672 instance ToHie (LWarnDecl GhcRn) where
1673 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1674 Warning _ vars _ ->
1675 [ toHie $ map (C Use) vars
1676 ]
1677 XWarnDecl _ -> []
1678
1679 instance ToHie (LAnnDecl GhcRn) where
1680 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1681 HsAnnotation _ _ prov expr ->
1682 [ toHie prov
1683 , toHie expr
1684 ]
1685 XAnnDecl _ -> []
1686
1687 instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
1688 toHie (ValueAnnProvenance a) = toHie $ C Use a
1689 toHie (TypeAnnProvenance a) = toHie $ C Use a
1690 toHie ModuleAnnProvenance = pure []
1691
1692 instance ToHie (LRuleDecls GhcRn) where
1693 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1694 HsRules _ _ rules ->
1695 [ toHie rules
1696 ]
1697 XRuleDecls _ -> []
1698
1699 instance ToHie (LRuleDecl GhcRn) where
1700 toHie (L _ (XRuleDecl _)) = pure []
1701 toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
1702 [ makeNode r span
1703 , pure $ locOnly $ getLoc rname
1704 , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1705 , toHie $ map (RS $ mkScope span) bndrs
1706 , toHie exprA
1707 , toHie exprB
1708 ]
1709 where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
1710 bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
1711 exprA_sc = mkLScope exprA
1712 exprB_sc = mkLScope exprB
1713
1714 instance ToHie (RScoped (LRuleBndr GhcRn)) where
1715 toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1716 RuleBndr _ var ->
1717 [ toHie $ C (ValBind RegularBind sc Nothing) var
1718 ]
1719 RuleBndrSig _ var typ ->
1720 [ toHie $ C (ValBind RegularBind sc Nothing) var
1721 , toHie $ TS (ResolvedScopes [sc]) typ
1722 ]
1723 XRuleBndr _ -> []
1724
1725 instance ToHie (LImportDecl GhcRn) where
1726 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1727 ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
1728 [ toHie $ IEC Import name
1729 , toHie $ fmap (IEC ImportAs) as
1730 , maybe (pure []) goIE hidden
1731 ]
1732 XImportDecl _ -> []
1733 where
1734 goIE (hiding, (L sp liens)) = concatM $
1735 [ pure $ locOnly sp
1736 , toHie $ map (IEC c) liens
1737 ]
1738 where
1739 c = if hiding then ImportHiding else Import
1740
1741 instance ToHie (IEContext (LIE GhcRn)) where
1742 toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
1743 IEVar _ n ->
1744 [ toHie $ IEC c n
1745 ]
1746 IEThingAbs _ n ->
1747 [ toHie $ IEC c n
1748 ]
1749 IEThingAll _ n ->
1750 [ toHie $ IEC c n
1751 ]
1752 IEThingWith _ n _ ns flds ->
1753 [ toHie $ IEC c n
1754 , toHie $ map (IEC c) ns
1755 , toHie $ map (IEC c) flds
1756 ]
1757 IEModuleContents _ n ->
1758 [ toHie $ IEC c n
1759 ]
1760 IEGroup _ _ _ -> []
1761 IEDoc _ _ -> []
1762 IEDocNamed _ _ -> []
1763 XIE _ -> []
1764
1765 instance ToHie (IEContext (LIEWrappedName Name)) where
1766 toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
1767 IEName n ->
1768 [ toHie $ C (IEThing c) n
1769 ]
1770 IEPattern p ->
1771 [ toHie $ C (IEThing c) p
1772 ]
1773 IEType n ->
1774 [ toHie $ C (IEThing c) n
1775 ]
1776
1777 instance ToHie (IEContext (Located (FieldLbl Name))) where
1778 toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
1779 FieldLabel _ _ n ->
1780 [ toHie $ C (IEThing c) $ L span n
1781 ]