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