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