@@ -1,1928 +0,0 @@
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− ]