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