HIE: Save module name and module exports
[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 ( mkFunTys, 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) = mkFunTys 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 HsArrApp _ a b _ _ ->
848 [ toHie a
849 , toHie b
850 ]
851 HsArrForm _ expr _ cmds ->
852 [ toHie expr
853 , toHie cmds
854 ]
855 HsTick _ _ expr ->
856 [ toHie expr
857 ]
858 HsBinTick _ _ _ expr ->
859 [ toHie expr
860 ]
861 HsTickPragma _ _ _ _ expr ->
862 [ toHie expr
863 ]
864 HsWrap _ _ a ->
865 [ toHie $ L mspan a
866 ]
867 HsBracket _ b ->
868 [ toHie b
869 ]
870 HsRnBracketOut _ b p ->
871 [ toHie b
872 , toHie p
873 ]
874 HsTcBracketOut _ b p ->
875 [ toHie b
876 , toHie p
877 ]
878 HsSpliceE _ x ->
879 [ toHie $ L mspan x
880 ]
881 EWildPat _ -> []
882 EAsPat _ a b ->
883 [ toHie $ C Use a
884 , toHie b
885 ]
886 EViewPat _ a b ->
887 [ toHie a
888 , toHie b
889 ]
890 ELazyPat _ a ->
891 [ toHie a
892 ]
893 XExpr _ -> []
894
895 instance ( a ~ GhcPass p
896 , ToHie (LHsExpr a)
897 , Data (HsTupArg a)
898 ) => ToHie (LHsTupArg (GhcPass p)) where
899 toHie (L span arg) = concatM $ makeNode arg span : case arg of
900 Present _ expr ->
901 [ toHie expr
902 ]
903 Missing _ -> []
904 XTupArg _ -> []
905
906 instance ( a ~ GhcPass p
907 , ToHie (PScoped (LPat a))
908 , ToHie (LHsExpr a)
909 , ToHie (SigContext (LSig a))
910 , ToHie (RScoped (LHsLocalBinds a))
911 , ToHie (RScoped (ApplicativeArg a))
912 , ToHie (Located body)
913 , Data (StmtLR a a (Located body))
914 , Data (StmtLR a a (Located (HsExpr a)))
915 ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
916 toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
917 LastStmt _ body _ _ ->
918 [ toHie body
919 ]
920 BindStmt _ pat body _ _ ->
921 [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
922 , toHie body
923 ]
924 ApplicativeStmt _ stmts _ ->
925 [ concatMapM (toHie . RS scope . snd) stmts
926 ]
927 BodyStmt _ body _ _ ->
928 [ toHie body
929 ]
930 LetStmt _ binds ->
931 [ toHie $ RS scope binds
932 ]
933 ParStmt _ parstmts _ _ ->
934 [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
935 toHie $ listScopes NoScope stmts)
936 parstmts
937 ]
938 TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
939 [ toHie $ listScopes scope stmts
940 , toHie using
941 , toHie by
942 ]
943 RecStmt {recS_stmts = stmts} ->
944 [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
945 ]
946 XStmtLR _ -> []
947
948 instance ( ToHie (LHsExpr a)
949 , ToHie (PScoped (LPat a))
950 , ToHie (BindContext (LHsBind a))
951 , ToHie (SigContext (LSig a))
952 , ToHie (RScoped (HsValBindsLR a a))
953 , Data (HsLocalBinds a)
954 ) => ToHie (RScoped (LHsLocalBinds a)) where
955 toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
956 EmptyLocalBinds _ -> []
957 HsIPBinds _ _ -> []
958 HsValBinds _ valBinds ->
959 [ toHie $ RS (combineScopes scope $ mkScope sp)
960 valBinds
961 ]
962 XHsLocalBindsLR _ -> []
963
964 instance ( ToHie (BindContext (LHsBind a))
965 , ToHie (SigContext (LSig a))
966 , ToHie (RScoped (XXValBindsLR a a))
967 ) => ToHie (RScoped (HsValBindsLR a a)) where
968 toHie (RS sc v) = concatM $ case v of
969 ValBinds _ binds sigs ->
970 [ toHie $ fmap (BC RegularBind sc) binds
971 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
972 ]
973 XValBindsLR x -> [ toHie $ RS sc x ]
974
975 instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
976 toHie (RS sc (NValBinds binds sigs)) = concatM $
977 [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
978 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
979 ]
980 instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
981 toHie (RS sc (NValBinds binds sigs)) = concatM $
982 [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
983 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
984 ]
985
986 instance ( ToHie (RContext (LHsRecField a arg))
987 ) => ToHie (RContext (HsRecFields a arg)) where
988 toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
989
990 instance ( ToHie (RFContext (Located label))
991 , ToHie arg
992 , HasLoc arg
993 , Data label
994 , Data arg
995 ) => ToHie (RContext (LHsRecField' label arg)) where
996 toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
997 HsRecField label expr _ ->
998 [ toHie $ RFC c (getRealSpan $ loc expr) label
999 , toHie expr
1000 ]
1001
1002 removeDefSrcSpan :: Name -> Name
1003 removeDefSrcSpan n = setNameLoc n noSrcSpan
1004
1005 instance ToHie (RFContext (LFieldOcc GhcRn)) where
1006 toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1007 FieldOcc name _ ->
1008 [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
1009 ]
1010 XFieldOcc _ -> []
1011
1012 instance ToHie (RFContext (LFieldOcc GhcTc)) where
1013 toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1014 FieldOcc var _ ->
1015 let var' = setVarName var (removeDefSrcSpan $ varName var)
1016 in [ toHie $ C (RecField c rhs) (L nspan var')
1017 ]
1018 XFieldOcc _ -> []
1019
1020 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
1021 toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1022 Unambiguous name _ ->
1023 [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
1024 ]
1025 Ambiguous _name _ ->
1026 [ ]
1027 XAmbiguousFieldOcc _ -> []
1028
1029 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
1030 toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1031 Unambiguous var _ ->
1032 let var' = setVarName var (removeDefSrcSpan $ varName var)
1033 in [ toHie $ C (RecField c rhs) (L nspan var')
1034 ]
1035 Ambiguous var _ ->
1036 let var' = setVarName var (removeDefSrcSpan $ varName var)
1037 in [ toHie $ C (RecField c rhs) (L nspan var')
1038 ]
1039 XAmbiguousFieldOcc _ -> []
1040
1041 instance ( a ~ GhcPass p
1042 , ToHie (PScoped (LPat a))
1043 , ToHie (BindContext (LHsBind a))
1044 , ToHie (LHsExpr a)
1045 , ToHie (SigContext (LSig a))
1046 , ToHie (RScoped (HsValBindsLR a a))
1047 , Data (StmtLR a a (Located (HsExpr a)))
1048 , Data (HsLocalBinds a)
1049 ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
1050 toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
1051 [ toHie $ PS Nothing sc NoScope pat
1052 , toHie expr
1053 ]
1054 toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
1055 [ toHie $ listScopes NoScope stmts
1056 , toHie $ PS Nothing sc NoScope pat
1057 ]
1058 toHie (RS _ (XApplicativeArg _)) = pure []
1059
1060 instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
1061 toHie (PrefixCon args) = toHie args
1062 toHie (RecCon rec) = toHie rec
1063 toHie (InfixCon a b) = concatM [ toHie a, toHie b]
1064
1065 instance ( ToHie (LHsCmd a)
1066 , Data (HsCmdTop a)
1067 ) => ToHie (LHsCmdTop a) where
1068 toHie (L span top) = concatM $ makeNode top span : case top of
1069 HsCmdTop _ cmd ->
1070 [ toHie cmd
1071 ]
1072 XCmdTop _ -> []
1073
1074 instance ( a ~ GhcPass p
1075 , ToHie (PScoped (LPat a))
1076 , ToHie (BindContext (LHsBind a))
1077 , ToHie (LHsExpr a)
1078 , ToHie (MatchGroup a (LHsCmd a))
1079 , ToHie (SigContext (LSig a))
1080 , ToHie (RScoped (HsValBindsLR a a))
1081 , Data (HsCmd a)
1082 , Data (HsCmdTop a)
1083 , Data (StmtLR a a (Located (HsCmd a)))
1084 , Data (HsLocalBinds a)
1085 , Data (StmtLR a a (Located (HsExpr a)))
1086 ) => ToHie (LHsCmd (GhcPass p)) where
1087 toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
1088 HsCmdArrApp _ a b _ _ ->
1089 [ toHie a
1090 , toHie b
1091 ]
1092 HsCmdArrForm _ a _ _ cmdtops ->
1093 [ toHie a
1094 , toHie cmdtops
1095 ]
1096 HsCmdApp _ a b ->
1097 [ toHie a
1098 , toHie b
1099 ]
1100 HsCmdLam _ mg ->
1101 [ toHie mg
1102 ]
1103 HsCmdPar _ a ->
1104 [ toHie a
1105 ]
1106 HsCmdCase _ expr alts ->
1107 [ toHie expr
1108 , toHie alts
1109 ]
1110 HsCmdIf _ _ a b c ->
1111 [ toHie a
1112 , toHie b
1113 , toHie c
1114 ]
1115 HsCmdLet _ binds cmd' ->
1116 [ toHie $ RS (mkLScope cmd') binds
1117 , toHie cmd'
1118 ]
1119 HsCmdDo _ (L ispan stmts) ->
1120 [ pure $ locOnly ispan
1121 , toHie $ listScopes NoScope stmts
1122 ]
1123 HsCmdWrap _ _ _ -> []
1124 XCmd _ -> []
1125
1126 instance ToHie (TyClGroup GhcRn) where
1127 toHie (TyClGroup _ classes roles instances) = concatM
1128 [ toHie classes
1129 , toHie roles
1130 , toHie instances
1131 ]
1132 toHie (XTyClGroup _) = pure []
1133
1134 instance ToHie (LTyClDecl GhcRn) where
1135 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1136 FamDecl {tcdFam = fdecl} ->
1137 [ toHie (L span fdecl)
1138 ]
1139 SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1140 [ toHie $ C (Decl SynDec $ getRealSpan span) name
1141 , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
1142 , toHie typ
1143 ]
1144 DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1145 [ toHie $ C (Decl DataDec $ getRealSpan span) name
1146 , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1147 , toHie defn
1148 ]
1149 where
1150 quant_scope = mkLScope $ dd_ctxt defn
1151 rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1152 sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
1153 con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
1154 deriv_sc = mkLScope $ dd_derivs defn
1155 ClassDecl { tcdCtxt = context
1156 , tcdLName = name
1157 , tcdTyVars = vars
1158 , tcdFDs = deps
1159 , tcdSigs = sigs
1160 , tcdMeths = meths
1161 , tcdATs = typs
1162 , tcdATDefs = deftyps
1163 } ->
1164 [ toHie $ C (Decl ClassDec $ getRealSpan span) name
1165 , toHie context
1166 , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1167 , toHie deps
1168 , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
1169 , toHie $ fmap (BC InstanceBind ModuleScope) meths
1170 , toHie typs
1171 , concatMapM (pure . locOnly . getLoc) deftyps
1172 , toHie $ map (go . unLoc) deftyps
1173 ]
1174 where
1175 context_scope = mkLScope context
1176 rhs_scope = foldl1' combineScopes $ map mkScope
1177 [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1178
1179 go :: TyFamDefltEqn GhcRn
1180 -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
1181 go (FamEqn a var bndrs pat b rhs) =
1182 FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
1183 go (XFamEqn NoExt) = XFamEqn NoExt
1184 XTyClDecl _ -> []
1185
1186 instance ToHie (LFamilyDecl GhcRn) where
1187 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1188 FamilyDecl _ info name vars _ sig inj ->
1189 [ toHie $ C (Decl FamDec $ getRealSpan span) name
1190 , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1191 , toHie info
1192 , toHie $ RS injSpan sig
1193 , toHie inj
1194 ]
1195 where
1196 rhsSpan = sigSpan `combineScopes` injSpan
1197 sigSpan = mkScope $ getLoc sig
1198 injSpan = maybe NoScope (mkScope . getLoc) inj
1199 XFamilyDecl _ -> []
1200
1201 instance ToHie (FamilyInfo GhcRn) where
1202 toHie (ClosedTypeFamily (Just eqns)) = concatM $
1203 [ concatMapM (pure . locOnly . getLoc) eqns
1204 , toHie $ map go eqns
1205 ]
1206 where
1207 go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
1208 toHie _ = pure []
1209
1210 instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
1211 toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
1212 NoSig _ ->
1213 []
1214 KindSig _ k ->
1215 [ toHie k
1216 ]
1217 TyVarSig _ bndr ->
1218 [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1219 ]
1220 XFamilyResultSig _ -> []
1221
1222 instance ToHie (Located (FunDep (Located Name))) where
1223 toHie (L span fd@(lhs, rhs)) = concatM $
1224 [ makeNode fd span
1225 , toHie $ map (C Use) lhs
1226 , toHie $ map (C Use) rhs
1227 ]
1228
1229 instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
1230 => ToHie (TScoped (FamEqn GhcRn pats rhs)) where
1231 toHie (TS _ f) = toHie f
1232
1233 instance ( ToHie pats
1234 , ToHie rhs
1235 , HasLoc pats
1236 , HasLoc rhs
1237 ) => ToHie (FamEqn GhcRn pats rhs) where
1238 toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
1239 [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1240 , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1241 , toHie pats
1242 , toHie rhs
1243 ]
1244 where scope = combineScopes patsScope rhsScope
1245 patsScope = mkScope (loc pats)
1246 rhsScope = mkScope (loc rhs)
1247 toHie (XFamEqn _) = pure []
1248
1249 instance ToHie (LInjectivityAnn GhcRn) where
1250 toHie (L span ann) = concatM $ makeNode ann span : case ann of
1251 InjectivityAnn lhs rhs ->
1252 [ toHie $ C Use lhs
1253 , toHie $ map (C Use) rhs
1254 ]
1255
1256 instance ToHie (HsDataDefn GhcRn) where
1257 toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1258 [ toHie ctx
1259 , toHie mkind
1260 , toHie cons
1261 , toHie derivs
1262 ]
1263 toHie (XHsDataDefn _) = pure []
1264
1265 instance ToHie (HsDeriving GhcRn) where
1266 toHie (L span clauses) = concatM
1267 [ pure $ locOnly span
1268 , toHie clauses
1269 ]
1270
1271 instance ToHie (LHsDerivingClause GhcRn) where
1272 toHie (L span cl) = concatM $ makeNode cl span : case cl of
1273 HsDerivingClause _ strat (L ispan tys) ->
1274 [ toHie strat
1275 , pure $ locOnly ispan
1276 , toHie $ map (TS (ResolvedScopes [])) tys
1277 ]
1278 XHsDerivingClause _ -> []
1279
1280 instance ToHie (Located (DerivStrategy GhcRn)) where
1281 toHie (L span strat) = concatM $ makeNode strat span : case strat of
1282 StockStrategy -> []
1283 AnyclassStrategy -> []
1284 NewtypeStrategy -> []
1285 ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
1286
1287 instance ToHie (Located OverlapMode) where
1288 toHie (L span _) = pure $ locOnly span
1289
1290 instance ToHie (LConDecl GhcRn) where
1291 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1292 ConDeclGADT { con_names = names, con_qvars = qvars
1293 , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
1294 [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
1295 , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
1296 , toHie ctx
1297 , toHie args
1298 , toHie typ
1299 ]
1300 where
1301 rhsScope = combineScopes argsScope tyScope
1302 ctxScope = maybe NoScope mkLScope ctx
1303 argsScope = condecl_scope args
1304 tyScope = mkLScope typ
1305 ConDeclH98 { con_name = name, con_ex_tvs = qvars
1306 , con_mb_cxt = ctx, con_args = dets } ->
1307 [ toHie $ C (Decl ConDec $ getRealSpan span) name
1308 , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1309 , toHie ctx
1310 , toHie dets
1311 ]
1312 where
1313 rhsScope = combineScopes ctxScope argsScope
1314 ctxScope = maybe NoScope mkLScope ctx
1315 argsScope = condecl_scope dets
1316 XConDecl _ -> []
1317 where condecl_scope args = case args of
1318 PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
1319 InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
1320 RecCon x -> mkLScope x
1321
1322 instance ToHie (Located [LConDeclField GhcRn]) where
1323 toHie (L span decls) = concatM $
1324 [ pure $ locOnly span
1325 , toHie decls
1326 ]
1327
1328 instance ( HasLoc thing
1329 , ToHie (TScoped thing)
1330 ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
1331 toHie (TS sc (HsIB ibrn a)) = concatM $
1332 [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
1333 , toHie $ TS sc a
1334 ]
1335 where span = loc a
1336 toHie (TS _ (XHsImplicitBndrs _)) = pure []
1337
1338 instance ( HasLoc thing
1339 , ToHie (TScoped thing)
1340 ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
1341 toHie (TS sc (HsWC names a)) = concatM $
1342 [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1343 , toHie $ TS sc a
1344 ]
1345 where span = loc a
1346 toHie (TS _ (XHsWildCardBndrs _)) = pure []
1347
1348 instance ToHie (SigContext (LSig GhcRn)) where
1349 toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
1350 TypeSig _ names typ ->
1351 [ toHie $ map (C TyDecl) names
1352 , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1353 ]
1354 PatSynSig _ names typ ->
1355 [ toHie $ map (C TyDecl) names
1356 , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1357 ]
1358 ClassOpSig _ _ names typ ->
1359 [ case styp of
1360 ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
1361 _ -> toHie $ map (C $ TyDecl) names
1362 , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1363 ]
1364 IdSig _ _ -> []
1365 FixSig _ fsig ->
1366 [ toHie $ L sp fsig
1367 ]
1368 InlineSig _ name _ ->
1369 [ toHie $ (C Use) name
1370 ]
1371 SpecSig _ name typs _ ->
1372 [ toHie $ (C Use) name
1373 , toHie $ map (TS (ResolvedScopes [])) typs
1374 ]
1375 SpecInstSig _ _ typ ->
1376 [ toHie $ TS (ResolvedScopes []) typ
1377 ]
1378 MinimalSig _ _ form ->
1379 [ toHie form
1380 ]
1381 SCCFunSig _ _ name mtxt ->
1382 [ toHie $ (C Use) name
1383 , pure $ maybe [] (locOnly . getLoc) mtxt
1384 ]
1385 CompleteMatchSig _ _ (L ispan names) typ ->
1386 [ pure $ locOnly ispan
1387 , toHie $ map (C Use) names
1388 , toHie $ fmap (C Use) typ
1389 ]
1390 XSig _ -> []
1391
1392 instance ToHie (LHsType GhcRn) where
1393 toHie x = toHie $ TS (ResolvedScopes []) x
1394
1395 instance ToHie (TScoped (LHsType GhcRn)) where
1396 toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
1397 HsForAllTy _ bndrs body ->
1398 [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
1399 , toHie body
1400 ]
1401 HsQualTy _ ctx body ->
1402 [ toHie ctx
1403 , toHie body
1404 ]
1405 HsTyVar _ _ var ->
1406 [ toHie $ C Use var
1407 ]
1408 HsAppTy _ a b ->
1409 [ toHie a
1410 , toHie b
1411 ]
1412 HsAppKindTy _ ty ki ->
1413 [ toHie ty
1414 , toHie $ TS (ResolvedScopes []) ki
1415 ]
1416 HsFunTy _ a b ->
1417 [ toHie a
1418 , toHie b
1419 ]
1420 HsListTy _ a ->
1421 [ toHie a
1422 ]
1423 HsTupleTy _ _ tys ->
1424 [ toHie tys
1425 ]
1426 HsSumTy _ tys ->
1427 [ toHie tys
1428 ]
1429 HsOpTy _ a op b ->
1430 [ toHie a
1431 , toHie $ C Use op
1432 , toHie b
1433 ]
1434 HsParTy _ a ->
1435 [ toHie a
1436 ]
1437 HsIParamTy _ ip ty ->
1438 [ toHie ip
1439 , toHie ty
1440 ]
1441 HsKindSig _ a b ->
1442 [ toHie a
1443 , toHie b
1444 ]
1445 HsSpliceTy _ a ->
1446 [ toHie $ L span a
1447 ]
1448 HsDocTy _ a _ ->
1449 [ toHie a
1450 ]
1451 HsBangTy _ _ ty ->
1452 [ toHie ty
1453 ]
1454 HsRecTy _ fields ->
1455 [ toHie fields
1456 ]
1457 HsExplicitListTy _ _ tys ->
1458 [ toHie tys
1459 ]
1460 HsExplicitTupleTy _ tys ->
1461 [ toHie tys
1462 ]
1463 HsTyLit _ _ -> []
1464 HsWildCardTy _ -> []
1465 HsStarTy _ _ -> []
1466 XHsType _ -> []
1467
1468 instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1469 toHie (HsValArg tm) = toHie tm
1470 toHie (HsTypeArg _ ty) = toHie ty
1471 toHie (HsArgPar sp) = pure $ locOnly sp
1472
1473 instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
1474 toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1475 UserTyVar _ var ->
1476 [ toHie $ C (TyVarBind sc tsc) var
1477 ]
1478 KindedTyVar _ var kind ->
1479 [ toHie $ C (TyVarBind sc tsc) var
1480 , toHie kind
1481 ]
1482 XTyVarBndr _ -> []
1483
1484 instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1485 toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $
1486 [ pure $ bindingsOnly bindings
1487 , toHie $ tvScopes sc NoScope vars
1488 ]
1489 where
1490 varLoc = loc vars
1491 bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1492 toHie (TS _ (XLHsQTyVars _)) = pure []
1493
1494 instance ToHie (LHsContext GhcRn) where
1495 toHie (L span tys) = concatM $
1496 [ pure $ locOnly span
1497 , toHie tys
1498 ]
1499
1500 instance ToHie (LConDeclField GhcRn) where
1501 toHie (L span field) = concatM $ makeNode field span : case field of
1502 ConDeclField _ fields typ _ ->
1503 [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1504 , toHie typ
1505 ]
1506 XConDeclField _ -> []
1507
1508 instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1509 toHie (From expr) = toHie expr
1510 toHie (FromThen a b) = concatM $
1511 [ toHie a
1512 , toHie b
1513 ]
1514 toHie (FromTo a b) = concatM $
1515 [ toHie a
1516 , toHie b
1517 ]
1518 toHie (FromThenTo a b c) = concatM $
1519 [ toHie a
1520 , toHie b
1521 , toHie c
1522 ]
1523
1524 instance ToHie (LSpliceDecl GhcRn) where
1525 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1526 SpliceDecl _ splice _ ->
1527 [ toHie splice
1528 ]
1529 XSpliceDecl _ -> []
1530
1531 instance ToHie (HsBracket a) where
1532 toHie _ = pure []
1533
1534 instance ToHie PendingRnSplice where
1535 toHie _ = pure []
1536
1537 instance ToHie PendingTcSplice where
1538 toHie _ = pure []
1539
1540 instance ToHie (LBooleanFormula (Located Name)) where
1541 toHie (L span form) = concatM $ makeNode form span : case form of
1542 Var a ->
1543 [ toHie $ C Use a
1544 ]
1545 And forms ->
1546 [ toHie forms
1547 ]
1548 Or forms ->
1549 [ toHie forms
1550 ]
1551 Parens f ->
1552 [ toHie f
1553 ]
1554
1555 instance ToHie (Located HsIPName) where
1556 toHie (L span e) = makeNode e span
1557
1558 instance ( ToHie (LHsExpr a)
1559 , Data (HsSplice a)
1560 ) => ToHie (Located (HsSplice a)) where
1561 toHie (L span sp) = concatM $ makeNode sp span : case sp of
1562 HsTypedSplice _ _ _ expr ->
1563 [ toHie expr
1564 ]
1565 HsUntypedSplice _ _ _ expr ->
1566 [ toHie expr
1567 ]
1568 HsQuasiQuote _ _ _ ispan _ ->
1569 [ pure $ locOnly ispan
1570 ]
1571 HsSpliced _ _ _ ->
1572 []
1573 HsSplicedT _ ->
1574 []
1575 XSplice _ -> []
1576
1577 instance ToHie (LRoleAnnotDecl GhcRn) where
1578 toHie (L span annot) = concatM $ makeNode annot span : case annot of
1579 RoleAnnotDecl _ var roles ->
1580 [ toHie $ C Use var
1581 , concatMapM (pure . locOnly . getLoc) roles
1582 ]
1583 XRoleAnnotDecl _ -> []
1584
1585 instance ToHie (LInstDecl GhcRn) where
1586 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1587 ClsInstD _ d ->
1588 [ toHie $ L span d
1589 ]
1590 DataFamInstD _ d ->
1591 [ toHie $ L span d
1592 ]
1593 TyFamInstD _ d ->
1594 [ toHie $ L span d
1595 ]
1596 XInstDecl _ -> []
1597
1598 instance ToHie (LClsInstDecl GhcRn) where
1599 toHie (L span decl) = concatM
1600 [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
1601 , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1602 , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
1603 , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
1604 , toHie $ cid_tyfam_insts decl
1605 , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
1606 , toHie $ cid_datafam_insts decl
1607 , toHie $ cid_overlap_mode decl
1608 ]
1609
1610 instance ToHie (LDataFamInstDecl GhcRn) where
1611 toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1612
1613 instance ToHie (LTyFamInstDecl GhcRn) where
1614 toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1615
1616 instance ToHie (Context a)
1617 => ToHie (PatSynFieldContext (RecordPatSynField a)) where
1618 toHie (PSC sp (RecordPatSynField a b)) = concatM $
1619 [ toHie $ C (RecField RecFieldDecl sp) a
1620 , toHie $ C Use b
1621 ]
1622
1623 instance ToHie (LDerivDecl GhcRn) where
1624 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1625 DerivDecl _ typ strat overlap ->
1626 [ toHie $ TS (ResolvedScopes []) typ
1627 , toHie strat
1628 , toHie overlap
1629 ]
1630 XDerivDecl _ -> []
1631
1632 instance ToHie (LFixitySig GhcRn) where
1633 toHie (L span sig) = concatM $ makeNode sig span : case sig of
1634 FixitySig _ vars _ ->
1635 [ toHie $ map (C Use) vars
1636 ]
1637 XFixitySig _ -> []
1638
1639 instance ToHie (LDefaultDecl GhcRn) where
1640 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1641 DefaultDecl _ typs ->
1642 [ toHie typs
1643 ]
1644 XDefaultDecl _ -> []
1645
1646 instance ToHie (LForeignDecl GhcRn) where
1647 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1648 ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1649 [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
1650 , toHie $ TS (ResolvedScopes []) sig
1651 , toHie fi
1652 ]
1653 ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1654 [ toHie $ C Use name
1655 , toHie $ TS (ResolvedScopes []) sig
1656 , toHie fe
1657 ]
1658 XForeignDecl _ -> []
1659
1660 instance ToHie ForeignImport where
1661 toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
1662 [ locOnly a
1663 , locOnly b
1664 , locOnly c
1665 ]
1666
1667 instance ToHie ForeignExport where
1668 toHie (CExport (L a _) (L b _)) = pure $ concat $
1669 [ locOnly a
1670 , locOnly b
1671 ]
1672
1673 instance ToHie (LWarnDecls GhcRn) where
1674 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1675 Warnings _ _ warnings ->
1676 [ toHie warnings
1677 ]
1678 XWarnDecls _ -> []
1679
1680 instance ToHie (LWarnDecl GhcRn) where
1681 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1682 Warning _ vars _ ->
1683 [ toHie $ map (C Use) vars
1684 ]
1685 XWarnDecl _ -> []
1686
1687 instance ToHie (LAnnDecl GhcRn) where
1688 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1689 HsAnnotation _ _ prov expr ->
1690 [ toHie prov
1691 , toHie expr
1692 ]
1693 XAnnDecl _ -> []
1694
1695 instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
1696 toHie (ValueAnnProvenance a) = toHie $ C Use a
1697 toHie (TypeAnnProvenance a) = toHie $ C Use a
1698 toHie ModuleAnnProvenance = pure []
1699
1700 instance ToHie (LRuleDecls GhcRn) where
1701 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1702 HsRules _ _ rules ->
1703 [ toHie rules
1704 ]
1705 XRuleDecls _ -> []
1706
1707 instance ToHie (LRuleDecl GhcRn) where
1708 toHie (L _ (XRuleDecl _)) = pure []
1709 toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
1710 [ makeNode r span
1711 , pure $ locOnly $ getLoc rname
1712 , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1713 , toHie $ map (RS $ mkScope span) bndrs
1714 , toHie exprA
1715 , toHie exprB
1716 ]
1717 where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
1718 bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
1719 exprA_sc = mkLScope exprA
1720 exprB_sc = mkLScope exprB
1721
1722 instance ToHie (RScoped (LRuleBndr GhcRn)) where
1723 toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1724 RuleBndr _ var ->
1725 [ toHie $ C (ValBind RegularBind sc Nothing) var
1726 ]
1727 RuleBndrSig _ var typ ->
1728 [ toHie $ C (ValBind RegularBind sc Nothing) var
1729 , toHie $ TS (ResolvedScopes [sc]) typ
1730 ]
1731 XRuleBndr _ -> []
1732
1733 instance ToHie (LImportDecl GhcRn) where
1734 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1735 ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
1736 [ toHie $ IEC Import name
1737 , toHie $ fmap (IEC ImportAs) as
1738 , maybe (pure []) goIE hidden
1739 ]
1740 XImportDecl _ -> []
1741 where
1742 goIE (hiding, (L sp liens)) = concatM $
1743 [ pure $ locOnly sp
1744 , toHie $ map (IEC c) liens
1745 ]
1746 where
1747 c = if hiding then ImportHiding else Import
1748
1749 instance ToHie (IEContext (LIE GhcRn)) where
1750 toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
1751 IEVar _ n ->
1752 [ toHie $ IEC c n
1753 ]
1754 IEThingAbs _ n ->
1755 [ toHie $ IEC c n
1756 ]
1757 IEThingAll _ n ->
1758 [ toHie $ IEC c n
1759 ]
1760 IEThingWith _ n _ ns flds ->
1761 [ toHie $ IEC c n
1762 , toHie $ map (IEC c) ns
1763 , toHie $ map (IEC c) flds
1764 ]
1765 IEModuleContents _ n ->
1766 [ toHie $ IEC c n
1767 ]
1768 IEGroup _ _ _ -> []
1769 IEDoc _ _ -> []
1770 IEDocNamed _ _ -> []
1771 XIE _ -> []
1772
1773 instance ToHie (IEContext (LIEWrappedName Name)) where
1774 toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
1775 IEName n ->
1776 [ toHie $ C (IEThing c) n
1777 ]
1778 IEPattern p ->
1779 [ toHie $ C (IEThing c) p
1780 ]
1781 IEType n ->
1782 [ toHie $ C (IEThing c) n
1783 ]
1784
1785 instance ToHie (IEContext (Located (FieldLbl Name))) where
1786 toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
1787 FieldLabel _ _ n ->
1788 [ toHie $ C (IEThing c) $ L span n
1789 ]