never executed always true always false
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE CPP #-}
3 {-# LANGUAGE ConstraintKinds #-}
4 {-# LANGUAGE DataKinds #-}
5 {-# LANGUAGE DeriveDataTypeable #-}
6 {-# LANGUAGE FlexibleContexts #-}
7 {-# LANGUAGE FlexibleInstances #-}
8 {-# LANGUAGE GADTs #-}
9 {-# LANGUAGE OverloadedStrings #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE TypeApplications #-}
12 {-# LANGUAGE TypeFamilies #-}
13 {-# LANGUAGE UndecidableInstances #-}
14 {-# LANGUAGE UndecidableSuperClasses #-}
15
16 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
17
18 {-
19 Main functions for .hie file generation
20 -}
21
22 module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where
23
24 import GHC.Utils.Outputable(ppr)
25
26 import GHC.Prelude
27
28 import GHC.Types.Avail ( Avails )
29 import GHC.Data.Bag ( Bag, bagToList )
30 import GHC.Types.Basic
31 import GHC.Data.BooleanFormula
32 import GHC.Core.Class ( className, classSCSelIds )
33 import GHC.Core.ConLike ( conLikeName )
34 import GHC.Core.TyCon ( TyCon, tyConClass_maybe )
35 import GHC.Core.FVs
36 import GHC.Core.DataCon ( dataConNonlinearType )
37 import GHC.Types.FieldLabel
38 import GHC.Hs
39 import GHC.Hs.Syn.Type
40 import GHC.Utils.Monad ( concatMapM, MonadIO(liftIO) )
41 import GHC.Types.Id ( isDataConId_maybe )
42 import GHC.Types.Name ( Name, nameSrcSpan, nameUnique )
43 import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
44 import GHC.Types.SrcLoc
45 import GHC.Core.Type ( Type )
46 import GHC.Core.Predicate
47 import GHC.Core.InstEnv
48 import GHC.Tc.Types
49 import GHC.Tc.Types.Evidence
50 import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique )
51 import GHC.Types.Var.Env
52 import GHC.Builtin.Uniques
53 import GHC.Iface.Make ( mkIfaceExports )
54 import GHC.Utils.Panic
55 import GHC.Utils.Panic.Plain
56 import GHC.Utils.Misc
57 import GHC.Data.Maybe
58 import GHC.Data.FastString
59 import qualified GHC.Data.Strict as Strict
60
61 import GHC.Iface.Ext.Types
62 import GHC.Iface.Ext.Utils
63
64 import GHC.Unit.Module ( ModuleName, ml_hs_file )
65 import GHC.Unit.Module.ModSummary
66
67 import qualified Data.Array as A
68 import qualified Data.ByteString as BS
69 import qualified Data.Map as M
70 import qualified Data.Set as S
71 import Data.Data ( Data, Typeable )
72 import Data.Functor.Identity ( Identity(..) )
73 import Data.Void ( Void, absurd )
74 import Control.Monad ( forM_ )
75 import Control.Monad.Trans.State.Strict
76 import Control.Monad.Trans.Reader
77 import Control.Monad.Trans.Class ( lift )
78 import Control.Applicative ( (<|>) )
79
80 {- Note [Updating HieAst for changes in the GHC AST]
81
82 When updating the code in this file for changes in the GHC AST, you
83 need to pay attention to the following things:
84
85 1) Symbols (Names/Vars/Modules) in the following categories:
86
87 a) Symbols that appear in the source file that directly correspond to
88 something the user typed
89 b) Symbols that don't appear in the source, but should be in some sense
90 "visible" to a user, particularly via IDE tooling or the like. This
91 includes things like the names introduced by RecordWildcards (We record
92 all the names introduced by a (..) in HIE files), and will include implicit
93 parameters and evidence variables after one of my pending MRs lands.
94
95 2) Subtrees that may contain such symbols, or correspond to a SrcSpan in
96 the file. This includes all `Located` things
97
98 For 1), you need to call `toHie` for one of the following instances
99
100 instance ToHie (Context (Located Name)) where ...
101 instance ToHie (Context (Located Var)) where ...
102 instance ToHie (IEContext (Located ModuleName)) where ...
103
104 `Context` is a data type that looks like:
105
106 data Context a = C ContextInfo a -- Used for names and bindings
107
108 `ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like
109
110 data ContextInfo
111 = Use -- ^ regular variable
112 | MatchBind
113 | IEThing IEType -- ^ import/export
114 | TyDecl
115 -- | Value binding
116 | ValBind
117 BindType -- ^ whether or not the binding is in an instance
118 Scope -- ^ scope over which the value is bound
119 (Maybe Span) -- ^ span of entire binding
120 ...
121
122 It is used to annotate symbols in the .hie files with some extra information on
123 the context in which they occur and should be fairly self explanatory. You need
124 to select one that looks appropriate for the symbol usage. In very rare cases,
125 you might need to extend this sum type if none of the cases seem appropriate.
126
127 So, given a `Located Name` that is just being "used", and not defined at a
128 particular location, you would do the following:
129
130 toHie $ C Use located_name
131
132 If you select one that corresponds to a binding site, you will need to
133 provide a `Scope` and a `Span` for your binding. Both of these are basically
134 `SrcSpans`.
135
136 The `SrcSpan` in the `Scope` is supposed to span over the part of the source
137 where the symbol can be legally allowed to occur. For more details on how to
138 calculate this, see Note [Capturing Scopes and other non local information]
139 in GHC.Iface.Ext.Ast.
140
141 The binding `Span` is supposed to be the span of the entire binding for
142 the name.
143
144 For a function definition `foo`:
145
146 foo x = x + y
147 where y = x^2
148
149 The binding `Span` is the span of the entire function definition from `foo x`
150 to `x^2`. For a class definition, this is the span of the entire class, and
151 so on. If this isn't well defined for your bit of syntax (like a variable
152 bound by a lambda), then you can just supply a `Nothing`
153
154 There is a test that checks that all symbols in the resulting HIE file
155 occur inside their stated `Scope`. This can be turned on by passing the
156 -fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the
157 .hie file.
158
159 You may also want to provide a test in testsuite/test/hiefile that includes
160 a file containing your new construction, and tests that the calculated scope
161 is valid (by using -fvalidate-ide-info)
162
163 For subtrees in the AST that may contain symbols, the procedure is fairly
164 straightforward. If you are extending the GHC AST, you will need to provide a
165 `ToHie` instance for any new types you may have introduced in the AST.
166
167 Here is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):
168
169 toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
170 HsVar _ (L _ var) ->
171 [ toHie $ C Use (L mspan var)
172 -- Patch up var location since typechecker removes it
173 ]
174 ...
175 HsApp _ a b ->
176 [ toHie a
177 , toHie b
178 ]
179
180 If your subtree is `Located` or has a `SrcSpan` available, the output list
181 should contain a HieAst `Node` corresponding to the subtree. You can use
182 either `makeNode` or `getTypeNode` for this purpose, depending on whether it
183 makes sense to assign a `Type` to the subtree. After this, you just need
184 to concatenate the result of calling `toHie` on all subexpressions and
185 appropriately annotated symbols contained in the subtree.
186
187 The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed
188 to work for both the renamed and typechecked source. `getTypeNode` is from
189 the `HasType` class defined in this file, and it has different instances
190 for `GhcTc` and `GhcRn` that allow it to access the type of the expression
191 when given a typechecked AST:
192
193 class Data a => HasType a where
194 getTypeNode :: a -> HieM [HieAST Type]
195 instance HasType (LHsExpr GhcTc) where
196 getTypeNode e@(L spn e') = ... -- Actually get the type for this expression
197 instance HasType (LHsExpr GhcRn) where
198 getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type
199
200 If your subtree doesn't have a span available, you can omit the `makeNode`
201 call and just recurse directly in to the subexpressions.
202
203 -}
204
205 -- These synonyms match those defined in compiler/GHC.hs
206 type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
207 , Maybe [(LIE GhcRn, Avails)]
208 , Maybe LHsDocString )
209 type TypecheckedSource = LHsBinds GhcTc
210
211
212 {- Note [Name Remapping]
213 The Typechecker introduces new names for mono names in AbsBinds.
214 We don't care about the distinction between mono and poly bindings,
215 so we replace all occurrences of the mono name with the poly name.
216 -}
217 type VarMap a = DVarEnv (Var,a)
218 data HieState = HieState
219 { name_remapping :: NameEnv Id
220 , unlocated_ev_binds :: VarMap (S.Set ContextInfo)
221 -- These contain evidence bindings that we don't have a location for
222 -- These are placed at the top level Node in the HieAST after everything
223 -- else has been generated
224 -- This includes things like top level evidence bindings.
225 }
226
227 addUnlocatedEvBind :: Var -> ContextInfo -> HieM ()
228 addUnlocatedEvBind var ci = do
229 let go (a,b) (_,c) = (a,S.union b c)
230 lift $ modify' $ \s ->
231 s { unlocated_ev_binds =
232 extendDVarEnv_C go (unlocated_ev_binds s)
233 var (var,S.singleton ci)
234 }
235
236 getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type])
237 getUnlocatedEvBinds file = do
238 binds <- lift $ gets unlocated_ev_binds
239 org <- ask
240 let elts = dVarEnvElts binds
241
242 mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci)
243
244 go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of
245 RealSrcSpan spn _
246 | srcSpanFile spn == file ->
247 let node = Node (mkSourcedNodeInfo org ni) spn []
248 ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e]
249 in (xs,node:ys)
250 _ -> (mkNodeInfo e : xs,ys)
251
252 (nis,asts) = foldr go ([],[]) elts
253
254 pure $ (M.fromList nis, asts)
255
256 initState :: HieState
257 initState = HieState emptyNameEnv emptyDVarEnv
258
259 class ModifyState a where -- See Note [Name Remapping]
260 addSubstitution :: a -> a -> HieState -> HieState
261
262 instance ModifyState Name where
263 addSubstitution _ _ hs = hs
264
265 instance ModifyState Id where
266 addSubstitution mono poly hs =
267 hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
268
269 modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
270 modifyState = foldr go id
271 where
272 go ABE{abe_poly=poly,abe_mono=mono} f
273 = addSubstitution mono poly . f
274 go _ f = f
275
276 type HieM = ReaderT NodeOrigin (State HieState)
277
278 -- | Construct an 'HieFile' from the outputs of the typechecker.
279 mkHieFile :: MonadIO m
280 => ModSummary
281 -> TcGblEnv
282 -> RenamedSource -> m HieFile
283 mkHieFile ms ts rs = do
284 let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms)
285 src <- liftIO $ BS.readFile src_file
286 pure $ mkHieFileWithSource src_file src ms ts rs
287
288 -- | Construct an 'HieFile' from the outputs of the typechecker but don't
289 -- read the source file again from disk.
290 mkHieFileWithSource :: FilePath
291 -> BS.ByteString
292 -> ModSummary
293 -> TcGblEnv
294 -> RenamedSource -> HieFile
295 mkHieFileWithSource src_file src ms ts rs =
296 let tc_binds = tcg_binds ts
297 top_ev_binds = tcg_ev_binds ts
298 insts = tcg_insts ts
299 tcs = tcg_tcs ts
300 (asts',arr) = getCompressedAsts tc_binds rs top_ev_binds insts tcs in
301 HieFile
302 { hie_hs_file = src_file
303 , hie_module = ms_mod ms
304 , hie_types = arr
305 , hie_asts = asts'
306 -- mkIfaceExports sorts the AvailInfos for stability
307 , hie_exports = mkIfaceExports (tcg_exports ts)
308 , hie_hs_src = src
309 }
310
311 getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
312 -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
313 getCompressedAsts ts rs top_ev_binds insts tcs =
314 let asts = enrichHie ts rs top_ev_binds insts tcs in
315 compressTypes asts
316
317 enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
318 -> HieASTs Type
319 enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
320 runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do
321 tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
322 rasts <- processGrp hsGrp
323 imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
324 exps <- toHie $ fmap (map $ IEC Export . fst) exports
325 -- Add Instance bindings
326 forM_ insts $ \i ->
327 addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing)
328 -- Add class parent bindings
329 forM_ tcs $ \tc ->
330 case tyConClass_maybe tc of
331 Nothing -> pure ()
332 Just c -> forM_ (classSCSelIds c) $ \v ->
333 addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing)
334 let spanFile file children = case children of
335 [] -> realSrcLocSpan (mkRealSrcLoc file 1 1)
336 _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
337 (realSrcSpanEnd $ nodeSpan $ last children)
338
339 flat_asts = concat
340 [ tasts
341 , rasts
342 , imps
343 , exps
344 ]
345
346 modulify (HiePath file) xs' = do
347
348 top_ev_asts :: [HieAST Type] <- do
349 let
350 l :: SrcSpanAnnA
351 l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Strict.Nothing)
352 toHie $ EvBindContext ModuleScope Nothing
353 $ L l (EvBinds ev_bs)
354
355 (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file
356
357 let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts
358 span = spanFile file xs
359
360 moduleInfo = SourcedNodeInfo
361 $ M.singleton SourceInfo
362 $ (simpleNodeInfo "Module" "Module")
363 {nodeIdentifiers = uloc_evs}
364
365 moduleNode = Node moduleInfo span []
366
367 case mergeSortAsts $ moduleNode : xs of
368 [x] -> return x
369 xs -> panicDoc "enrichHie: mergeSortAsts retur:ed more than one result" (ppr $ map nodeSpan xs)
370
371 asts' <- sequence
372 $ M.mapWithKey modulify
373 $ M.fromListWith (++)
374 $ map (\x -> (HiePath (srcSpanFile (nodeSpan x)),[x])) flat_asts
375
376 let asts = HieASTs $ resolveTyVarScopes asts'
377 return asts
378 where
379 processGrp grp = concatM
380 [ toHie $ fmap (RS ModuleScope ) hs_valds grp
381 , toHie $ hs_splcds grp
382 , toHie $ hs_tyclds grp
383 , toHie $ hs_derivds grp
384 , toHie $ hs_fixds grp
385 , toHie $ hs_defds grp
386 , toHie $ hs_fords grp
387 , toHie $ hs_warnds grp
388 , toHie $ hs_annds grp
389 , toHie $ hs_ruleds grp
390 ]
391
392 getRealSpanA :: SrcSpanAnn' ann -> Maybe Span
393 getRealSpanA la = getRealSpan (locA la)
394
395 getRealSpan :: SrcSpan -> Maybe Span
396 getRealSpan (RealSrcSpan sp _) = Just sp
397 getRealSpan _ = Nothing
398
399 grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns)
400 => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan
401 grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs)
402
403 bindingsOnly :: [Context Name] -> HieM [HieAST a]
404 bindingsOnly [] = pure []
405 bindingsOnly (C c n : xs) = do
406 org <- ask
407 rest <- bindingsOnly xs
408 pure $ case nameSrcSpan n of
409 RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest
410 where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
411 info = mempty{identInfo = S.singleton c}
412 _ -> rest
413
414 concatM :: Monad m => [m [a]] -> m [a]
415 concatM xs = concat <$> sequence xs
416
417 {- Note [Capturing Scopes and other non local information]
418 toHie is a local transformation, but scopes of bindings cannot be known locally,
419 hence we have to push the relevant info down into the binding nodes.
420 We use the following types (*Context and *Scoped) to wrap things and
421 carry the required info
422 (Maybe Span) always carries the span of the entire binding, including rhs
423 -}
424 data Context a = C ContextInfo a -- Used for names and bindings
425
426 data RContext a = RC RecFieldContext a
427 data RFContext a = RFC RecFieldContext (Maybe Span) a
428 -- ^ context for record fields
429
430 data IEContext a = IEC IEType a
431 -- ^ context for imports/exports
432
433 data BindContext a = BC BindType Scope a
434 -- ^ context for imports/exports
435
436 data PatSynFieldContext a = PSC (Maybe Span) a
437 -- ^ context for pattern synonym fields.
438
439 data SigContext a = SC SigInfo a
440 -- ^ context for type signatures
441
442 data SigInfo = SI SigType (Maybe Span)
443
444 data SigType = BindSig | ClassSig | InstSig
445
446 data EvBindContext a = EvBindContext Scope (Maybe Span) a
447
448 data RScoped a = RS Scope a
449 -- ^ Scope spans over everything to the right of a, (mostly) not
450 -- including a itself
451 -- (Includes a in a few special cases like recursive do bindings) or
452 -- let/where bindings
453
454 -- | Pattern scope
455 data PScoped a = PS (Maybe Span)
456 Scope -- ^ use site of the pattern
457 Scope -- ^ pattern to the right of a, not including a
458 a
459 deriving (Typeable, Data) -- Pattern Scope
460
461 {- Note [TyVar Scopes]
462 Due to -XScopedTypeVariables, type variables can be in scope quite far from
463 their original binding. We resolve the scope of these type variables
464 in a separate pass
465 -}
466 data TScoped a = TS TyVarScope a -- TyVarScope
467
468 data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
469 -- ^ First scope remains constant
470 -- Second scope is used to build up the scope of a tyvar over
471 -- things to its right, ala RScoped
472
473 -- | Each element scopes over the elements to the right
474 listScopes :: Scope -> [LocatedA a] -> [RScoped (LocatedA a)]
475 listScopes _ [] = []
476 listScopes rhsScope [pat] = [RS rhsScope pat]
477 listScopes rhsScope (pat : pats) = RS sc pat : pats'
478 where
479 pats'@((RS scope p):_) = listScopes rhsScope pats
480 sc = combineScopes scope $ mkScope $ getLocA p
481
482 -- | 'listScopes' specialised to 'PScoped' things
483 patScopes
484 :: Maybe Span
485 -> Scope
486 -> Scope
487 -> [LPat (GhcPass p)]
488 -> [PScoped (LPat (GhcPass p))]
489 patScopes rsp useScope patScope xs =
490 map (\(RS sc a) -> PS rsp useScope sc a) $
491 listScopes patScope xs
492
493 -- | 'listScopes' specialised to 'HsPatSigType'
494 tScopes
495 :: Scope
496 -> Scope
497 -> [HsPatSigType (GhcPass a)]
498 -> [TScoped (HsPatSigType (GhcPass a))]
499 tScopes scope rhsScope xs =
500 map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $
501 listScopes rhsScope (map (\hsps -> L (getLoc $ hsps_body hsps) hsps) xs)
502 -- We make the HsPatSigType into a Located one by using the location of the underlying LHsType.
503 -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS.
504
505 -- | 'listScopes' specialised to 'TVScoped' things
506 tvScopes
507 :: TyVarScope
508 -> Scope
509 -> [LHsTyVarBndr flag (GhcPass a)]
510 -> [TVScoped (LHsTyVarBndr flag (GhcPass a))]
511 tvScopes tvScope rhsScope xs =
512 map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
513
514 {- Note [Scoping Rules for SigPat]
515 Explicitly quantified variables in pattern type signatures are not
516 brought into scope in the rhs, but implicitly quantified variables
517 are (HsWC and HsIB).
518 This is unlike other signatures, where explicitly quantified variables
519 are brought into the RHS Scope
520 For example
521 foo :: forall a. ...;
522 foo = ... -- a is in scope here
523
524 bar (x :: forall a. a -> a) = ... -- a is not in scope here
525 -- ^ a is in scope here (pattern body)
526
527 bax (x :: a) = ... -- a is in scope here
528
529 This case in handled in the instance for HsPatSigType
530 -}
531
532 class HasLoc a where
533 -- ^ conveniently calculate locations for things without locations attached
534 loc :: a -> SrcSpan
535
536 instance HasLoc thing => HasLoc (PScoped thing) where
537 loc (PS _ _ _ a) = loc a
538
539 instance HasLoc (Located a) where
540 loc (L l _) = l
541
542 instance HasLoc (LocatedA a) where
543 loc (L la _) = locA la
544
545 instance HasLoc (LocatedN a) where
546 loc (L la _) = locA la
547
548 instance HasLoc a => HasLoc [a] where
549 loc [] = noSrcSpan
550 loc xs = foldl1' combineSrcSpans $ map loc xs
551
552 instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where
553 loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of
554 HsOuterImplicit{} ->
555 foldl1' combineSrcSpans [loc a, loc b, loc c]
556 HsOuterExplicit{hso_bndrs = tvs} ->
557 foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c]
558
559 instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
560 loc (HsValArg tm) = loc tm
561 loc (HsTypeArg _ ty) = loc ty
562 loc (HsArgPar sp) = sp
563
564 instance HasLoc (HsDataDefn GhcRn) where
565 loc def@(HsDataDefn{}) = loc $ dd_cons def
566 -- Only used for data family instances, so we only need rhs
567 -- Most probably the rest will be unhelpful anyway
568
569 -- | The main worker class
570 -- See Note [Updating HieAst for changes in the GHC AST] for more information
571 -- on how to add/modify instances for this.
572 class ToHie a where
573 toHie :: a -> HieM [HieAST Type]
574
575 -- | Used to collect type info
576 class HasType a where
577 getTypeNode :: a -> HieM [HieAST Type]
578
579 instance ToHie Void where
580 toHie v = absurd v
581
582 instance (ToHie a) => ToHie [a] where
583 toHie = concatMapM toHie
584
585 instance (ToHie a) => ToHie (Bag a) where
586 toHie = toHie . bagToList
587
588 instance (ToHie a) => ToHie (Maybe a) where
589 toHie = maybe (pure []) toHie
590
591 instance ToHie (IEContext (LocatedA ModuleName)) where
592 toHie (IEC c (L (SrcSpanAnn _ (RealSrcSpan span _)) mname)) = do
593 org <- ask
594 pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]
595 where details = mempty{identInfo = S.singleton (IEThing c)}
596 idents = M.singleton (Left mname) details
597 toHie _ = pure []
598
599 instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where
600 toHie (C c (L l a)) = toHie (C c (L (locA l) a))
601
602 instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where
603 toHie (C c (L l a)) = toHie (C c (L (locA l) a))
604
605 instance ToHie (Context (Located Var)) where
606 toHie c = case c of
607 C context (L (RealSrcSpan span _) name')
608 | varUnique name' == mkBuiltinUnique 1 -> pure []
609 -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
610 | otherwise -> do
611 m <- lift $ gets name_remapping
612 org <- ask
613 let name = case lookupNameEnv m (varName name') of
614 Just var -> var
615 Nothing-> name'
616 ty = case isDataConId_maybe name' of
617 Nothing -> varType name'
618 Just dc -> dataConNonlinearType dc
619 pure
620 [Node
621 (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
622 M.singleton (Right $ varName name)
623 (IdentifierDetails (Just ty)
624 (S.singleton context)))
625 span
626 []]
627 C (EvidenceVarBind i _ sp) (L _ name) -> do
628 addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
629 pure []
630 _ -> pure []
631
632 instance ToHie (Context (Located Name)) where
633 toHie c = case c of
634 C context (L (RealSrcSpan span _) name')
635 | nameUnique name' == mkBuiltinUnique 1 -> pure []
636 -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
637 | otherwise -> do
638 m <- lift $ gets name_remapping
639 org <- ask
640 let name = case lookupNameEnv m name' of
641 Just var -> varName var
642 Nothing -> name'
643 pure
644 [Node
645 (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
646 M.singleton (Right name)
647 (IdentifierDetails Nothing
648 (S.singleton context)))
649 span
650 []]
651 _ -> pure []
652
653 evVarsOfTermList :: EvTerm -> [EvId]
654 evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e
655 evVarsOfTermList (EvTypeable _ ev) =
656 case ev of
657 EvTypeableTyCon _ e -> concatMap evVarsOfTermList e
658 EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2]
659 EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3]
660 EvTypeableTyLit e -> evVarsOfTermList e
661 evVarsOfTermList (EvFun{}) = []
662
663 instance ToHie (EvBindContext (LocatedA TcEvBinds)) where
664 toHie (EvBindContext sc sp (L span (EvBinds bs)))
665 = concatMapM go $ bagToList bs
666 where
667 go evbind = do
668 let evDeps = evVarsOfTermList $ eb_rhs evbind
669 depNames = EvBindDeps $ map varName evDeps
670 concatM $
671 [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScopeA span)) sp)
672 (L span $ eb_lhs evbind))
673 , toHie $ map (C EvidenceVarUse . L span) $ evDeps
674 ]
675 toHie _ = pure []
676
677 instance ToHie (LocatedA HsWrapper) where
678 toHie (L osp wrap)
679 = case wrap of
680 (WpLet bs) -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs)
681 (WpCompose a b) -> concatM $
682 [toHie (L osp a), toHie (L osp b)]
683 (WpFun a b _) -> concatM $
684 [toHie (L osp a), toHie (L osp b)]
685 (WpEvLam a) ->
686 toHie $ C (EvidenceVarBind EvWrapperBind (mkScopeA osp) (getRealSpanA osp))
687 $ L osp a
688 (WpEvApp a) ->
689 concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a
690 _ -> pure []
691
692 instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where
693 getTypeNode (L spn bind) =
694 case hiePass @p of
695 HieRn -> makeNode bind (locA spn)
696 HieTc -> case bind of
697 FunBind{fun_id = name} -> makeTypeNode bind (locA spn) (varType $ unLoc name)
698 _ -> makeNode bind (locA spn)
699
700 instance HiePass p => HasType (LocatedA (Pat (GhcPass p))) where
701 getTypeNode (L spn pat) =
702 case hiePass @p of
703 HieRn -> makeNodeA pat spn
704 HieTc -> makeTypeNodeA pat spn (hsPatType pat)
705
706 -- | This instance tries to construct 'HieAST' nodes which include the type of
707 -- the expression. It is not yet possible to do this efficiently for all
708 -- expression forms, so we skip filling in the type for those inputs.
709 --
710 -- See Note [Computing the type of every node in the tree]
711 instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
712 getTypeNode (L spn e) =
713 case hiePass @p of
714 HieRn -> fallback
715 HieTc -> case computeType e of
716 Just ty -> makeTypeNodeA e spn ty
717 Nothing -> fallback
718 where
719 fallback :: HieM [HieAST Type]
720 fallback = makeNodeA e spn
721
722 -- | Skip computing the type of some expressions for performance reasons.
723 --
724 -- See impact on Haddock output (esp. missing type annotations or links)
725 -- before skipping more kinds of expressions. See impact on Haddock
726 -- performance before computing the types of more expressions.
727 --
728 -- See Note [Computing the type of every node in the tree]
729 computeType :: HsExpr GhcTc -> Maybe Type
730 computeType e = case e of
731 HsApp{} -> Nothing
732 HsAppType{} -> Nothing
733 NegApp{} -> Nothing
734 HsPar _ _ e _ -> computeLType e
735 ExplicitTuple{} -> Nothing
736 HsIf _ _ t f -> computeLType t <|> computeLType f
737 HsLet _ _ _ _ body -> computeLType body
738 RecordCon con_expr _ _ -> computeType con_expr
739 ExprWithTySig _ e _ -> computeLType e
740 HsStatic _ e -> computeLType e
741 HsPragE _ _ e -> computeLType e
742 XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e
743 XExpr (HsTick _ e) -> computeLType e
744 XExpr (HsBinTick _ _ e) -> computeLType e
745 e -> Just (hsExprType e)
746
747 computeLType :: LHsExpr GhcTc -> Maybe Type
748 computeLType (L _ e) = computeType e
749
750 {- Note [Computing the type of every node in the tree]
751 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
752 In GHC.Iface.Ext.Ast we decorate every node in the AST with its
753 type, computed by `hsExprType` applied to that node. So it's
754 important that `hsExprType` takes roughly constant time per node.
755 There are three cases to consider:
756
757 1. For many nodes (e.g. HsVar, HsDo, HsCase) it is easy to get their
758 type -- e.g. it is stored in the node, or in sub-node thereof.
759
760 2. For some nodes (e.g. HsPar, HsTick, HsIf) the type of the node is
761 the type of a child, so we can recurse, fast. We don't expect the
762 nesting to be very deep, so while this is theoretically non-linear,
763 we don't expect it to be a problem in practice.
764
765 3. A very few nodes (e.g. HsApp) are more troublesome because we need to
766 take the type of a child, and then do some non-trivial processing.
767 To be conservative on computation, we decline to decorate these
768 nodes, using `fallback` instead.
769
770 The function `computeType e` returns `Just t` if we can find the type
771 of `e` cheaply, and `Nothing` otherwise. The base `Nothing` cases
772 are the troublesome ones in (3) above. Hopefully we can ultimately
773 get rid of them all.
774
775 See #16233
776
777 -}
778
779 data HiePassEv p where
780 HieRn :: HiePassEv 'Renamed
781 HieTc :: HiePassEv 'Typechecked
782
783 class ( HiePass (NoGhcTcPass p)
784 , NoGhcTcPass p ~ 'Renamed
785 , ModifyState (IdGhcP p)
786 , Data (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
787 , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
788 , Data (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
789 , Data (Stmt (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
790 , Data (Stmt (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
791 , Data (HsExpr (GhcPass p))
792 , Data (HsCmd (GhcPass p))
793 , Data (AmbiguousFieldOcc (GhcPass p))
794 , Data (HsCmdTop (GhcPass p))
795 , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
796 , Data (HsSplice (GhcPass p))
797 , Data (HsLocalBinds (GhcPass p))
798 , Data (FieldOcc (GhcPass p))
799 , Data (HsTupArg (GhcPass p))
800 , Data (IPBind (GhcPass p))
801 , ToHie (Context (Located (IdGhcP p)))
802 , Anno (IdGhcP p) ~ SrcSpanAnnN
803 )
804 => HiePass p where
805 hiePass :: HiePassEv p
806
807 instance HiePass 'Renamed where
808 hiePass = HieRn
809 instance HiePass 'Typechecked where
810 hiePass = HieTc
811
812 instance ToHie (Context (Located NoExtField)) where
813 toHie _ = pure []
814
815 type AnnoBody p body
816 = ( Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
817 ~ SrcSpanAnnA
818 , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
819 ~ SrcSpanAnnL
820 , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
821 ~ SrcAnn NoEpAnns
822 , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA
823
824 , Data (body (GhcPass p))
825 , Data (Match (GhcPass p) (LocatedA (body (GhcPass p))))
826 , Data (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
827 , Data (Stmt (GhcPass p) (LocatedA (body (GhcPass p))))
828 )
829
830 instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where
831 toHie (BC context scope b@(L span bind)) =
832 concatM $ getTypeNode b : case bind of
833 FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->
834 [ toHie $ C (ValBind context scope $ getRealSpanA span) name
835 , toHie matches
836 , case hiePass @p of
837 HieTc -> toHie $ L span wrap
838 _ -> pure []
839 ]
840 PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
841 [ toHie $ PS (getRealSpan (locA span)) scope NoScope lhs
842 , toHie rhs
843 ]
844 VarBind{var_rhs = expr} ->
845 [ toHie expr
846 ]
847 AbsBinds{ abs_exports = xs, abs_binds = binds
848 , abs_ev_binds = ev_binds
849 , abs_ev_vars = ev_vars } ->
850 [ lift (modify (modifyState xs)) >> -- Note [Name Remapping]
851 (toHie $ fmap (BC context scope) binds)
852 , toHie $ map (L span . abe_wrap) xs
853 , toHie $
854 map (EvBindContext (mkScopeA span) (getRealSpanA span)
855 . L span) ev_binds
856 , toHie $
857 map (C (EvidenceVarBind EvSigBind
858 (mkScopeA span)
859 (getRealSpanA span))
860 . L span) ev_vars
861 ]
862 PatSynBind _ psb ->
863 [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level
864 ]
865
866 instance ( HiePass p
867 , AnnoBody p body
868 , ToHie (LocatedA (body (GhcPass p)))
869 ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where
870 toHie mg = case mg of
871 MG{ mg_alts = (L span alts) , mg_origin = origin} ->
872 local (setOrigin origin) $ concatM
873 [ locOnly (locA span)
874 , toHie alts
875 ]
876
877 setOrigin :: Origin -> NodeOrigin -> NodeOrigin
878 setOrigin FromSource _ = SourceInfo
879 setOrigin Generated _ = GeneratedInfo
880
881 instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
882 toHie (L sp psb) = concatM $ case psb of
883 PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
884 [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
885 , toHie $ toBind dets
886 , toHie $ PS Nothing lhsScope patScope pat
887 , toHie dir
888 ]
889 where
890 lhsScope = combineScopes varScope detScope
891 varScope = mkLScopeN var
892 patScope = mkScopeA $ getLoc pat
893 detScope = case dets of
894 (PrefixCon _ args) -> foldr combineScopes NoScope $ map mkLScopeN args
895 (InfixCon a b) -> combineScopes (mkLScopeN a) (mkLScopeN b)
896 (RecCon r) -> foldr go NoScope r
897 go (RecordPatSynField a b) c = combineScopes c
898 $ combineScopes (mkLScopeN (foLabel a)) (mkLScopeN b)
899 detSpan = case detScope of
900 LocalScope a -> Just a
901 _ -> Nothing
902 toBind (PrefixCon ts args) = assert (null ts) $ PrefixCon ts $ map (C Use) args
903 toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
904 toBind (RecCon r) = RecCon $ map (PSC detSpan) r
905
906 instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where
907 toHie dir = case dir of
908 ExplicitBidirectional mg -> toHie mg
909 _ -> pure []
910
911 instance ( HiePass p
912 , Data (body (GhcPass p))
913 , AnnoBody p body
914 , ToHie (LocatedA (body (GhcPass p)))
915 ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where
916 toHie (L span m ) = concatM $ makeNodeA m span : case m of
917 Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
918 [ toHie mctx
919 , let rhsScope = mkScope $ grhss_span grhss
920 in toHie $ patScopes Nothing rhsScope NoScope pats
921 , toHie grhss
922 ]
923
924 instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where
925 toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name'
926 where
927 -- See a paragraph about Haddock in #20415.
928 name' :: LocatedN Name
929 name' = case hiePass @p of
930 HieRn -> name
931 HieTc -> mapLoc varName name
932 toHie (StmtCtxt a) = toHie a
933 toHie _ = pure []
934
935 instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where
936 toHie (PatGuard a) = toHie a
937 toHie (ParStmtCtxt a) = toHie a
938 toHie (TransStmtCtxt a) = toHie a
939 toHie _ = pure []
940
941 instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
942 toHie (PS rsp scope pscope lpat@(L ospan opat)) =
943 concatM $ getTypeNode lpat : case opat of
944 WildPat _ ->
945 []
946 VarPat _ lname ->
947 [ toHie $ C (PatternBind scope pscope rsp) lname
948 ]
949 LazyPat _ p ->
950 [ toHie $ PS rsp scope pscope p
951 ]
952 AsPat _ lname pat ->
953 [ toHie $ C (PatternBind scope
954 (combineScopes (mkLScopeA pat) pscope)
955 rsp)
956 lname
957 , toHie $ PS rsp scope pscope pat
958 ]
959 ParPat _ _ pat _ ->
960 [ toHie $ PS rsp scope pscope pat
961 ]
962 BangPat _ pat ->
963 [ toHie $ PS rsp scope pscope pat
964 ]
965 ListPat _ pats ->
966 [ toHie $ patScopes rsp scope pscope pats
967 ]
968 TuplePat _ pats _ ->
969 [ toHie $ patScopes rsp scope pscope pats
970 ]
971 SumPat _ pat _ _ ->
972 [ toHie $ PS rsp scope pscope pat
973 ]
974 ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} ->
975 case hiePass @p of
976 HieTc ->
977 [ toHie $ C Use $ fmap conLikeName con
978 , toHie $ contextify dets
979 , let ev_binds = cpt_binds ext
980 ev_vars = cpt_dicts ext
981 wrap = cpt_wrap ext
982 evscope = mkScopeA ospan `combineScopes` scope `combineScopes` pscope
983 in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds
984 , toHie $ L ospan wrap
985 , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
986 . L ospan) ev_vars
987 ]
988 ]
989 HieRn ->
990 [ toHie $ C Use con
991 , toHie $ contextify dets
992 ]
993 ViewPat _ expr pat ->
994 [ toHie expr
995 , toHie $ PS rsp scope pscope pat
996 ]
997 SplicePat _ sp ->
998 [ toHie $ L ospan sp
999 ]
1000 LitPat _ _ ->
1001 []
1002 NPat _ _ _ _ ->
1003 []
1004 NPlusKPat _ n _ _ _ _ ->
1005 [ toHie $ C (PatternBind scope pscope rsp) n
1006 ]
1007 SigPat _ pat sig ->
1008 [ toHie $ PS rsp scope pscope pat
1009 , case hiePass @p of
1010 HieTc ->
1011 let cscope = mkLScopeA pat in
1012 toHie $ TS (ResolvedScopes [cscope, scope, pscope])
1013 sig
1014 HieRn -> pure []
1015 ]
1016 XPat e ->
1017 case hiePass @p of
1018 HieRn -> case e of
1019 HsPatExpanded _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
1020 HieTc -> case e of
1021 CoPat wrap pat _ ->
1022 [ toHie $ L ospan wrap
1023 , toHie $ PS rsp scope pscope $ (L ospan pat)
1024 ]
1025 ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
1026 where
1027 contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType GhcRn) a (HsRecFields (GhcPass p) a)
1028 -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
1029 contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args)
1030 where argscope = foldr combineScopes NoScope $ map mkLScopeA args
1031 contextify (InfixCon a b) = InfixCon a' b'
1032 where [a', b'] = patScopes rsp scope pscope [a,b]
1033 contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
1034 contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
1035 where
1036 go :: RScoped (LocatedA (HsFieldBind id a1))
1037 -> LocatedA (HsFieldBind id (PScoped a1)) -- AZ
1038 go (RS fscope (L spn (HsFieldBind x lbl pat pun))) =
1039 L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun
1040 scoped_fds = listScopes pscope fds
1041
1042 instance ToHie (TScoped (HsPatSigType GhcRn)) where
1043 toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
1044 [ bindingsOnly $ map (C $ TyVarBind (mkScopeA span) sc) (wcs++tvs)
1045 , toHie body
1046 ]
1047 -- See Note [Scoping Rules for SigPat]
1048
1049 instance ( ToHie (LocatedA (body (GhcPass p)))
1050 , HiePass p
1051 , AnnoBody p body
1052 ) => ToHie (GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))) where
1053 toHie grhs = concatM $ case grhs of
1054 GRHSs _ grhss binds ->
1055 [ toHie grhss
1056 , toHie $ RS (mkScope $ grhss_span grhs) binds
1057 ]
1058
1059 instance ( ToHie (LocatedA (body (GhcPass p)))
1060 , HiePass p
1061 , AnnoBody p body
1062 ) => ToHie (LocatedAn NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where
1063 toHie (L span g) = concatM $ makeNodeA g span : case g of
1064 GRHS _ guards body ->
1065 [ toHie $ listScopes (mkLScopeA body) guards
1066 , toHie body
1067 ]
1068
1069 instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
1070 toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
1071 HsVar _ (L _ var) ->
1072 [ toHie $ C Use (L mspan var)
1073 -- Patch up var location since typechecker removes it
1074 ]
1075 HsUnboundVar _ _ -> [] -- there is an unbound name here, but that causes trouble
1076 HsRecSel _ fld ->
1077 [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld)
1078 ]
1079 HsOverLabel {} -> []
1080 HsIPVar _ _ -> []
1081 HsOverLit _ _ -> []
1082 HsLit _ _ -> []
1083 HsLam _ mg ->
1084 [ toHie mg
1085 ]
1086 HsLamCase _ mg ->
1087 [ toHie mg
1088 ]
1089 HsApp _ a b ->
1090 [ toHie a
1091 , toHie b
1092 ]
1093 HsAppType _ expr sig ->
1094 [ toHie expr
1095 , toHie $ TS (ResolvedScopes []) sig
1096 ]
1097 OpApp _ a b c ->
1098 [ toHie a
1099 , toHie b
1100 , toHie c
1101 ]
1102 NegApp _ a _ ->
1103 [ toHie a
1104 ]
1105 HsPar _ _ a _ ->
1106 [ toHie a
1107 ]
1108 SectionL _ a b ->
1109 [ toHie a
1110 , toHie b
1111 ]
1112 SectionR _ a b ->
1113 [ toHie a
1114 , toHie b
1115 ]
1116 ExplicitTuple _ args _ ->
1117 [ toHie args
1118 ]
1119 ExplicitSum _ _ _ expr ->
1120 [ toHie expr
1121 ]
1122 HsCase _ expr matches ->
1123 [ toHie expr
1124 , toHie matches
1125 ]
1126 HsIf _ a b c ->
1127 [ toHie a
1128 , toHie b
1129 , toHie c
1130 ]
1131 HsMultiIf _ grhss ->
1132 [ toHie grhss
1133 ]
1134 HsLet _ _ binds _ expr ->
1135 [ toHie $ RS (mkLScopeA expr) binds
1136 , toHie expr
1137 ]
1138 HsDo _ _ (L ispan stmts) ->
1139 [ locOnly (locA ispan)
1140 , toHie $ listScopes NoScope stmts
1141 ]
1142 ExplicitList _ exprs ->
1143 [ toHie exprs
1144 ]
1145 RecordCon { rcon_con = con, rcon_flds = binds} ->
1146 [ toHie $ C Use $ con_name
1147 , toHie $ RC RecFieldAssign $ binds
1148 ]
1149 where
1150 con_name :: LocatedN Name
1151 con_name = case hiePass @p of -- Like ConPat
1152 HieRn -> con
1153 HieTc -> fmap conLikeName con
1154 RecordUpd {rupd_expr = expr, rupd_flds = Left upds}->
1155 [ toHie expr
1156 , toHie $ map (RC RecFieldAssign) upds
1157 ]
1158 RecordUpd {rupd_expr = expr, rupd_flds = Right _}->
1159 [ toHie expr
1160 ]
1161 ExprWithTySig _ expr sig ->
1162 [ toHie expr
1163 , toHie $ TS (ResolvedScopes [mkLScopeA expr]) sig
1164 ]
1165 ArithSeq _ _ info ->
1166 [ toHie info
1167 ]
1168 HsPragE _ _ expr ->
1169 [ toHie expr
1170 ]
1171 HsProc _ pat cmdtop ->
1172 [ toHie $ PS Nothing (mkLScopeA cmdtop) NoScope pat
1173 , toHie cmdtop
1174 ]
1175 HsStatic _ expr ->
1176 [ toHie expr
1177 ]
1178 HsBracket _ b ->
1179 [ toHie b
1180 ]
1181 HsRnBracketOut _ b p ->
1182 [ toHie b
1183 , toHie p
1184 ]
1185 HsTcBracketOut _ _wrap b p ->
1186 [ toHie b
1187 , toHie p
1188 ]
1189 HsSpliceE _ x ->
1190 [ toHie $ L mspan x
1191 ]
1192 HsGetField {} -> []
1193 HsProjection {} -> []
1194 XExpr x
1195 | HieTc <- hiePass @p
1196 -> case x of
1197 WrapExpr (HsWrap w a)
1198 -> [ toHie $ L mspan a
1199 , toHie (L mspan w) ]
1200 ExpansionExpr (HsExpanded _ b)
1201 -> [ toHie (L mspan b) ]
1202 ConLikeTc con _ _
1203 -> [ toHie $ C Use $ L mspan $ conLikeName con ]
1204 HsTick _ expr
1205 -> [ toHie expr
1206 ]
1207 HsBinTick _ _ expr
1208 -> [ toHie expr
1209 ]
1210 | otherwise -> []
1211
1212 -- NOTE: no longer have the location
1213 instance HiePass p => ToHie (HsTupArg (GhcPass p)) where
1214 toHie arg = concatM $ case arg of
1215 Present _ expr ->
1216 [ toHie expr
1217 ]
1218 Missing _ -> []
1219
1220 instance ( ToHie (LocatedA (body (GhcPass p)))
1221 , AnnoBody p body
1222 , HiePass p
1223 ) => ToHie (RScoped (LocatedA (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))))) where
1224 toHie (RS scope (L span stmt)) = concatM $ node : case stmt of
1225 LastStmt _ body _ _ ->
1226 [ toHie body
1227 ]
1228 BindStmt _ pat body ->
1229 [ toHie $ PS (getRealSpan $ getLocA body) scope NoScope pat
1230 , toHie body
1231 ]
1232 ApplicativeStmt _ stmts _ ->
1233 [ concatMapM (toHie . RS scope . snd) stmts
1234 ]
1235 BodyStmt _ body _ _ ->
1236 [ toHie body
1237 ]
1238 LetStmt _ binds ->
1239 [ toHie $ RS scope binds
1240 ]
1241 ParStmt _ parstmts _ _ ->
1242 [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
1243 toHie $ listScopes NoScope stmts)
1244 parstmts
1245 ]
1246 TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
1247 [ toHie $ listScopes scope stmts
1248 , toHie using
1249 , toHie by
1250 ]
1251 RecStmt {recS_stmts = L _ stmts} ->
1252 [ toHie $ map (RS $ combineScopes scope (mkScope (locA span))) stmts
1253 ]
1254 where
1255 node = case hiePass @p of
1256 HieTc -> makeNodeA stmt span
1257 HieRn -> makeNodeA stmt span
1258
1259 instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where
1260 toHie (RS scope binds) = concatM $ makeNode binds (spanHsLocaLBinds binds) : case binds of
1261 EmptyLocalBinds _ -> []
1262 HsIPBinds _ ipbinds -> case ipbinds of
1263 IPBinds evbinds xs -> let sc = combineScopes scope $ scopeHsLocaLBinds binds
1264 sp :: SrcSpanAnnA
1265 sp = noAnnSrcSpan $ spanHsLocaLBinds binds in
1266 [
1267 case hiePass @p of
1268 HieTc -> toHie $ EvBindContext sc (getRealSpan $ locA sp) $ L sp evbinds
1269 HieRn -> pure []
1270 , toHie $ map (RS sc) xs
1271 ]
1272 HsValBinds _ valBinds ->
1273 [
1274 toHie $ RS (combineScopes scope (scopeHsLocaLBinds binds))
1275 valBinds
1276 ]
1277
1278
1279 scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope
1280 scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
1281 = foldr combineScopes NoScope (bsScope ++ sigsScope)
1282 where
1283 bsScope :: [Scope]
1284 bsScope = map (mkScopeA . getLoc) $ bagToList bs
1285 sigsScope :: [Scope]
1286 sigsScope = map (mkScope . getLocA) sigs
1287 scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
1288 = foldr combineScopes NoScope (bsScope ++ sigsScope)
1289 where
1290 bsScope :: [Scope]
1291 bsScope = map (mkScopeA . getLoc) $ concatMap (bagToList . snd) bs
1292 sigsScope :: [Scope]
1293 sigsScope = map (mkScope . getLocA) sigs
1294
1295 scopeHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
1296 = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs)
1297 scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope
1298
1299
1300 instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where
1301 toHie (RS scope (L sp bind)) = concatM $ makeNodeA bind sp : case bind of
1302 IPBind _ (Left _) expr -> [toHie expr]
1303 IPBind _ (Right v) expr ->
1304 [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))
1305 $ L sp v
1306 , toHie expr
1307 ]
1308
1309 instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where
1310 toHie (RS sc v) = concatM $ case v of
1311 ValBinds _ binds sigs ->
1312 [ toHie $ fmap (BC RegularBind sc) binds
1313 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
1314 ]
1315 XValBindsLR x -> [ toHie $ RS sc x ]
1316
1317 instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where
1318 toHie (RS sc (NValBinds binds sigs)) = concatM $
1319 [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
1320 , toHie $ fmap (SC (SI BindSig Nothing)) sigs
1321 ]
1322
1323 instance ( ToHie arg , HasLoc arg , Data arg
1324 , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where
1325 toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
1326
1327 instance ( ToHie (RFContext label)
1328 , ToHie arg, HasLoc arg, Data arg
1329 , Data label
1330 ) => ToHie (RContext (LocatedA (HsFieldBind label arg))) where
1331 toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of
1332 HsFieldBind _ label expr _ ->
1333 [ toHie $ RFC c (getRealSpan $ loc expr) label
1334 , toHie expr
1335 ]
1336
1337 instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (FieldOcc (GhcPass p)))) where
1338 toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1339 FieldOcc fld _ ->
1340 case hiePass @p of
1341 HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
1342 HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
1343
1344 instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where
1345 toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1346 Unambiguous fld _ ->
1347 case hiePass @p of
1348 HieRn -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]
1349 HieTc -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]
1350 Ambiguous fld _ ->
1351 case hiePass @p of
1352 HieRn -> []
1353 HieTc -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ]
1354
1355 instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
1356 toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
1357 [ toHie $ PS Nothing sc NoScope pat
1358 , toHie expr
1359 ]
1360 toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM
1361 [ toHie $ listScopes NoScope stmts
1362 , toHie $ PS Nothing sc NoScope pat
1363 ]
1364
1365 instance (ToHie tyarg, ToHie arg, ToHie rec) => ToHie (HsConDetails tyarg arg rec) where
1366 toHie (PrefixCon tyargs args) = concatM [ toHie tyargs, toHie args ]
1367 toHie (RecCon rec) = toHie rec
1368 toHie (InfixCon a b) = concatM [ toHie a, toHie b]
1369
1370 instance ToHie (HsConDeclGADTDetails GhcRn) where
1371 toHie (PrefixConGADT args) = toHie args
1372 toHie (RecConGADT rec _) = toHie rec
1373
1374 instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where
1375 toHie (L span top) = concatM $ makeNodeA top span : case top of
1376 HsCmdTop _ cmd ->
1377 [ toHie cmd
1378 ]
1379
1380 instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where
1381 toHie (L span cmd) = concatM $ makeNodeA cmd span : case cmd of
1382 HsCmdArrApp _ a b _ _ ->
1383 [ toHie a
1384 , toHie b
1385 ]
1386 HsCmdArrForm _ a _ _ cmdtops ->
1387 [ toHie a
1388 , toHie cmdtops
1389 ]
1390 HsCmdApp _ a b ->
1391 [ toHie a
1392 , toHie b
1393 ]
1394 HsCmdLam _ mg ->
1395 [ toHie mg
1396 ]
1397 HsCmdPar _ _ a _ ->
1398 [ toHie a
1399 ]
1400 HsCmdCase _ expr alts ->
1401 [ toHie expr
1402 , toHie alts
1403 ]
1404 HsCmdLamCase _ alts ->
1405 [ toHie alts
1406 ]
1407 HsCmdIf _ _ a b c ->
1408 [ toHie a
1409 , toHie b
1410 , toHie c
1411 ]
1412 HsCmdLet _ _ binds _ cmd' ->
1413 [ toHie $ RS (mkLScopeA cmd') binds
1414 , toHie cmd'
1415 ]
1416 HsCmdDo _ (L ispan stmts) ->
1417 [ locOnly (locA ispan)
1418 , toHie $ listScopes NoScope stmts
1419 ]
1420 XCmd _ -> []
1421
1422 instance ToHie (TyClGroup GhcRn) where
1423 toHie TyClGroup{ group_tyclds = classes
1424 , group_roles = roles
1425 , group_kisigs = sigs
1426 , group_instds = instances } =
1427 concatM
1428 [ toHie classes
1429 , toHie sigs
1430 , toHie roles
1431 , toHie instances
1432 ]
1433
1434 instance ToHie (LocatedA (TyClDecl GhcRn)) where
1435 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
1436 FamDecl {tcdFam = fdecl} ->
1437 [ toHie ((L span fdecl) :: LFamilyDecl GhcRn)
1438 ]
1439 SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1440 [ toHie $ C (Decl SynDec $ getRealSpanA span) name
1441 , toHie $ TS (ResolvedScopes [mkScope $ getLocA typ]) vars
1442 , toHie typ
1443 ]
1444 DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1445 [ toHie $ C (Decl DataDec $ getRealSpanA span) name
1446 , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1447 , toHie defn
1448 ]
1449 where
1450 quant_scope = mkLScopeA $ fromMaybe (noLocA []) $ dd_ctxt defn
1451 rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1452 sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn
1453 con_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_cons defn
1454 deriv_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_derivs defn
1455 ClassDecl { tcdCtxt = context
1456 , tcdLName = name
1457 , tcdTyVars = vars
1458 , tcdFDs = deps
1459 , tcdSigs = sigs
1460 , tcdMeths = meths
1461 , tcdATs = typs
1462 , tcdATDefs = deftyps
1463 } ->
1464 [ toHie $ C (Decl ClassDec $ getRealSpanA span) name
1465 , toHie context
1466 , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1467 , toHie deps
1468 , toHie $ map (SC $ SI ClassSig $ getRealSpanA span) sigs
1469 , toHie $ fmap (BC InstanceBind ModuleScope) meths
1470 , toHie typs
1471 , concatMapM (locOnly . getLocA) deftyps
1472 , toHie deftyps
1473 ]
1474 where
1475 context_scope = mkLScopeA $ fromMaybe (noLocA []) context
1476 rhs_scope = foldl1' combineScopes $ map mkScope
1477 [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1478
1479 instance ToHie (LocatedA (FamilyDecl GhcRn)) where
1480 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
1481 FamilyDecl _ info _ name vars _ sig inj ->
1482 [ toHie $ C (Decl FamDec $ getRealSpanA span) name
1483 , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1484 , toHie info
1485 , toHie $ RS injSpan sig
1486 , toHie inj
1487 ]
1488 where
1489 rhsSpan = sigSpan `combineScopes` injSpan
1490 sigSpan = mkScope $ getLocA sig
1491 injSpan = maybe NoScope (mkScope . getLocA) inj
1492
1493 instance ToHie (FamilyInfo GhcRn) where
1494 toHie (ClosedTypeFamily (Just eqns)) = concatM $
1495 [ concatMapM (locOnly . getLocA) eqns
1496 , toHie $ map go eqns
1497 ]
1498 where
1499 go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib
1500 toHie _ = pure []
1501
1502 instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where
1503 toHie (RS sc (L span sig)) = concatM $ makeNodeA sig span : case sig of
1504 NoSig _ ->
1505 []
1506 KindSig _ k ->
1507 [ toHie k
1508 ]
1509 TyVarSig _ bndr ->
1510 [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1511 ]
1512
1513 instance ToHie (LocatedA (FunDep GhcRn)) where
1514 toHie (L span fd@(FunDep _ lhs rhs)) = concatM $
1515 [ makeNode fd (locA span)
1516 , toHie $ map (C Use) lhs
1517 , toHie $ map (C Use) rhs
1518 ]
1519
1520
1521 instance ToHie (TScoped (FamEqn GhcRn (HsDataDefn GhcRn))) where
1522 toHie (TS _ f) = toHie f
1523
1524 instance ToHie (TScoped (FamEqn GhcRn (LocatedA (HsType GhcRn)))) where
1525 toHie (TS _ f) = toHie f
1526
1527 instance (ToHie rhs, HasLoc rhs)
1528 => ToHie (FamEqn GhcRn rhs) where
1529 toHie fe@(FamEqn _ var outer_bndrs pats _ rhs) = concatM $
1530 [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1531 , toHie $ TVS (ResolvedScopes []) scope outer_bndrs
1532 , toHie pats
1533 , toHie rhs
1534 ]
1535 where scope = combineScopes patsScope rhsScope
1536 patsScope = mkScope (loc pats)
1537 rhsScope = mkScope (loc rhs)
1538
1539 instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where
1540 toHie (L span ann) = concatM $ makeNodeA ann span : case ann of
1541 InjectivityAnn _ lhs rhs ->
1542 [ toHie $ C Use lhs
1543 , toHie $ map (C Use) rhs
1544 ]
1545
1546 instance ToHie (HsDataDefn GhcRn) where
1547 toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1548 [ toHie ctx
1549 , toHie mkind
1550 , toHie cons
1551 , toHie derivs
1552 ]
1553
1554 instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where
1555 toHie (L span clauses) = concatM
1556 [ locOnly span
1557 , toHie clauses
1558 ]
1559
1560 instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where
1561 toHie (L span cl) = concatM $ makeNodeA cl span : case cl of
1562 HsDerivingClause _ strat dct ->
1563 [ toHie strat
1564 , toHie dct
1565 ]
1566
1567 instance ToHie (LocatedC (DerivClauseTys GhcRn)) where
1568 toHie (L span dct) = concatM $ makeNodeA dct span : case dct of
1569 DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ]
1570 DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]
1571
1572 instance ToHie (LocatedAn NoEpAnns (DerivStrategy GhcRn)) where
1573 toHie (L span strat) = concatM $ makeNodeA strat span : case strat of
1574 StockStrategy _ -> []
1575 AnyclassStrategy _ -> []
1576 NewtypeStrategy _ -> []
1577 ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ]
1578
1579 instance ToHie (LocatedP OverlapMode) where
1580 toHie (L span _) = locOnly (locA span)
1581
1582 instance ToHie a => ToHie (HsScaled GhcRn a) where
1583 toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]
1584
1585 instance ToHie (LocatedA (ConDecl GhcRn)) where
1586 toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
1587 ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs
1588 , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->
1589 [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names
1590 , case outer_bndrs of
1591 HsOuterImplicit{hso_ximplicit = imp_vars} ->
1592 bindingsOnly $ map (C $ TyVarBind (mkScopeA outer_bndrs_loc) resScope)
1593 imp_vars
1594 HsOuterExplicit{hso_bndrs = exp_bndrs} ->
1595 toHie $ tvScopes resScope NoScope exp_bndrs
1596 , toHie ctx
1597 , toHie args
1598 , toHie typ
1599 ]
1600 where
1601 rhsScope = combineScopes argsScope tyScope
1602 ctxScope = maybe NoScope mkLScopeA ctx
1603 argsScope = case args of
1604 PrefixConGADT xs -> scaled_args_scope xs
1605 RecConGADT x _ -> mkLScopeA x
1606 tyScope = mkLScopeA typ
1607 resScope = ResolvedScopes [ctxScope, rhsScope]
1608 ConDeclH98 { con_name = name, con_ex_tvs = qvars
1609 , con_mb_cxt = ctx, con_args = dets } ->
1610 [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name
1611 , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1612 , toHie ctx
1613 , toHie dets
1614 ]
1615 where
1616 rhsScope = combineScopes ctxScope argsScope
1617 ctxScope = maybe NoScope mkLScopeA ctx
1618 argsScope = case dets of
1619 PrefixCon _ xs -> scaled_args_scope xs
1620 InfixCon a b -> scaled_args_scope [a, b]
1621 RecCon x -> mkLScopeA x
1622 where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope
1623 scaled_args_scope = foldr combineScopes NoScope . map (mkLScopeA . hsScaledThing)
1624
1625 instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
1626 toHie (L span decls) = concatM $
1627 [ locOnly (locA span)
1628 , toHie decls
1629 ]
1630
1631 instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where
1632 toHie (TS sc (HsWC names a)) = concatM $
1633 [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1634 , toHie $ TS sc a
1635 ]
1636 where span = loc a
1637
1638 instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsType GhcRn)))) where
1639 toHie (TS sc (HsWC names a)) = concatM $
1640 [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1641 , toHie a
1642 ]
1643 where span = loc a
1644
1645 instance ToHie (LocatedA (StandaloneKindSig GhcRn)) where
1646 toHie (L sp sig) = concatM [makeNodeA sig sp, toHie sig]
1647
1648 instance ToHie (StandaloneKindSig GhcRn) where
1649 toHie sig = concatM $ case sig of
1650 StandaloneKindSig _ name typ ->
1651 [ toHie $ C TyDecl name
1652 , toHie $ TS (ResolvedScopes []) typ
1653 ]
1654
1655 instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
1656 toHie (SC (SI styp msp) (L sp sig)) =
1657 case hiePass @p of
1658 HieTc -> pure []
1659 HieRn -> concatM $ makeNodeA sig sp : case sig of
1660 TypeSig _ names typ ->
1661 [ toHie $ map (C TyDecl) names
1662 , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1663 ]
1664 PatSynSig _ names typ ->
1665 [ toHie $ map (C TyDecl) names
1666 , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1667 ]
1668 ClassOpSig _ _ names typ ->
1669 [ case styp of
1670 ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpanA sp) names
1671 _ -> toHie $ map (C $ TyDecl) names
1672 , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1673 ]
1674 IdSig _ _ -> []
1675 FixSig _ fsig ->
1676 [ toHie $ L sp fsig
1677 ]
1678 InlineSig _ name _ ->
1679 [ toHie $ (C Use) name
1680 ]
1681 SpecSig _ name typs _ ->
1682 [ toHie $ (C Use) name
1683 , toHie $ map (TS (ResolvedScopes [])) typs
1684 ]
1685 SpecInstSig _ _ typ ->
1686 [ toHie $ TS (ResolvedScopes []) typ
1687 ]
1688 MinimalSig _ _ form ->
1689 [ toHie form
1690 ]
1691 SCCFunSig _ _ name mtxt ->
1692 [ toHie $ (C Use) name
1693 , maybe (pure []) (locOnly . getLocA) mtxt
1694 ]
1695 CompleteMatchSig _ _ (L ispan names) typ ->
1696 [ locOnly ispan
1697 , toHie $ map (C Use) names
1698 , toHie $ fmap (C Use) typ
1699 ]
1700
1701 instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where
1702 toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span :
1703 [ toHie (TVS tsc (mkScopeA span) bndrs)
1704 , toHie body
1705 ]
1706
1707 -- Check this
1708 instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where
1709 toHie (TVS tsc sc bndrs) = case bndrs of
1710 HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs
1711 HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs
1712
1713 instance ToHie (LocatedA (HsType GhcRn)) where
1714 toHie (L span t) = concatM $ makeNode t (locA span) : case t of
1715 HsForAllTy _ tele body ->
1716 let scope = mkScope $ getLocA body in
1717 [ case tele of
1718 HsForAllVis { hsf_vis_bndrs = bndrs } ->
1719 toHie $ tvScopes (ResolvedScopes []) scope bndrs
1720 HsForAllInvis { hsf_invis_bndrs = bndrs } ->
1721 toHie $ tvScopes (ResolvedScopes []) scope bndrs
1722 , toHie body
1723 ]
1724 HsQualTy _ ctx body ->
1725 [ toHie ctx
1726 , toHie body
1727 ]
1728 HsTyVar _ _ var ->
1729 [ toHie $ C Use var
1730 ]
1731 HsAppTy _ a b ->
1732 [ toHie a
1733 , toHie b
1734 ]
1735 HsAppKindTy _ ty ki ->
1736 [ toHie ty
1737 , toHie ki
1738 ]
1739 HsFunTy _ w a b ->
1740 [ toHie (arrowToHsType w)
1741 , toHie a
1742 , toHie b
1743 ]
1744 HsListTy _ a ->
1745 [ toHie a
1746 ]
1747 HsTupleTy _ _ tys ->
1748 [ toHie tys
1749 ]
1750 HsSumTy _ tys ->
1751 [ toHie tys
1752 ]
1753 HsOpTy _ a op b ->
1754 [ toHie a
1755 , toHie $ C Use op
1756 , toHie b
1757 ]
1758 HsParTy _ a ->
1759 [ toHie a
1760 ]
1761 HsIParamTy _ ip ty ->
1762 [ toHie ip
1763 , toHie ty
1764 ]
1765 HsKindSig _ a b ->
1766 [ toHie a
1767 , toHie b
1768 ]
1769 HsSpliceTy _ a ->
1770 [ toHie $ L span a
1771 ]
1772 HsDocTy _ a _ ->
1773 [ toHie a
1774 ]
1775 HsBangTy _ _ ty ->
1776 [ toHie ty
1777 ]
1778 HsRecTy _ fields ->
1779 [ toHie fields
1780 ]
1781 HsExplicitListTy _ _ tys ->
1782 [ toHie tys
1783 ]
1784 HsExplicitTupleTy _ tys ->
1785 [ toHie tys
1786 ]
1787 HsTyLit _ _ -> []
1788 HsWildCardTy _ -> []
1789 HsStarTy _ _ -> []
1790 XHsType _ -> []
1791
1792 instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1793 toHie (HsValArg tm) = toHie tm
1794 toHie (HsTypeArg _ ty) = toHie ty
1795 toHie (HsArgPar sp) = locOnly sp
1796
1797 instance Data flag => ToHie (TVScoped (LocatedA (HsTyVarBndr flag GhcRn))) where
1798 toHie (TVS tsc sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of
1799 UserTyVar _ _ var ->
1800 [ toHie $ C (TyVarBind sc tsc) var
1801 ]
1802 KindedTyVar _ _ var kind ->
1803 [ toHie $ C (TyVarBind sc tsc) var
1804 , toHie kind
1805 ]
1806
1807 instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1808 toHie (TS sc (HsQTvs implicits vars)) = concatM $
1809 [ bindingsOnly bindings
1810 , toHie $ tvScopes sc NoScope vars
1811 ]
1812 where
1813 varLoc = loc vars
1814 bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1815
1816 instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where
1817 toHie (L span tys) = concatM $
1818 [ locOnly (locA span)
1819 , toHie tys
1820 ]
1821
1822 instance ToHie (LocatedA (ConDeclField GhcRn)) where
1823 toHie (L span field) = concatM $ makeNode field (locA span) : case field of
1824 ConDeclField _ fields typ _ ->
1825 [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1826 , toHie typ
1827 ]
1828
1829 instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1830 toHie (From expr) = toHie expr
1831 toHie (FromThen a b) = concatM $
1832 [ toHie a
1833 , toHie b
1834 ]
1835 toHie (FromTo a b) = concatM $
1836 [ toHie a
1837 , toHie b
1838 ]
1839 toHie (FromThenTo a b c) = concatM $
1840 [ toHie a
1841 , toHie b
1842 , toHie c
1843 ]
1844
1845 instance ToHie (LocatedA (SpliceDecl GhcRn)) where
1846 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
1847 SpliceDecl _ splice _ ->
1848 [ toHie splice
1849 ]
1850
1851 instance ToHie (HsBracket a) where
1852 toHie _ = pure []
1853
1854 instance ToHie PendingRnSplice where
1855 toHie _ = pure []
1856
1857 instance ToHie PendingTcSplice where
1858 toHie _ = pure []
1859
1860 instance ToHie (LBooleanFormula (LocatedN Name)) where
1861 toHie (L span form) = concatM $ makeNode form (locA span) : case form of
1862 Var a ->
1863 [ toHie $ C Use a
1864 ]
1865 And forms ->
1866 [ toHie forms
1867 ]
1868 Or forms ->
1869 [ toHie forms
1870 ]
1871 Parens f ->
1872 [ toHie f
1873 ]
1874
1875 instance ToHie (LocatedAn NoEpAnns HsIPName) where
1876 toHie (L span e) = makeNodeA e span
1877
1878 instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where
1879 toHie (L span sp) = concatM $ makeNodeA sp span : case sp of
1880 HsTypedSplice _ _ _ expr ->
1881 [ toHie expr
1882 ]
1883 HsUntypedSplice _ _ _ expr ->
1884 [ toHie expr
1885 ]
1886 HsQuasiQuote _ _ _ ispan _ ->
1887 [ locOnly ispan
1888 ]
1889 HsSpliced _ _ _ ->
1890 []
1891 XSplice x -> case hiePass @p of
1892 #if __GLASGOW_HASKELL__ < 811
1893 HieRn -> noExtCon x
1894 #endif
1895 HieTc -> case x of
1896 HsSplicedT _ -> []
1897
1898 instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where
1899 toHie (L span annot) = concatM $ makeNodeA annot span : case annot of
1900 RoleAnnotDecl _ var roles ->
1901 [ toHie $ C Use var
1902 , concatMapM (locOnly . getLocA) roles
1903 ]
1904
1905 instance ToHie (LocatedA (InstDecl GhcRn)) where
1906 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
1907 ClsInstD _ d ->
1908 [ toHie $ L span d
1909 ]
1910 DataFamInstD _ d ->
1911 [ toHie $ L span d
1912 ]
1913 TyFamInstD _ d ->
1914 [ toHie $ L span d
1915 ]
1916
1917 instance ToHie (LocatedA (ClsInstDecl GhcRn)) where
1918 toHie (L span decl) = concatM
1919 [ toHie $ TS (ResolvedScopes [mkScopeA span]) $ cid_poly_ty decl
1920 , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1921 , toHie $ map (SC $ SI InstSig $ getRealSpanA span) $ cid_sigs decl
1922 , concatMapM (locOnly . getLocA) $ cid_tyfam_insts decl
1923 , toHie $ cid_tyfam_insts decl
1924 , concatMapM (locOnly . getLocA) $ cid_datafam_insts decl
1925 , toHie $ cid_datafam_insts decl
1926 , toHie $ cid_overlap_mode decl
1927 ]
1928
1929 instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where
1930 toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d
1931
1932 instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where
1933 toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d
1934
1935 instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where
1936 toHie (C c (FieldOcc n (L l _))) = case hiePass @p of
1937 HieTc -> toHie (C c (L l n))
1938 HieRn -> toHie (C c (L l n))
1939
1940 instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where
1941 toHie (PSC sp (RecordPatSynField a b)) = concatM $
1942 [ toHie $ C (RecField RecFieldDecl sp) a
1943 , toHie $ C Use b
1944 ]
1945
1946 instance ToHie (LocatedA (DerivDecl GhcRn)) where
1947 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
1948 DerivDecl _ typ strat overlap ->
1949 [ toHie $ TS (ResolvedScopes []) typ
1950 , toHie strat
1951 , toHie overlap
1952 ]
1953
1954 instance ToHie (LocatedA (FixitySig GhcRn)) where
1955 toHie (L span sig) = concatM $ makeNodeA sig span : case sig of
1956 FixitySig _ vars _ ->
1957 [ toHie $ map (C Use) vars
1958 ]
1959
1960 instance ToHie (LocatedA (DefaultDecl GhcRn)) where
1961 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
1962 DefaultDecl _ typs ->
1963 [ toHie typs
1964 ]
1965
1966 instance ToHie (LocatedA (ForeignDecl GhcRn)) where
1967 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
1968 ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1969 [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpanA span) name
1970 , toHie $ TS (ResolvedScopes []) sig
1971 , toHie fi
1972 ]
1973 ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1974 [ toHie $ C Use name
1975 , toHie $ TS (ResolvedScopes []) sig
1976 , toHie fe
1977 ]
1978
1979 instance ToHie ForeignImport where
1980 toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $
1981 [ locOnly a
1982 , locOnly b
1983 , locOnly c
1984 ]
1985
1986 instance ToHie ForeignExport where
1987 toHie (CExport (L a _) (L b _)) = concatM $
1988 [ locOnly a
1989 , locOnly b
1990 ]
1991
1992 instance ToHie (LocatedA (WarnDecls GhcRn)) where
1993 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
1994 Warnings _ _ warnings ->
1995 [ toHie warnings
1996 ]
1997
1998 instance ToHie (LocatedA (WarnDecl GhcRn)) where
1999 toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
2000 Warning _ vars _ ->
2001 [ toHie $ map (C Use) vars
2002 ]
2003
2004 instance ToHie (LocatedA (AnnDecl GhcRn)) where
2005 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
2006 HsAnnotation _ _ prov expr ->
2007 [ toHie prov
2008 , toHie expr
2009 ]
2010
2011 instance ToHie (AnnProvenance GhcRn) where
2012 toHie (ValueAnnProvenance a) = toHie $ C Use a
2013 toHie (TypeAnnProvenance a) = toHie $ C Use a
2014 toHie ModuleAnnProvenance = pure []
2015
2016 instance ToHie (LocatedA (RuleDecls GhcRn)) where
2017 toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
2018 HsRules _ _ rules ->
2019 [ toHie rules
2020 ]
2021
2022 instance ToHie (LocatedA (RuleDecl GhcRn)) where
2023 toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
2024 [ makeNodeA r span
2025 , locOnly $ getLocA rname
2026 , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
2027 , toHie $ map (RS $ mkScope (locA span)) bndrs
2028 , toHie exprA
2029 , toHie exprB
2030 ]
2031 where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
2032 bndrs_sc = maybe NoScope mkLScopeA (listToMaybe bndrs)
2033 exprA_sc = mkLScopeA exprA
2034 exprB_sc = mkLScopeA exprB
2035
2036 instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where
2037 toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of
2038 RuleBndr _ var ->
2039 [ toHie $ C (ValBind RegularBind sc Nothing) var
2040 ]
2041 RuleBndrSig _ var typ ->
2042 [ toHie $ C (ValBind RegularBind sc Nothing) var
2043 , toHie $ TS (ResolvedScopes [sc]) typ
2044 ]
2045
2046 instance ToHie (LocatedA (ImportDecl GhcRn)) where
2047 toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
2048 ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
2049 [ toHie $ IEC Import name
2050 , toHie $ fmap (IEC ImportAs) as
2051 , maybe (pure []) goIE hidden
2052 ]
2053 where
2054 goIE (hiding, (L sp liens)) = concatM $
2055 [ locOnly (locA sp)
2056 , toHie $ map (IEC c) liens
2057 ]
2058 where
2059 c = if hiding then ImportHiding else Import
2060
2061 instance ToHie (IEContext (LocatedA (IE GhcRn))) where
2062 toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of
2063 IEVar _ n ->
2064 [ toHie $ IEC c n
2065 ]
2066 IEThingAbs _ n ->
2067 [ toHie $ IEC c n
2068 ]
2069 IEThingAll _ n ->
2070 [ toHie $ IEC c n
2071 ]
2072 IEThingWith flds n _ ns ->
2073 [ toHie $ IEC c n
2074 , toHie $ map (IEC c) ns
2075 , toHie $ map (IEC c) flds
2076 ]
2077 IEModuleContents _ n ->
2078 [ toHie $ IEC c n
2079 ]
2080 IEGroup _ _ _ -> []
2081 IEDoc _ _ -> []
2082 IEDocNamed _ _ -> []
2083
2084 instance ToHie (IEContext (LIEWrappedName Name)) where
2085 toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of
2086 IEName n ->
2087 [ toHie $ C (IEThing c) n
2088 ]
2089 IEPattern _ p ->
2090 [ toHie $ C (IEThing c) p
2091 ]
2092 IEType _ n ->
2093 [ toHie $ C (IEThing c) n
2094 ]
2095
2096 instance ToHie (IEContext (Located FieldLabel)) where
2097 toHie (IEC c (L span lbl)) = concatM
2098 [ makeNode lbl span
2099 , toHie $ C (IEThing c) $ L span (flSelector lbl)
2100 ]