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