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