0040b30cde2b4f14b8db16987ef81fc85624c203
[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
38 import HieTypes
39 import HieUtils
40
41 import qualified Data.Array as A
42 import qualified Data.ByteString as BS
43 import qualified Data.ByteString.Char8 as BSC
44 import qualified Data.Map as M
45 import qualified Data.Set as S
46 import Data.Data ( Data, Typeable )
47 import Data.List ( foldl1' )
48 import Data.Maybe ( listToMaybe )
49 import Control.Monad.Trans.Reader
50 import Control.Monad.Trans.Class ( lift )
51
52 -- These synonyms match those defined in main/GHC.hs
53 type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
54 , Maybe [(LIE GhcRn, Avails)]
55 , Maybe LHsDocString )
56 type TypecheckedSource = LHsBinds GhcTc
57
58
59 {- Note [Name Remapping]
60 The Typechecker introduces new names for mono names in AbsBinds.
61 We don't care about the distinction between mono and poly bindings,
62 so we replace all occurrences of the mono name with the poly name.
63 -}
64 newtype HieState = HieState
65 { name_remapping :: NameEnv Id
66 }
67
68 initState :: HieState
69 initState = HieState emptyNameEnv
70
71 class ModifyState a where -- See Note [Name Remapping]
72 addSubstitution :: a -> a -> HieState -> HieState
73
74 instance ModifyState Name where
75 addSubstitution _ _ hs = hs
76
77 instance ModifyState Id where
78 addSubstitution mono poly hs =
79 hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
80
81 modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
82 modifyState = foldr go id
83 where
84 go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
85 go _ f = f
86
87 type HieM = ReaderT HieState Hsc
88
89 -- | Construct an 'HieFile' from the outputs of the typechecker.
90 mkHieFile :: ModSummary -> TypecheckedSource -> RenamedSource -> Hsc HieFile
91 mkHieFile ms ts rs = do
92 (asts', arr) <- getCompressedAsts ts rs
93 let Just src_file = ml_hs_file $ ms_location ms
94 src <- liftIO $ BS.readFile src_file
95 return $ HieFile
96 { hie_version = curHieVersion
97 , hie_ghc_version = BSC.pack cProjectVersion
98 , hie_hs_file = src_file
99 , hie_types = arr
100 , hie_asts = asts'
101 , hie_hs_src = src
102 }
103
104 getCompressedAsts :: TypecheckedSource -> RenamedSource
105 -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
106 getCompressedAsts ts rs = do
107 asts <- enrichHie ts rs
108 return $ compressTypes asts
109
110 enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
111 enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
112 tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
113 rasts <- processGrp hsGrp
114 imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
115 exps <- toHie $ fmap (map $ IEC Export . fst) exports
116 let spanFile children = case children of
117 [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
118 _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
119 (realSrcSpanEnd $ nodeSpan $ last children)
120
121 modulify xs =
122 Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
123
124 asts = HieASTs
125 $ resolveTyVarScopes
126 $ M.map (modulify . mergeSortAsts)
127 $ M.fromListWith (++)
128 $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
129
130 flat_asts = concat
131 [ tasts
132 , rasts
133 , imps
134 , exps
135 ]
136 return asts
137 where
138 processGrp grp = concatM
139 [ toHie $ fmap (RS ModuleScope ) hs_valds grp
140 , toHie $ hs_splcds grp
141 , toHie $ hs_tyclds grp
142 , toHie $ hs_derivds grp
143 , toHie $ hs_fixds grp
144 , toHie $ hs_defds grp
145 , toHie $ hs_fords grp
146 , toHie $ hs_warnds grp
147 , toHie $ hs_annds grp
148 , toHie $ hs_ruleds grp
149 ]
150
151 getRealSpan :: SrcSpan -> Maybe Span
152 getRealSpan (RealSrcSpan sp) = Just sp
153 getRealSpan _ = Nothing
154
155 grhss_span :: GRHSs p body -> SrcSpan
156 grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
157 grhss_span (XGRHSs _) = error "XGRHS has no span"
158
159 bindingsOnly :: [Context Name] -> [HieAST a]
160 bindingsOnly [] = []
161 bindingsOnly (C c n : xs) = case nameSrcSpan n of
162 RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
163 where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
164 info = mempty{identInfo = S.singleton c}
165 _ -> bindingsOnly xs
166
167 concatM :: Monad m => [m [a]] -> m [a]
168 concatM xs = concat <$> sequence xs
169
170 {- Note [Capturing Scopes and other non local information]
171 toHie is a local tranformation, but scopes of bindings cannot be known locally,
172 hence we have to push the relevant info down into the binding nodes.
173 We use the following types (*Context and *Scoped) to wrap things and
174 carry the required info
175 (Maybe Span) always carries the span of the entire binding, including rhs
176 -}
177 data Context a = C ContextInfo a -- Used for names and bindings
178
179 data RContext a = RC RecFieldContext a
180 data RFContext a = RFC RecFieldContext (Maybe Span) a
181 -- ^ context for record fields
182
183 data IEContext a = IEC IEType a
184 -- ^ context for imports/exports
185
186 data BindContext a = BC BindType Scope a
187 -- ^ context for imports/exports
188
189 data PatSynFieldContext a = PSC (Maybe Span) a
190 -- ^ context for pattern synonym fields.
191
192 data SigContext a = SC SigInfo a
193 -- ^ context for type signatures
194
195 data SigInfo = SI SigType (Maybe Span)
196
197 data SigType = BindSig | ClassSig | InstSig
198
199 data RScoped a = RS Scope a
200 -- ^ Scope spans over everything to the right of a, (mostly) not
201 -- including a itself
202 -- (Includes a in a few special cases like recursive do bindings) or
203 -- let/where bindings
204
205 -- | Pattern scope
206 data PScoped a = PS (Maybe Span)
207 Scope -- ^ use site of the pattern
208 Scope -- ^ pattern to the right of a, not including a
209 a
210 deriving (Typeable, Data) -- Pattern Scope
211
212 {- Note [TyVar Scopes]
213 Due to -XScopedTypeVariables, type variables can be in scope quite far from
214 their original binding. We resolve the scope of these type variables
215 in a separate pass
216 -}
217 data TScoped a = TS TyVarScope a -- TyVarScope
218
219 data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
220 -- ^ First scope remains constant
221 -- Second scope is used to build up the scope of a tyvar over
222 -- things to its right, ala RScoped
223
224 -- | Each element scopes over the elements to the right
225 listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
226 listScopes _ [] = []
227 listScopes rhsScope [pat] = [RS rhsScope pat]
228 listScopes rhsScope (pat : pats) = RS sc pat : pats'
229 where
230 pats'@((RS scope p):_) = listScopes rhsScope pats
231 sc = combineScopes scope $ mkScope $ getLoc p
232
233 -- | 'listScopes' specialised to 'PScoped' things
234 patScopes
235 :: Maybe Span
236 -> Scope
237 -> Scope
238 -> [LPat (GhcPass p)]
239 -> [PScoped (LPat (GhcPass p))]
240 patScopes rsp useScope patScope xs =
241 map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
242 listScopes patScope (map dL xs)
243
244 -- | 'listScopes' specialised to 'TVScoped' things
245 tvScopes
246 :: TyVarScope
247 -> Scope
248 -> [LHsTyVarBndr a]
249 -> [TVScoped (LHsTyVarBndr a)]
250 tvScopes tvScope rhsScope xs =
251 map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
252
253 {- Note [Scoping Rules for SigPat]
254 Explicitly quantified variables in pattern type signatures are not
255 brought into scope in the rhs, but implicitly quantified variables
256 are (HsWC and HsIB).
257 This is unlike other signatures, where explicitly quantified variables
258 are brought into the RHS Scope
259 For example
260 foo :: forall a. ...;
261 foo = ... -- a is in scope here
262
263 bar (x :: forall a. a -> a) = ... -- a is not in scope here
264 -- ^ a is in scope here (pattern body)
265
266 bax (x :: a) = ... -- a is in scope here
267 Because of HsWC and HsIB pass on their scope to their children
268 we must wrap the LHsType in pattern signatures in a
269 Shielded explictly, so that the HsWC/HsIB scope is not passed
270 on the the LHsType
271 -}
272
273 data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
274
275 type family ProtectedSig a where
276 ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
277 GhcRn
278 (Shielded (LHsType GhcRn)))
279 ProtectedSig GhcTc = NoExt
280
281 class ProtectSig a where
282 protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
283
284 instance (HasLoc a) => HasLoc (Shielded a) where
285 loc (SH _ a) = loc a
286
287 instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
288 toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
289
290 instance ProtectSig GhcTc where
291 protectSig _ _ = NoExt
292
293 instance ProtectSig GhcRn where
294 protectSig sc (HsWC a (HsIB b sig)) =
295 HsWC a (HsIB b (SH sc sig))
296 protectSig _ _ = error "protectSig not given HsWC (HsIB)"
297
298 class HasLoc a where
299 -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
300 -- know what their implicit bindings are scoping over
301 loc :: a -> SrcSpan
302
303 instance HasLoc thing => HasLoc (TScoped thing) where
304 loc (TS _ a) = loc a
305
306 instance HasLoc thing => HasLoc (PScoped thing) where
307 loc (PS _ _ _ a) = loc a
308
309 instance HasLoc (LHsQTyVars GhcRn) where
310 loc (HsQTvs _ vs) = loc vs
311 loc _ = noSrcSpan
312
313 instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
314 loc (HsIB _ a) = loc a
315 loc _ = noSrcSpan
316
317 instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
318 loc (HsWC _ a) = loc a
319 loc _ = noSrcSpan
320
321 instance HasLoc (Located a) where
322 loc (L l _) = l
323
324 instance HasLoc a => HasLoc [a] where
325 loc [] = noSrcSpan
326 loc xs = foldl1' combineSrcSpans $ map loc xs
327
328 instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
329 loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
330 loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
331 [loc a, loc tvs, loc b, loc c]
332 loc _ = noSrcSpan
333 instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
334 loc (HsValArg tm) = loc tm
335 loc (HsTypeArg _ ty) = loc ty
336 loc (HsArgPar sp) = sp
337
338 instance HasLoc (HsDataDefn GhcRn) where
339 loc def@(HsDataDefn{}) = loc $ dd_cons def
340 -- Only used for data family instances, so we only need rhs
341 -- Most probably the rest will be unhelpful anyway
342 loc _ = noSrcSpan
343
344 instance HasLoc (Pat (GhcPass a)) where
345 loc (dL -> L l _) = l
346
347 -- | The main worker class
348 class ToHie a where
349 toHie :: a -> HieM [HieAST Type]
350
351 -- | Used to collect type info
352 class Data a => HasType a where
353 getTypeNode :: a -> HieM [HieAST Type]
354
355 instance (ToHie a) => ToHie [a] where
356 toHie = concatMapM toHie
357
358 instance (ToHie a) => ToHie (Bag a) where
359 toHie = toHie . bagToList
360
361 instance (ToHie a) => ToHie (Maybe a) where
362 toHie = maybe (pure []) toHie
363
364 instance ToHie (Context (Located NoExt)) where
365 toHie _ = pure []
366
367 instance ToHie (TScoped NoExt) where
368 toHie _ = pure []
369
370 instance ToHie (IEContext (Located ModuleName)) where
371 toHie (IEC c (L (RealSrcSpan span) mname)) =
372 pure $ [Node (NodeInfo S.empty [] idents) span []]
373 where details = mempty{identInfo = S.singleton (IEThing c)}
374 idents = M.singleton (Left mname) details
375 toHie _ = pure []
376
377 instance ToHie (Context (Located Var)) where
378 toHie c = case c of
379 C context (L (RealSrcSpan span) name')
380 -> do
381 m <- asks name_remapping
382 let name = case lookupNameEnv m (varName name') of
383 Just var -> var
384 Nothing-> name'
385 pure
386 [Node
387 (NodeInfo S.empty [] $
388 M.singleton (Right $ varName name)
389 (IdentifierDetails (Just $ varType name')
390 (S.singleton context)))
391 span
392 []]
393 _ -> pure []
394
395 instance ToHie (Context (Located Name)) where
396 toHie c = case c of
397 C context (L (RealSrcSpan span) name') -> do
398 m <- asks name_remapping
399 let name = case lookupNameEnv m name' of
400 Just var -> varName var
401 Nothing -> name'
402 pure
403 [Node
404 (NodeInfo S.empty [] $
405 M.singleton (Right name)
406 (IdentifierDetails Nothing
407 (S.singleton context)))
408 span
409 []]
410 _ -> pure []
411
412 -- | Dummy instances - never called
413 instance ToHie (TScoped (LHsSigWcType GhcTc)) where
414 toHie _ = pure []
415 instance ToHie (TScoped (LHsWcType GhcTc)) where
416 toHie _ = pure []
417 instance ToHie (SigContext (LSig GhcTc)) where
418 toHie _ = pure []
419 instance ToHie (TScoped Type) where
420 toHie _ = pure []
421
422 instance HasType (LHsBind GhcRn) where
423 getTypeNode (L spn bind) = makeNode bind spn
424
425 instance HasType (LHsBind GhcTc) where
426 getTypeNode (L spn bind) = case bind of
427 FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
428 _ -> makeNode bind spn
429
430 instance HasType (LPat GhcRn) where
431 getTypeNode (dL -> L spn pat) = makeNode pat spn
432
433 instance HasType (LPat GhcTc) where
434 getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
435
436 instance HasType (LHsExpr GhcRn) where
437 getTypeNode (L spn e) = makeNode e spn
438
439 -- | This instance tries to construct 'HieAST' nodes which include the type of
440 -- the expression. It is not yet possible to do this efficiently for all
441 -- expression forms, so we skip filling in the type for those inputs.
442 --
443 -- 'HsApp', for example, doesn't have any type information available directly on
444 -- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
445 -- query the type of that. Yet both the desugaring call and the type query both
446 -- involve recursive calls to the function and argument! This is particularly
447 -- problematic when you realize that the HIE traversal will eventually visit
448 -- those nodes too and ask for their types again.
449 --
450 -- Since the above is quite costly, we just skip cases where computing the
451 -- expression's type is going to be expensive.
452 --
453 -- See #16233
454 instance HasType (LHsExpr GhcTc) where
455 getTypeNode e@(L spn e') = lift $
456 -- Some expression forms have their type immediately available
457 let tyOpt = case e' of
458 HsLit _ l -> Just (hsLitType l)
459 HsOverLit _ o -> Just (overLitType o)
460
461 HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
462 HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
463 HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
464
465 ExplicitList ty _ _ -> Just (mkListTy ty)
466 ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
467 HsDo ty _ _ -> Just ty
468 HsMultiIf ty _ -> Just ty
469
470 _ -> Nothing
471
472 in
473 case tyOpt of
474 _ | skipDesugaring e' -> fallback
475 | otherwise -> do
476 hs_env <- Hsc $ \e w -> return (e,w)
477 (_,mbe) <- liftIO $ deSugarExpr hs_env e
478 maybe fallback (makeTypeNode e' spn . exprType) mbe
479 where
480 fallback = makeNode e' spn
481
482 matchGroupType :: MatchGroupTc -> Type
483 matchGroupType (MatchGroupTc args res) = mkFunTys args res
484
485 -- | Skip desugaring of these expressions for performance reasons.
486 --
487 -- See impact on Haddock output (esp. missing type annotations or links)
488 -- before marking more things here as 'False'. See impact on Haddock
489 -- performance before marking more things as 'True'.
490 skipDesugaring :: HsExpr a -> Bool
491 skipDesugaring e = case e of
492 HsVar{} -> False
493 HsUnboundVar{} -> False
494 HsConLikeOut{} -> False
495 HsRecFld{} -> False
496 HsOverLabel{} -> False
497 HsIPVar{} -> False
498 HsWrap{} -> False
499 _ -> True
500
501 instance ( ToHie (Context (Located (IdP a)))
502 , ToHie (MatchGroup a (LHsExpr a))
503 , ToHie (PScoped (LPat a))
504 , ToHie (GRHSs a (LHsExpr a))
505 , ToHie (LHsExpr a)
506 , ToHie (Located (PatSynBind a a))
507 , HasType (LHsBind a)
508 , ModifyState (IdP a)
509 , Data (HsBind a)
510 ) => ToHie (BindContext (LHsBind a)) where
511 toHie (BC context scope b@(L span bind)) =
512 concatM $ getTypeNode b : case bind of
513 FunBind{fun_id = name, fun_matches = matches} ->
514 [ toHie $ C (ValBind context scope $ getRealSpan span) name
515 , toHie matches
516 ]
517 PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
518 [ toHie $ PS (getRealSpan span) scope NoScope lhs
519 , toHie rhs
520 ]
521 VarBind{var_rhs = expr} ->
522 [ toHie expr
523 ]
524 AbsBinds{abs_exports = xs, abs_binds = binds} ->
525 [ local (modifyState xs) $ -- Note [Name Remapping]
526 toHie $ fmap (BC context scope) binds
527 ]
528 PatSynBind _ psb ->
529 [ toHie $ L span psb -- PatSynBinds only occur at the top level
530 ]
531 XHsBindsLR _ -> []
532
533 instance ( ToHie (LMatch a body)
534 ) => ToHie (MatchGroup a body) where
535 toHie mg = concatM $ case mg of
536 MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
537 [ pure $ locOnly span
538 , toHie alts
539 ]
540 MG{} -> []
541 XMatchGroup _ -> []
542
543 instance ( ToHie (Context (Located (IdP a)))
544 , ToHie (PScoped (LPat a))
545 , ToHie (HsPatSynDir a)
546 ) => ToHie (Located (PatSynBind a a)) where
547 toHie (L sp psb) = concatM $ case psb of
548 PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
549 [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
550 , toHie $ toBind dets
551 , toHie $ PS Nothing lhsScope NoScope pat
552 , toHie dir
553 ]
554 where
555 lhsScope = combineScopes varScope detScope
556 varScope = mkLScope var
557 detScope = case dets of
558 (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
559 (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
560 (RecCon r) -> foldr go NoScope r
561 go (RecordPatSynField a b) c = combineScopes c
562 $ combineScopes (mkLScope a) (mkLScope b)
563 detSpan = case detScope of
564 LocalScope a -> Just a
565 _ -> Nothing
566 toBind (PrefixCon args) = PrefixCon $ map (C Use) args
567 toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
568 toBind (RecCon r) = RecCon $ map (PSC detSpan) r
569 XPatSynBind _ -> []
570
571 instance ( ToHie (MatchGroup a (LHsExpr a))
572 ) => ToHie (HsPatSynDir a) where
573 toHie dir = case dir of
574 ExplicitBidirectional mg -> toHie mg
575 _ -> pure []
576
577 instance ( a ~ GhcPass p
578 , ToHie body
579 , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
580 , ToHie (PScoped (LPat a))
581 , ToHie (GRHSs a body)
582 , Data (Match a body)
583 ) => ToHie (LMatch (GhcPass p) body) where
584 toHie (L span m ) = concatM $ makeNode m span : case m of
585 Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
586 [ toHie mctx
587 , let rhsScope = mkScope $ grhss_span grhss
588 in toHie $ patScopes Nothing rhsScope NoScope pats
589 , toHie grhss
590 ]
591 XMatch _ -> []
592
593 instance ( ToHie (Context (Located a))
594 ) => ToHie (HsMatchContext a) where
595 toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
596 toHie (StmtCtxt a) = toHie a
597 toHie _ = pure []
598
599 instance ( ToHie (HsMatchContext a)
600 ) => ToHie (HsStmtContext a) where
601 toHie (PatGuard a) = toHie a
602 toHie (ParStmtCtxt a) = toHie a
603 toHie (TransStmtCtxt a) = toHie a
604 toHie _ = pure []
605
606 instance ( a ~ GhcPass p
607 , ToHie (Context (Located (IdP a)))
608 , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
609 , ToHie (LHsExpr a)
610 , ToHie (TScoped (LHsSigWcType a))
611 , ProtectSig a
612 , ToHie (TScoped (ProtectedSig a))
613 , HasType (LPat a)
614 , Data (HsSplice a)
615 ) => ToHie (PScoped (LPat (GhcPass p))) where
616 toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
617 concatM $ getTypeNode lpat : case opat of
618 WildPat _ ->
619 []
620 VarPat _ lname ->
621 [ toHie $ C (PatternBind scope pscope rsp) lname
622 ]
623 LazyPat _ p ->
624 [ toHie $ PS rsp scope pscope p
625 ]
626 AsPat _ lname pat ->
627 [ toHie $ C (PatternBind scope
628 (combineScopes (mkLScope (dL pat)) pscope)
629 rsp)
630 lname
631 , toHie $ PS rsp scope pscope pat
632 ]
633 ParPat _ pat ->
634 [ toHie $ PS rsp scope pscope pat
635 ]
636 BangPat _ pat ->
637 [ toHie $ PS rsp scope pscope pat
638 ]
639 ListPat _ pats ->
640 [ toHie $ patScopes rsp scope pscope pats
641 ]
642 TuplePat _ pats _ ->
643 [ toHie $ patScopes rsp scope pscope pats
644 ]
645 SumPat _ pat _ _ ->
646 [ toHie $ PS rsp scope pscope pat
647 ]
648 ConPatIn c dets ->
649 [ toHie $ C Use c
650 , toHie $ contextify dets
651 ]
652 ConPatOut {pat_con = con, pat_args = dets}->
653 [ toHie $ C Use $ fmap conLikeName con
654 , toHie $ contextify dets
655 ]
656 ViewPat _ expr pat ->
657 [ toHie expr
658 , toHie $ PS rsp scope pscope pat
659 ]
660 SplicePat _ sp ->
661 [ toHie $ L ospan sp
662 ]
663 LitPat _ _ ->
664 []
665 NPat _ _ _ _ ->
666 []
667 NPlusKPat _ n _ _ _ _ ->
668 [ toHie $ C (PatternBind scope pscope rsp) n
669 ]
670 SigPat _ pat sig ->
671 [ toHie $ PS rsp scope pscope pat
672 , let cscope = mkLScope (dL pat) in
673 toHie $ TS (ResolvedScopes [cscope, scope, pscope])
674 (protectSig @a cscope sig)
675 -- See Note [Scoping Rules for SigPat]
676 ]
677 CoPat _ _ _ _ ->
678 []
679 XPat _ -> []
680 where
681 contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
682 contextify (InfixCon a b) = InfixCon a' b'
683 where [a', b'] = patScopes rsp scope pscope [a,b]
684 contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
685 contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
686 where
687 go (RS fscope (L spn (HsRecField lbl pat pun))) =
688 L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
689 scoped_fds = listScopes pscope fds
690
691 instance ( ToHie body
692 , ToHie (LGRHS a body)
693 , ToHie (RScoped (LHsLocalBinds a))
694 ) => ToHie (GRHSs a body) where
695 toHie grhs = concatM $ case grhs of
696 GRHSs _ grhss binds ->
697 [ toHie grhss
698 , toHie $ RS (mkScope $ grhss_span grhs) binds
699 ]
700 XGRHSs _ -> []
701
702 instance ( ToHie (Located body)
703 , ToHie (RScoped (GuardLStmt a))
704 , Data (GRHS a (Located body))
705 ) => ToHie (LGRHS a (Located body)) where
706 toHie (L span g) = concatM $ makeNode g span : case g of
707 GRHS _ guards body ->
708 [ toHie $ listScopes (mkLScope body) guards
709 , toHie body
710 ]
711 XGRHS _ -> []
712
713 instance ( a ~ GhcPass p
714 , ToHie (Context (Located (IdP a)))
715 , HasType (LHsExpr a)
716 , ToHie (PScoped (LPat a))
717 , ToHie (MatchGroup a (LHsExpr a))
718 , ToHie (LGRHS a (LHsExpr a))
719 , ToHie (RContext (HsRecordBinds a))
720 , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
721 , ToHie (ArithSeqInfo a)
722 , ToHie (LHsCmdTop a)
723 , ToHie (RScoped (GuardLStmt a))
724 , ToHie (RScoped (LHsLocalBinds a))
725 , ToHie (TScoped (LHsWcType (NoGhcTc a)))
726 , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
727 , Data (HsExpr a)
728 , Data (HsSplice a)
729 , Data (HsTupArg a)
730 , Data (AmbiguousFieldOcc a)
731 ) => ToHie (LHsExpr (GhcPass p)) where
732 toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
733 HsVar _ (L _ var) ->
734 [ toHie $ C Use (L mspan var)
735 -- Patch up var location since typechecker removes it
736 ]
737 HsUnboundVar _ _ ->
738 []
739 HsConLikeOut _ con ->
740 [ toHie $ C Use $ L mspan $ conLikeName con
741 ]
742 HsRecFld _ fld ->
743 [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
744 ]
745 HsOverLabel _ _ _ -> []
746 HsIPVar _ _ -> []
747 HsOverLit _ _ -> []
748 HsLit _ _ -> []
749 HsLam _ mg ->
750 [ toHie mg
751 ]
752 HsLamCase _ mg ->
753 [ toHie mg
754 ]
755 HsApp _ a b ->
756 [ toHie a
757 , toHie b
758 ]
759 HsAppType _ expr sig ->
760 [ toHie expr
761 , toHie $ TS (ResolvedScopes []) sig
762 ]
763 OpApp _ a b c ->
764 [ toHie a
765 , toHie b
766 , toHie c
767 ]
768 NegApp _ a _ ->
769 [ toHie a
770 ]
771 HsPar _ a ->
772 [ toHie a
773 ]
774 SectionL _ a b ->
775 [ toHie a
776 , toHie b
777 ]
778 SectionR _ a b ->
779 [ toHie a
780 , toHie b
781 ]
782 ExplicitTuple _ args _ ->
783 [ toHie args
784 ]
785 ExplicitSum _ _ _ expr ->
786 [ toHie expr
787 ]
788 HsCase _ expr matches ->
789 [ toHie expr
790 , toHie matches
791 ]
792 HsIf _ _ a b c ->
793 [ toHie a
794 , toHie b
795 , toHie c
796 ]
797 HsMultiIf _ grhss ->
798 [ toHie grhss
799 ]
800 HsLet _ binds expr ->
801 [ toHie $ RS (mkLScope expr) binds
802 , toHie expr
803 ]
804 HsDo _ _ (L ispan stmts) ->
805 [ pure $ locOnly ispan
806 , toHie $ listScopes NoScope stmts
807 ]
808 ExplicitList _ _ exprs ->
809 [ toHie exprs
810 ]
811 RecordCon {rcon_con_name = name, rcon_flds = binds}->
812 [ toHie $ C Use name
813 , toHie $ RC RecFieldAssign $ binds
814 ]
815 RecordUpd {rupd_expr = expr, rupd_flds = upds}->
816 [ toHie expr
817 , toHie $ map (RC RecFieldAssign) upds
818 ]
819 ExprWithTySig _ expr sig ->
820 [ toHie expr
821 , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
822 ]
823 ArithSeq _ _ info ->
824 [ toHie info
825 ]
826 HsSCC _ _ _ expr ->
827 [ toHie expr
828 ]
829 HsCoreAnn _ _ _ expr ->
830 [ toHie expr
831 ]
832 HsProc _ pat cmdtop ->
833 [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
834 , toHie cmdtop
835 ]
836 HsStatic _ expr ->
837 [ toHie expr
838 ]
839 HsArrApp _ a b _ _ ->
840 [ toHie a
841 , toHie b
842 ]
843 HsArrForm _ expr _ cmds ->
844 [ toHie expr
845 , toHie cmds
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 (HsQTvsRn 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 ]