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