Revert "Batch merge"
[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 separate 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 instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
332 loc (HsValArg tm) = loc tm
333 loc (HsTypeArg ty) = loc ty
334 loc (HsArgPar sp) = sp
335
336 instance HasLoc (HsDataDefn GhcRn) where
337 loc def@(HsDataDefn{}) = loc $ dd_cons def
338 -- Only used for data family instances, so we only need rhs
339 -- Most probably the rest will be unhelpful anyway
340 loc _ = noSrcSpan
341
342 instance HasLoc (Pat (GhcPass a)) where
343 loc (dL -> L l _) = l
344
345 -- | The main worker class
346 class ToHie a where
347 toHie :: a -> HieM [HieAST Type]
348
349 -- | Used to collect type info
350 class Data a => HasType a where
351 getTypeNode :: a -> HieM [HieAST Type]
352
353 instance (ToHie a) => ToHie [a] where
354 toHie = concatMapM toHie
355
356 instance (ToHie a) => ToHie (Bag a) where
357 toHie = toHie . bagToList
358
359 instance (ToHie a) => ToHie (Maybe a) where
360 toHie = maybe (pure []) toHie
361
362 instance ToHie (Context (Located NoExt)) where
363 toHie _ = pure []
364
365 instance ToHie (TScoped NoExt) where
366 toHie _ = pure []
367
368 instance ToHie (IEContext (Located ModuleName)) where
369 toHie (IEC c (L (RealSrcSpan span) mname)) =
370 pure $ [Node (NodeInfo S.empty [] idents) span []]
371 where details = mempty{identInfo = S.singleton (IEThing c)}
372 idents = M.singleton (Left mname) details
373 toHie _ = pure []
374
375 instance ToHie (Context (Located Var)) where
376 toHie c = case c of
377 C context (L (RealSrcSpan span) name')
378 -> do
379 m <- asks name_remapping
380 let name = M.findWithDefault name' (varName name') m
381 pure
382 [Node
383 (NodeInfo S.empty [] $
384 M.singleton (Right $ varName name)
385 (IdentifierDetails (Just $ varType name')
386 (S.singleton context)))
387 span
388 []]
389 _ -> pure []
390
391 instance ToHie (Context (Located Name)) where
392 toHie c = case c of
393 C context (L (RealSrcSpan span) name') -> do
394 m <- asks name_remapping
395 let name = case M.lookup name' m of
396 Just var -> varName var
397 Nothing -> name'
398 pure
399 [Node
400 (NodeInfo S.empty [] $
401 M.singleton (Right name)
402 (IdentifierDetails Nothing
403 (S.singleton context)))
404 span
405 []]
406 _ -> pure []
407
408 -- | Dummy instances - never called
409 instance ToHie (TScoped (LHsSigWcType GhcTc)) where
410 toHie _ = pure []
411 instance ToHie (TScoped (LHsWcType GhcTc)) where
412 toHie _ = pure []
413 instance ToHie (SigContext (LSig GhcTc)) where
414 toHie _ = pure []
415 instance ToHie (TScoped Type) where
416 toHie _ = pure []
417
418 instance HasType (LHsBind GhcRn) where
419 getTypeNode (L spn bind) = makeNode bind spn
420
421 instance HasType (LHsBind GhcTc) where
422 getTypeNode (L spn bind) = case bind of
423 FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
424 _ -> makeNode bind spn
425
426 instance HasType (LPat GhcRn) where
427 getTypeNode (dL -> L spn pat) = makeNode pat spn
428
429 instance HasType (LPat GhcTc) where
430 getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
431
432 instance HasType (LHsExpr GhcRn) where
433 getTypeNode (L spn e) = makeNode e spn
434
435 instance HasType (LHsExpr GhcTc) where
436 getTypeNode e@(L spn e') = lift $ do
437 hs_env <- Hsc $ \e w -> return (e,w)
438 (_,mbe) <- liftIO $ deSugarExpr hs_env e
439 case mbe of
440 Just te -> makeTypeNode e' spn (exprType te)
441 Nothing -> makeNode e' spn
442
443 instance ( ToHie (Context (Located (IdP a)))
444 , ToHie (MatchGroup a (LHsExpr a))
445 , ToHie (PScoped (LPat a))
446 , ToHie (GRHSs a (LHsExpr a))
447 , ToHie (LHsExpr a)
448 , ToHie (Located (PatSynBind a a))
449 , HasType (LHsBind a)
450 , ModifyState (IdP a)
451 , Data (HsBind a)
452 ) => ToHie (BindContext (LHsBind a)) where
453 toHie (BC context scope b@(L span bind)) =
454 concatM $ getTypeNode b : case bind of
455 FunBind{fun_id = name, fun_matches = matches} ->
456 [ toHie $ C (ValBind context scope $ getRealSpan span) name
457 , toHie matches
458 ]
459 PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
460 [ toHie $ PS (getRealSpan span) scope NoScope lhs
461 , toHie rhs
462 ]
463 VarBind{var_rhs = expr} ->
464 [ toHie expr
465 ]
466 AbsBinds{abs_exports = xs, abs_binds = binds} ->
467 [ local (modifyState xs) $ -- Note [Name Remapping]
468 toHie $ fmap (BC context scope) binds
469 ]
470 PatSynBind _ psb ->
471 [ toHie $ L span psb -- PatSynBinds only occur at the top level
472 ]
473 XHsBindsLR _ -> []
474
475 instance ( ToHie (LMatch a body)
476 ) => ToHie (MatchGroup a body) where
477 toHie mg = concatM $ case mg of
478 MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
479 [ pure $ locOnly span
480 , toHie alts
481 ]
482 MG{} -> []
483 XMatchGroup _ -> []
484
485 instance ( ToHie (Context (Located (IdP a)))
486 , ToHie (PScoped (LPat a))
487 , ToHie (HsPatSynDir a)
488 ) => ToHie (Located (PatSynBind a a)) where
489 toHie (L sp psb) = concatM $ case psb of
490 PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
491 [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
492 , toHie $ toBind dets
493 , toHie $ PS Nothing lhsScope NoScope pat
494 , toHie dir
495 ]
496 where
497 lhsScope = combineScopes varScope detScope
498 varScope = mkLScope var
499 detScope = case dets of
500 (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
501 (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
502 (RecCon r) -> foldr go NoScope r
503 go (RecordPatSynField a b) c = combineScopes c
504 $ combineScopes (mkLScope a) (mkLScope b)
505 detSpan = case detScope of
506 LocalScope a -> Just a
507 _ -> Nothing
508 toBind (PrefixCon args) = PrefixCon $ map (C Use) args
509 toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
510 toBind (RecCon r) = RecCon $ map (PSC detSpan) r
511 XPatSynBind _ -> []
512
513 instance ( ToHie (MatchGroup a (LHsExpr a))
514 ) => ToHie (HsPatSynDir a) where
515 toHie dir = case dir of
516 ExplicitBidirectional mg -> toHie mg
517 _ -> pure []
518
519 instance ( a ~ GhcPass p
520 , ToHie body
521 , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
522 , ToHie (PScoped (LPat a))
523 , ToHie (GRHSs a body)
524 , Data (Match a body)
525 ) => ToHie (LMatch (GhcPass p) body) where
526 toHie (L span m ) = concatM $ makeNode m span : case m of
527 Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
528 [ toHie mctx
529 , let rhsScope = mkScope $ grhss_span grhss
530 in toHie $ patScopes Nothing rhsScope NoScope pats
531 , toHie grhss
532 ]
533 XMatch _ -> []
534
535 instance ( ToHie (Context (Located a))
536 ) => ToHie (HsMatchContext a) where
537 toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
538 toHie (StmtCtxt a) = toHie a
539 toHie _ = pure []
540
541 instance ( ToHie (HsMatchContext a)
542 ) => ToHie (HsStmtContext a) where
543 toHie (PatGuard a) = toHie a
544 toHie (ParStmtCtxt a) = toHie a
545 toHie (TransStmtCtxt a) = toHie a
546 toHie _ = pure []
547
548 instance ( a ~ GhcPass p
549 , ToHie (Context (Located (IdP a)))
550 , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
551 , ToHie (LHsExpr a)
552 , ToHie (TScoped (LHsSigWcType a))
553 , ProtectSig a
554 , ToHie (TScoped (ProtectedSig a))
555 , HasType (LPat a)
556 , Data (HsSplice a)
557 ) => ToHie (PScoped (LPat (GhcPass p))) where
558 toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
559 concatM $ getTypeNode lpat : case opat of
560 WildPat _ ->
561 []
562 VarPat _ lname ->
563 [ toHie $ C (PatternBind scope pscope rsp) lname
564 ]
565 LazyPat _ p ->
566 [ toHie $ PS rsp scope pscope p
567 ]
568 AsPat _ lname pat ->
569 [ toHie $ C (PatternBind scope
570 (combineScopes (mkLScope (dL pat)) pscope)
571 rsp)
572 lname
573 , toHie $ PS rsp scope pscope pat
574 ]
575 ParPat _ pat ->
576 [ toHie $ PS rsp scope pscope pat
577 ]
578 BangPat _ pat ->
579 [ toHie $ PS rsp scope pscope pat
580 ]
581 ListPat _ pats ->
582 [ toHie $ patScopes rsp scope pscope pats
583 ]
584 TuplePat _ pats _ ->
585 [ toHie $ patScopes rsp scope pscope pats
586 ]
587 SumPat _ pat _ _ ->
588 [ toHie $ PS rsp scope pscope pat
589 ]
590 ConPatIn c dets ->
591 [ toHie $ C Use c
592 , toHie $ contextify dets
593 ]
594 ConPatOut {pat_con = con, pat_args = dets}->
595 [ toHie $ C Use $ fmap conLikeName con
596 , toHie $ contextify dets
597 ]
598 ViewPat _ expr pat ->
599 [ toHie expr
600 , toHie $ PS rsp scope pscope pat
601 ]
602 SplicePat _ sp ->
603 [ toHie $ L ospan sp
604 ]
605 LitPat _ _ ->
606 []
607 NPat _ _ _ _ ->
608 []
609 NPlusKPat _ n _ _ _ _ ->
610 [ toHie $ C (PatternBind scope pscope rsp) n
611 ]
612 SigPat _ pat sig ->
613 [ toHie $ PS rsp scope pscope pat
614 , let cscope = mkLScope (dL pat) in
615 toHie $ TS (ResolvedScopes [cscope, scope, pscope])
616 (protectSig @a cscope sig)
617 -- See Note [Scoping Rules for SigPat]
618 ]
619 CoPat _ _ _ _ ->
620 []
621 XPat _ -> []
622 where
623 contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
624 contextify (InfixCon a b) = InfixCon a' b'
625 where [a', b'] = patScopes rsp scope pscope [a,b]
626 contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
627 contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
628 where
629 go (RS fscope (L spn (HsRecField lbl pat pun))) =
630 L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
631 scoped_fds = listScopes pscope fds
632
633 instance ( ToHie body
634 , ToHie (LGRHS a body)
635 , ToHie (RScoped (LHsLocalBinds a))
636 ) => ToHie (GRHSs a body) where
637 toHie grhs = concatM $ case grhs of
638 GRHSs _ grhss binds ->
639 [ toHie grhss
640 , toHie $ RS (mkScope $ grhss_span grhs) binds
641 ]
642 XGRHSs _ -> []
643
644 instance ( ToHie (Located body)
645 , ToHie (RScoped (GuardLStmt a))
646 , Data (GRHS a (Located body))
647 ) => ToHie (LGRHS a (Located body)) where
648 toHie (L span g) = concatM $ makeNode g span : case g of
649 GRHS _ guards body ->
650 [ toHie $ listScopes (mkLScope body) guards
651 , toHie body
652 ]
653 XGRHS _ -> []
654
655 instance ( a ~ GhcPass p
656 , ToHie (Context (Located (IdP a)))
657 , HasType (LHsExpr a)
658 , ToHie (PScoped (LPat a))
659 , ToHie (MatchGroup a (LHsExpr a))
660 , ToHie (LGRHS a (LHsExpr a))
661 , ToHie (RContext (HsRecordBinds a))
662 , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
663 , ToHie (ArithSeqInfo a)
664 , ToHie (LHsCmdTop a)
665 , ToHie (RScoped (GuardLStmt a))
666 , ToHie (RScoped (LHsLocalBinds a))
667 , ToHie (TScoped (LHsWcType (NoGhcTc a)))
668 , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
669 , Data (HsExpr a)
670 , Data (HsSplice a)
671 , Data (HsTupArg a)
672 , Data (AmbiguousFieldOcc a)
673 ) => ToHie (LHsExpr (GhcPass p)) where
674 toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
675 HsVar _ (L _ var) ->
676 [ toHie $ C Use (L mspan var)
677 -- Patch up var location since typechecker removes it
678 ]
679 HsUnboundVar _ _ ->
680 []
681 HsConLikeOut _ con ->
682 [ toHie $ C Use $ L mspan $ conLikeName con
683 ]
684 HsRecFld _ fld ->
685 [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
686 ]
687 HsOverLabel _ _ _ -> []
688 HsIPVar _ _ -> []
689 HsOverLit _ _ -> []
690 HsLit _ _ -> []
691 HsLam _ mg ->
692 [ toHie mg
693 ]
694 HsLamCase _ mg ->
695 [ toHie mg
696 ]
697 HsApp _ a b ->
698 [ toHie a
699 , toHie b
700 ]
701 HsAppType _ expr sig ->
702 [ toHie expr
703 , toHie $ TS (ResolvedScopes []) sig
704 ]
705 OpApp _ a b c ->
706 [ toHie a
707 , toHie b
708 , toHie c
709 ]
710 NegApp _ a _ ->
711 [ toHie a
712 ]
713 HsPar _ a ->
714 [ toHie a
715 ]
716 SectionL _ a b ->
717 [ toHie a
718 , toHie b
719 ]
720 SectionR _ a b ->
721 [ toHie a
722 , toHie b
723 ]
724 ExplicitTuple _ args _ ->
725 [ toHie args
726 ]
727 ExplicitSum _ _ _ expr ->
728 [ toHie expr
729 ]
730 HsCase _ expr matches ->
731 [ toHie expr
732 , toHie matches
733 ]
734 HsIf _ _ a b c ->
735 [ toHie a
736 , toHie b
737 , toHie c
738 ]
739 HsMultiIf _ grhss ->
740 [ toHie grhss
741 ]
742 HsLet _ binds expr ->
743 [ toHie $ RS (mkLScope expr) binds
744 , toHie expr
745 ]
746 HsDo _ _ (L ispan stmts) ->
747 [ pure $ locOnly ispan
748 , toHie $ listScopes NoScope stmts
749 ]
750 ExplicitList _ _ exprs ->
751 [ toHie exprs
752 ]
753 RecordCon {rcon_con_name = name, rcon_flds = binds}->
754 [ toHie $ C Use name
755 , toHie $ RC RecFieldAssign $ binds
756 ]
757 RecordUpd {rupd_expr = expr, rupd_flds = upds}->
758 [ toHie expr
759 , toHie $ map (RC RecFieldAssign) upds
760 ]
761 ExprWithTySig _ expr sig ->
762 [ toHie expr
763 , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
764 ]
765 ArithSeq _ _ info ->
766 [ toHie info
767 ]
768 HsSCC _ _ _ expr ->
769 [ toHie expr
770 ]
771 HsCoreAnn _ _ _ expr ->
772 [ toHie expr
773 ]
774 HsProc _ pat cmdtop ->
775 [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
776 , toHie cmdtop
777 ]
778 HsStatic _ expr ->
779 [ toHie expr
780 ]
781 HsArrApp _ a b _ _ ->
782 [ toHie a
783 , toHie b
784 ]
785 HsArrForm _ expr _ cmds ->
786 [ toHie expr
787 , toHie cmds
788 ]
789 HsTick _ _ expr ->
790 [ toHie expr
791 ]
792 HsBinTick _ _ _ expr ->
793 [ toHie expr
794 ]
795 HsTickPragma _ _ _ _ expr ->
796 [ toHie expr
797 ]
798 HsWrap _ _ a ->
799 [ toHie $ L mspan a
800 ]
801 HsBracket _ b ->
802 [ toHie b
803 ]
804 HsRnBracketOut _ b p ->
805 [ toHie b
806 , toHie p
807 ]
808 HsTcBracketOut _ b p ->
809 [ toHie b
810 , toHie p
811 ]
812 HsSpliceE _ x ->
813 [ toHie $ L mspan x
814 ]
815 EWildPat _ -> []
816 EAsPat _ a b ->
817 [ toHie $ C Use a
818 , toHie b
819 ]
820 EViewPat _ a b ->
821 [ toHie a
822 , toHie b
823 ]
824 ELazyPat _ a ->
825 [ toHie a
826 ]
827 XExpr _ -> []
828
829 instance ( a ~ GhcPass p
830 , ToHie (LHsExpr a)
831 , Data (HsTupArg a)
832 ) => ToHie (LHsTupArg (GhcPass p)) where
833 toHie (L span arg) = concatM $ makeNode arg span : case arg of
834 Present _ expr ->
835 [ toHie expr
836 ]
837 Missing _ -> []
838 XTupArg _ -> []
839
840 instance ( a ~ GhcPass p
841 , ToHie (PScoped (LPat a))
842 , ToHie (LHsExpr a)
843 , ToHie (SigContext (LSig a))
844 , ToHie (RScoped (LHsLocalBinds a))
845 , ToHie (RScoped (ApplicativeArg a))
846 , ToHie (Located body)
847 , Data (StmtLR a a (Located body))
848 , Data (StmtLR a a (Located (HsExpr a)))
849 ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
850 toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
851 LastStmt _ body _ _ ->
852 [ toHie body
853 ]
854 BindStmt _ pat body _ _ ->
855 [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
856 , toHie body
857 ]
858 ApplicativeStmt _ stmts _ ->
859 [ concatMapM (toHie . RS scope . snd) stmts
860 ]
861 BodyStmt _ body _ _ ->
862 [ toHie body
863 ]
864 LetStmt _ binds ->
865 [ toHie $ RS scope binds
866 ]
867 ParStmt _ parstmts _ _ ->
868 [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
869 toHie $ listScopes NoScope stmts)
870 parstmts
871 ]
872 TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
873 [ toHie $ listScopes scope stmts
874 , toHie using
875 , toHie by
876 ]
877 RecStmt {recS_stmts = stmts} ->
878 [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
879 ]
880 XStmtLR _ -> []
881
882 instance ( ToHie (LHsExpr a)
883 , ToHie (PScoped (LPat a))
884 , ToHie (BindContext (LHsBind a))
885 , ToHie (SigContext (LSig a))
886 , ToHie (RScoped (HsValBindsLR a a))
887 , Data (HsLocalBinds a)
888 ) => ToHie (RScoped (LHsLocalBinds a)) where
889 toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
890 EmptyLocalBinds _ -> []
891 HsIPBinds _ _ -> []
892 HsValBinds _ valBinds ->
893 [ toHie $ RS (combineScopes scope $ mkScope sp)
894 valBinds
895 ]
896 XHsLocalBindsLR _ -> []
897
898 instance ( ToHie (BindContext (LHsBind a))
899 , ToHie (SigContext (LSig a))
900 , ToHie (RScoped (XXValBindsLR a a))
901 ) => ToHie (RScoped (HsValBindsLR a a)) where
902 toHie (RS sc v) = concatM $ case v of
903 ValBinds _ binds sigs ->
904 [ toHie $ fmap (BC RegularBind sc) binds
905 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
906 ]
907 XValBindsLR x -> [ toHie $ RS sc x ]
908
909 instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
910 toHie (RS sc (NValBinds binds sigs)) = concatM $
911 [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
912 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
913 ]
914 instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
915 toHie (RS sc (NValBinds binds sigs)) = concatM $
916 [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
917 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
918 ]
919
920 instance ( ToHie (RContext (LHsRecField a arg))
921 ) => ToHie (RContext (HsRecFields a arg)) where
922 toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
923
924 instance ( ToHie (RFContext (Located label))
925 , ToHie arg
926 , HasLoc arg
927 , Data label
928 , Data arg
929 ) => ToHie (RContext (LHsRecField' label arg)) where
930 toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
931 HsRecField label expr _ ->
932 [ toHie $ RFC c (getRealSpan $ loc expr) label
933 , toHie expr
934 ]
935
936 removeDefSrcSpan :: Name -> Name
937 removeDefSrcSpan n = setNameLoc n noSrcSpan
938
939 instance ToHie (RFContext (LFieldOcc GhcRn)) where
940 toHie (RFC c rhs (L nspan f)) = concatM $ case f of
941 FieldOcc name _ ->
942 [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
943 ]
944 XFieldOcc _ -> []
945
946 instance ToHie (RFContext (LFieldOcc GhcTc)) where
947 toHie (RFC c rhs (L nspan f)) = concatM $ case f of
948 FieldOcc var _ ->
949 let var' = setVarName var (removeDefSrcSpan $ varName var)
950 in [ toHie $ C (RecField c rhs) (L nspan var')
951 ]
952 XFieldOcc _ -> []
953
954 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
955 toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
956 Unambiguous name _ ->
957 [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
958 ]
959 Ambiguous _name _ ->
960 [ ]
961 XAmbiguousFieldOcc _ -> []
962
963 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
964 toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
965 Unambiguous var _ ->
966 let var' = setVarName var (removeDefSrcSpan $ varName var)
967 in [ toHie $ C (RecField c rhs) (L nspan var')
968 ]
969 Ambiguous var _ ->
970 let var' = setVarName var (removeDefSrcSpan $ varName var)
971 in [ toHie $ C (RecField c rhs) (L nspan var')
972 ]
973 XAmbiguousFieldOcc _ -> []
974
975 instance ( a ~ GhcPass p
976 , ToHie (PScoped (LPat a))
977 , ToHie (BindContext (LHsBind a))
978 , ToHie (LHsExpr a)
979 , ToHie (SigContext (LSig a))
980 , ToHie (RScoped (HsValBindsLR a a))
981 , Data (StmtLR a a (Located (HsExpr a)))
982 , Data (HsLocalBinds a)
983 ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
984 toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
985 [ toHie $ PS Nothing sc NoScope pat
986 , toHie expr
987 ]
988 toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
989 [ toHie $ listScopes NoScope stmts
990 , toHie $ PS Nothing sc NoScope pat
991 ]
992 toHie (RS _ (XApplicativeArg _)) = pure []
993
994 instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
995 toHie (PrefixCon args) = toHie args
996 toHie (RecCon rec) = toHie rec
997 toHie (InfixCon a b) = concatM [ toHie a, toHie b]
998
999 instance ( ToHie (LHsCmd a)
1000 , Data (HsCmdTop a)
1001 ) => ToHie (LHsCmdTop a) where
1002 toHie (L span top) = concatM $ makeNode top span : case top of
1003 HsCmdTop _ cmd ->
1004 [ toHie cmd
1005 ]
1006 XCmdTop _ -> []
1007
1008 instance ( a ~ GhcPass p
1009 , ToHie (PScoped (LPat a))
1010 , ToHie (BindContext (LHsBind a))
1011 , ToHie (LHsExpr a)
1012 , ToHie (MatchGroup a (LHsCmd a))
1013 , ToHie (SigContext (LSig a))
1014 , ToHie (RScoped (HsValBindsLR a a))
1015 , Data (HsCmd a)
1016 , Data (HsCmdTop a)
1017 , Data (StmtLR a a (Located (HsCmd a)))
1018 , Data (HsLocalBinds a)
1019 , Data (StmtLR a a (Located (HsExpr a)))
1020 ) => ToHie (LHsCmd (GhcPass p)) where
1021 toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
1022 HsCmdArrApp _ a b _ _ ->
1023 [ toHie a
1024 , toHie b
1025 ]
1026 HsCmdArrForm _ a _ _ cmdtops ->
1027 [ toHie a
1028 , toHie cmdtops
1029 ]
1030 HsCmdApp _ a b ->
1031 [ toHie a
1032 , toHie b
1033 ]
1034 HsCmdLam _ mg ->
1035 [ toHie mg
1036 ]
1037 HsCmdPar _ a ->
1038 [ toHie a
1039 ]
1040 HsCmdCase _ expr alts ->
1041 [ toHie expr
1042 , toHie alts
1043 ]
1044 HsCmdIf _ _ a b c ->
1045 [ toHie a
1046 , toHie b
1047 , toHie c
1048 ]
1049 HsCmdLet _ binds cmd' ->
1050 [ toHie $ RS (mkLScope cmd') binds
1051 , toHie cmd'
1052 ]
1053 HsCmdDo _ (L ispan stmts) ->
1054 [ pure $ locOnly ispan
1055 , toHie $ listScopes NoScope stmts
1056 ]
1057 HsCmdWrap _ _ _ -> []
1058 XCmd _ -> []
1059
1060 instance ToHie (TyClGroup GhcRn) where
1061 toHie (TyClGroup _ classes roles instances) = concatM
1062 [ toHie classes
1063 , toHie roles
1064 , toHie instances
1065 ]
1066 toHie (XTyClGroup _) = pure []
1067
1068 instance ToHie (LTyClDecl GhcRn) where
1069 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1070 FamDecl {tcdFam = fdecl} ->
1071 [ toHie (L span fdecl)
1072 ]
1073 SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1074 [ toHie $ C (Decl SynDec $ getRealSpan span) name
1075 , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
1076 , toHie typ
1077 ]
1078 DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1079 [ toHie $ C (Decl DataDec $ getRealSpan span) name
1080 , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1081 , toHie defn
1082 ]
1083 where
1084 quant_scope = mkLScope $ dd_ctxt defn
1085 rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1086 sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
1087 con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
1088 deriv_sc = mkLScope $ dd_derivs defn
1089 ClassDecl { tcdCtxt = context
1090 , tcdLName = name
1091 , tcdTyVars = vars
1092 , tcdFDs = deps
1093 , tcdSigs = sigs
1094 , tcdMeths = meths
1095 , tcdATs = typs
1096 , tcdATDefs = deftyps
1097 } ->
1098 [ toHie $ C (Decl ClassDec $ getRealSpan span) name
1099 , toHie context
1100 , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1101 , toHie deps
1102 , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
1103 , toHie $ fmap (BC InstanceBind ModuleScope) meths
1104 , toHie typs
1105 , concatMapM (pure . locOnly . getLoc) deftyps
1106 , toHie $ map (go . unLoc) deftyps
1107 ]
1108 where
1109 context_scope = mkLScope context
1110 rhs_scope = foldl1' combineScopes $ map mkScope
1111 [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1112
1113 go :: TyFamDefltEqn GhcRn
1114 -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
1115 go (FamEqn a var bndrs pat b rhs) =
1116 FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
1117 go (XFamEqn NoExt) = XFamEqn NoExt
1118 XTyClDecl _ -> []
1119
1120 instance ToHie (LFamilyDecl GhcRn) where
1121 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1122 FamilyDecl _ info name vars _ sig inj ->
1123 [ toHie $ C (Decl FamDec $ getRealSpan span) name
1124 , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1125 , toHie info
1126 , toHie $ RS injSpan sig
1127 , toHie inj
1128 ]
1129 where
1130 rhsSpan = sigSpan `combineScopes` injSpan
1131 sigSpan = mkScope $ getLoc sig
1132 injSpan = maybe NoScope (mkScope . getLoc) inj
1133 XFamilyDecl _ -> []
1134
1135 instance ToHie (FamilyInfo GhcRn) where
1136 toHie (ClosedTypeFamily (Just eqns)) = concatM $
1137 [ concatMapM (pure . locOnly . getLoc) eqns
1138 , toHie $ map go eqns
1139 ]
1140 where
1141 go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
1142 toHie _ = pure []
1143
1144 instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
1145 toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
1146 NoSig _ ->
1147 []
1148 KindSig _ k ->
1149 [ toHie k
1150 ]
1151 TyVarSig _ bndr ->
1152 [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1153 ]
1154 XFamilyResultSig _ -> []
1155
1156 instance ToHie (Located (FunDep (Located Name))) where
1157 toHie (L span fd@(lhs, rhs)) = concatM $
1158 [ makeNode fd span
1159 , toHie $ map (C Use) lhs
1160 , toHie $ map (C Use) rhs
1161 ]
1162
1163 instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
1164 => ToHie (TScoped (FamEqn GhcRn pats rhs)) where
1165 toHie (TS _ f) = toHie f
1166
1167 instance ( ToHie pats
1168 , ToHie rhs
1169 , HasLoc pats
1170 , HasLoc rhs
1171 ) => ToHie (FamEqn GhcRn pats rhs) where
1172 toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
1173 [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1174 , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1175 , toHie pats
1176 , toHie rhs
1177 ]
1178 where scope = combineScopes patsScope rhsScope
1179 patsScope = mkScope (loc pats)
1180 rhsScope = mkScope (loc rhs)
1181 toHie (XFamEqn _) = pure []
1182
1183 instance ToHie (LInjectivityAnn GhcRn) where
1184 toHie (L span ann) = concatM $ makeNode ann span : case ann of
1185 InjectivityAnn lhs rhs ->
1186 [ toHie $ C Use lhs
1187 , toHie $ map (C Use) rhs
1188 ]
1189
1190 instance ToHie (HsDataDefn GhcRn) where
1191 toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1192 [ toHie ctx
1193 , toHie mkind
1194 , toHie cons
1195 , toHie derivs
1196 ]
1197 toHie (XHsDataDefn _) = pure []
1198
1199 instance ToHie (HsDeriving GhcRn) where
1200 toHie (L span clauses) = concatM
1201 [ pure $ locOnly span
1202 , toHie clauses
1203 ]
1204
1205 instance ToHie (LHsDerivingClause GhcRn) where
1206 toHie (L span cl) = concatM $ makeNode cl span : case cl of
1207 HsDerivingClause _ strat (L ispan tys) ->
1208 [ toHie strat
1209 , pure $ locOnly ispan
1210 , toHie $ map (TS (ResolvedScopes [])) tys
1211 ]
1212 XHsDerivingClause _ -> []
1213
1214 instance ToHie (Located (DerivStrategy GhcRn)) where
1215 toHie (L span strat) = concatM $ makeNode strat span : case strat of
1216 StockStrategy -> []
1217 AnyclassStrategy -> []
1218 NewtypeStrategy -> []
1219 ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
1220
1221 instance ToHie (Located OverlapMode) where
1222 toHie (L span _) = pure $ locOnly span
1223
1224 instance ToHie (LConDecl GhcRn) where
1225 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1226 ConDeclGADT { con_names = names, con_qvars = qvars
1227 , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
1228 [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
1229 , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
1230 , toHie ctx
1231 , toHie args
1232 , toHie typ
1233 ]
1234 where
1235 rhsScope = combineScopes argsScope tyScope
1236 ctxScope = maybe NoScope mkLScope ctx
1237 argsScope = condecl_scope args
1238 tyScope = mkLScope typ
1239 ConDeclH98 { con_name = name, con_ex_tvs = qvars
1240 , con_mb_cxt = ctx, con_args = dets } ->
1241 [ toHie $ C (Decl ConDec $ getRealSpan span) name
1242 , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1243 , toHie ctx
1244 , toHie dets
1245 ]
1246 where
1247 rhsScope = combineScopes ctxScope argsScope
1248 ctxScope = maybe NoScope mkLScope ctx
1249 argsScope = condecl_scope dets
1250 XConDecl _ -> []
1251 where condecl_scope args = case args of
1252 PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
1253 InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
1254 RecCon x -> mkLScope x
1255
1256 instance ToHie (Located [LConDeclField GhcRn]) where
1257 toHie (L span decls) = concatM $
1258 [ pure $ locOnly span
1259 , toHie decls
1260 ]
1261
1262 instance ( HasLoc thing
1263 , ToHie (TScoped thing)
1264 ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
1265 toHie (TS sc (HsIB ibrn a)) = concatM $
1266 [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
1267 , toHie $ TS sc a
1268 ]
1269 where span = loc a
1270 toHie (TS _ (XHsImplicitBndrs _)) = pure []
1271
1272 instance ( HasLoc thing
1273 , ToHie (TScoped thing)
1274 ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
1275 toHie (TS sc (HsWC names a)) = concatM $
1276 [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1277 , toHie $ TS sc a
1278 ]
1279 where span = loc a
1280 toHie (TS _ (XHsWildCardBndrs _)) = pure []
1281
1282 instance ToHie (SigContext (LSig GhcRn)) where
1283 toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
1284 TypeSig _ names typ ->
1285 [ toHie $ map (C TyDecl) names
1286 , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1287 ]
1288 PatSynSig _ names typ ->
1289 [ toHie $ map (C TyDecl) names
1290 , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1291 ]
1292 ClassOpSig _ _ names typ ->
1293 [ case styp of
1294 ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
1295 _ -> toHie $ map (C $ TyDecl) names
1296 , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1297 ]
1298 IdSig _ _ -> []
1299 FixSig _ fsig ->
1300 [ toHie $ L sp fsig
1301 ]
1302 InlineSig _ name _ ->
1303 [ toHie $ (C Use) name
1304 ]
1305 SpecSig _ name typs _ ->
1306 [ toHie $ (C Use) name
1307 , toHie $ map (TS (ResolvedScopes [])) typs
1308 ]
1309 SpecInstSig _ _ typ ->
1310 [ toHie $ TS (ResolvedScopes []) typ
1311 ]
1312 MinimalSig _ _ form ->
1313 [ toHie form
1314 ]
1315 SCCFunSig _ _ name mtxt ->
1316 [ toHie $ (C Use) name
1317 , pure $ maybe [] (locOnly . getLoc) mtxt
1318 ]
1319 CompleteMatchSig _ _ (L ispan names) typ ->
1320 [ pure $ locOnly ispan
1321 , toHie $ map (C Use) names
1322 , toHie $ fmap (C Use) typ
1323 ]
1324 XSig _ -> []
1325
1326 instance ToHie (LHsType GhcRn) where
1327 toHie x = toHie $ TS (ResolvedScopes []) x
1328
1329 instance ToHie (TScoped (LHsType GhcRn)) where
1330 toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
1331 HsForAllTy _ bndrs body ->
1332 [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
1333 , toHie body
1334 ]
1335 HsQualTy _ ctx body ->
1336 [ toHie ctx
1337 , toHie body
1338 ]
1339 HsTyVar _ _ var ->
1340 [ toHie $ C Use var
1341 ]
1342 HsAppTy _ a b ->
1343 [ toHie a
1344 , toHie b
1345 ]
1346 HsAppKindTy _ ty ki ->
1347 [ toHie ty
1348 , toHie $ TS (ResolvedScopes []) ki
1349 ]
1350 HsFunTy _ a b ->
1351 [ toHie a
1352 , toHie b
1353 ]
1354 HsListTy _ a ->
1355 [ toHie a
1356 ]
1357 HsTupleTy _ _ tys ->
1358 [ toHie tys
1359 ]
1360 HsSumTy _ tys ->
1361 [ toHie tys
1362 ]
1363 HsOpTy _ a op b ->
1364 [ toHie a
1365 , toHie $ C Use op
1366 , toHie b
1367 ]
1368 HsParTy _ a ->
1369 [ toHie a
1370 ]
1371 HsIParamTy _ ip ty ->
1372 [ toHie ip
1373 , toHie ty
1374 ]
1375 HsKindSig _ a b ->
1376 [ toHie a
1377 , toHie b
1378 ]
1379 HsSpliceTy _ a ->
1380 [ toHie $ L span a
1381 ]
1382 HsDocTy _ a _ ->
1383 [ toHie a
1384 ]
1385 HsBangTy _ _ ty ->
1386 [ toHie ty
1387 ]
1388 HsRecTy _ fields ->
1389 [ toHie fields
1390 ]
1391 HsExplicitListTy _ _ tys ->
1392 [ toHie tys
1393 ]
1394 HsExplicitTupleTy _ tys ->
1395 [ toHie tys
1396 ]
1397 HsTyLit _ _ -> []
1398 HsWildCardTy _ -> []
1399 HsStarTy _ _ -> []
1400 XHsType _ -> []
1401
1402 instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1403 toHie (HsValArg tm) = toHie tm
1404 toHie (HsTypeArg ty) = toHie ty
1405 toHie (HsArgPar sp) = pure $ locOnly sp
1406
1407 instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
1408 toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1409 UserTyVar _ var ->
1410 [ toHie $ C (TyVarBind sc tsc) var
1411 ]
1412 KindedTyVar _ var kind ->
1413 [ toHie $ C (TyVarBind sc tsc) var
1414 , toHie kind
1415 ]
1416 XTyVarBndr _ -> []
1417
1418 instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1419 toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $
1420 [ pure $ bindingsOnly bindings
1421 , toHie $ tvScopes sc NoScope vars
1422 ]
1423 where
1424 varLoc = loc vars
1425 bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1426 toHie (TS _ (XLHsQTyVars _)) = pure []
1427
1428 instance ToHie (LHsContext GhcRn) where
1429 toHie (L span tys) = concatM $
1430 [ pure $ locOnly span
1431 , toHie tys
1432 ]
1433
1434 instance ToHie (LConDeclField GhcRn) where
1435 toHie (L span field) = concatM $ makeNode field span : case field of
1436 ConDeclField _ fields typ _ ->
1437 [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1438 , toHie typ
1439 ]
1440 XConDeclField _ -> []
1441
1442 instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1443 toHie (From expr) = toHie expr
1444 toHie (FromThen a b) = concatM $
1445 [ toHie a
1446 , toHie b
1447 ]
1448 toHie (FromTo a b) = concatM $
1449 [ toHie a
1450 , toHie b
1451 ]
1452 toHie (FromThenTo a b c) = concatM $
1453 [ toHie a
1454 , toHie b
1455 , toHie c
1456 ]
1457
1458 instance ToHie (LSpliceDecl GhcRn) where
1459 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1460 SpliceDecl _ splice _ ->
1461 [ toHie splice
1462 ]
1463 XSpliceDecl _ -> []
1464
1465 instance ToHie (HsBracket a) where
1466 toHie _ = pure []
1467
1468 instance ToHie PendingRnSplice where
1469 toHie _ = pure []
1470
1471 instance ToHie PendingTcSplice where
1472 toHie _ = pure []
1473
1474 instance ToHie (LBooleanFormula (Located Name)) where
1475 toHie (L span form) = concatM $ makeNode form span : case form of
1476 Var a ->
1477 [ toHie $ C Use a
1478 ]
1479 And forms ->
1480 [ toHie forms
1481 ]
1482 Or forms ->
1483 [ toHie forms
1484 ]
1485 Parens f ->
1486 [ toHie f
1487 ]
1488
1489 instance ToHie (Located HsIPName) where
1490 toHie (L span e) = makeNode e span
1491
1492 instance ( ToHie (LHsExpr a)
1493 , Data (HsSplice a)
1494 ) => ToHie (Located (HsSplice a)) where
1495 toHie (L span sp) = concatM $ makeNode sp span : case sp of
1496 HsTypedSplice _ _ _ expr ->
1497 [ toHie expr
1498 ]
1499 HsUntypedSplice _ _ _ expr ->
1500 [ toHie expr
1501 ]
1502 HsQuasiQuote _ _ _ ispan _ ->
1503 [ pure $ locOnly ispan
1504 ]
1505 HsSpliced _ _ _ ->
1506 []
1507 HsSplicedT _ ->
1508 []
1509 XSplice _ -> []
1510
1511 instance ToHie (LRoleAnnotDecl GhcRn) where
1512 toHie (L span annot) = concatM $ makeNode annot span : case annot of
1513 RoleAnnotDecl _ var roles ->
1514 [ toHie $ C Use var
1515 , concatMapM (pure . locOnly . getLoc) roles
1516 ]
1517 XRoleAnnotDecl _ -> []
1518
1519 instance ToHie (LInstDecl GhcRn) where
1520 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1521 ClsInstD _ d ->
1522 [ toHie $ L span d
1523 ]
1524 DataFamInstD _ d ->
1525 [ toHie $ L span d
1526 ]
1527 TyFamInstD _ d ->
1528 [ toHie $ L span d
1529 ]
1530 XInstDecl _ -> []
1531
1532 instance ToHie (LClsInstDecl GhcRn) where
1533 toHie (L span decl) = concatM
1534 [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
1535 , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1536 , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
1537 , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
1538 , toHie $ cid_tyfam_insts decl
1539 , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
1540 , toHie $ cid_datafam_insts decl
1541 , toHie $ cid_overlap_mode decl
1542 ]
1543
1544 instance ToHie (LDataFamInstDecl GhcRn) where
1545 toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1546
1547 instance ToHie (LTyFamInstDecl GhcRn) where
1548 toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1549
1550 instance ToHie (Context a)
1551 => ToHie (PatSynFieldContext (RecordPatSynField a)) where
1552 toHie (PSC sp (RecordPatSynField a b)) = concatM $
1553 [ toHie $ C (RecField RecFieldDecl sp) a
1554 , toHie $ C Use b
1555 ]
1556
1557 instance ToHie (LDerivDecl GhcRn) where
1558 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1559 DerivDecl _ typ strat overlap ->
1560 [ toHie $ TS (ResolvedScopes []) typ
1561 , toHie strat
1562 , toHie overlap
1563 ]
1564 XDerivDecl _ -> []
1565
1566 instance ToHie (LFixitySig GhcRn) where
1567 toHie (L span sig) = concatM $ makeNode sig span : case sig of
1568 FixitySig _ vars _ ->
1569 [ toHie $ map (C Use) vars
1570 ]
1571 XFixitySig _ -> []
1572
1573 instance ToHie (LDefaultDecl GhcRn) where
1574 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1575 DefaultDecl _ typs ->
1576 [ toHie typs
1577 ]
1578 XDefaultDecl _ -> []
1579
1580 instance ToHie (LForeignDecl GhcRn) where
1581 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1582 ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1583 [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
1584 , toHie $ TS (ResolvedScopes []) sig
1585 , toHie fi
1586 ]
1587 ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1588 [ toHie $ C Use name
1589 , toHie $ TS (ResolvedScopes []) sig
1590 , toHie fe
1591 ]
1592 XForeignDecl _ -> []
1593
1594 instance ToHie ForeignImport where
1595 toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
1596 [ locOnly a
1597 , locOnly b
1598 , locOnly c
1599 ]
1600
1601 instance ToHie ForeignExport where
1602 toHie (CExport (L a _) (L b _)) = pure $ concat $
1603 [ locOnly a
1604 , locOnly b
1605 ]
1606
1607 instance ToHie (LWarnDecls GhcRn) where
1608 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1609 Warnings _ _ warnings ->
1610 [ toHie warnings
1611 ]
1612 XWarnDecls _ -> []
1613
1614 instance ToHie (LWarnDecl GhcRn) where
1615 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1616 Warning _ vars _ ->
1617 [ toHie $ map (C Use) vars
1618 ]
1619 XWarnDecl _ -> []
1620
1621 instance ToHie (LAnnDecl GhcRn) where
1622 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1623 HsAnnotation _ _ prov expr ->
1624 [ toHie prov
1625 , toHie expr
1626 ]
1627 XAnnDecl _ -> []
1628
1629 instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
1630 toHie (ValueAnnProvenance a) = toHie $ C Use a
1631 toHie (TypeAnnProvenance a) = toHie $ C Use a
1632 toHie ModuleAnnProvenance = pure []
1633
1634 instance ToHie (LRuleDecls GhcRn) where
1635 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1636 HsRules _ _ rules ->
1637 [ toHie rules
1638 ]
1639 XRuleDecls _ -> []
1640
1641 instance ToHie (LRuleDecl GhcRn) where
1642 toHie (L _ (XRuleDecl _)) = pure []
1643 toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
1644 [ makeNode r span
1645 , pure $ locOnly $ getLoc rname
1646 , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1647 , toHie $ map (RS $ mkScope span) bndrs
1648 , toHie exprA
1649 , toHie exprB
1650 ]
1651 where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
1652 bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
1653 exprA_sc = mkLScope exprA
1654 exprB_sc = mkLScope exprB
1655
1656 instance ToHie (RScoped (LRuleBndr GhcRn)) where
1657 toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1658 RuleBndr _ var ->
1659 [ toHie $ C (ValBind RegularBind sc Nothing) var
1660 ]
1661 RuleBndrSig _ var typ ->
1662 [ toHie $ C (ValBind RegularBind sc Nothing) var
1663 , toHie $ TS (ResolvedScopes [sc]) typ
1664 ]
1665 XRuleBndr _ -> []
1666
1667 instance ToHie (LImportDecl GhcRn) where
1668 toHie (L span decl) = concatM $ makeNode decl span : case decl of
1669 ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
1670 [ toHie $ IEC Import name
1671 , toHie $ fmap (IEC ImportAs) as
1672 , maybe (pure []) goIE hidden
1673 ]
1674 XImportDecl _ -> []
1675 where
1676 goIE (hiding, (L sp liens)) = concatM $
1677 [ pure $ locOnly sp
1678 , toHie $ map (IEC c) liens
1679 ]
1680 where
1681 c = if hiding then ImportHiding else Import
1682
1683 instance ToHie (IEContext (LIE GhcRn)) where
1684 toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
1685 IEVar _ n ->
1686 [ toHie $ IEC c n
1687 ]
1688 IEThingAbs _ n ->
1689 [ toHie $ IEC c n
1690 ]
1691 IEThingAll _ n ->
1692 [ toHie $ IEC c n
1693 ]
1694 IEThingWith _ n _ ns flds ->
1695 [ toHie $ IEC c n
1696 , toHie $ map (IEC c) ns
1697 , toHie $ map (IEC c) flds
1698 ]
1699 IEModuleContents _ n ->
1700 [ toHie $ IEC c n
1701 ]
1702 IEGroup _ _ _ -> []
1703 IEDoc _ _ -> []
1704 IEDocNamed _ _ -> []
1705 XIE _ -> []
1706
1707 instance ToHie (IEContext (LIEWrappedName Name)) where
1708 toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
1709 IEName n ->
1710 [ toHie $ C (IEThing c) n
1711 ]
1712 IEPattern p ->
1713 [ toHie $ C (IEThing c) p
1714 ]
1715 IEType n ->
1716 [ toHie $ C (IEThing c) n
1717 ]
1718
1719 instance ToHie (IEContext (Located (FieldLbl Name))) where
1720 toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
1721 FieldLabel _ _ n ->
1722 [ toHie $ C (IEThing c) $ L span n
1723 ]