1{- 2(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 3 4\section[RnSource]{Main pass of renamer} 5-} 6 7{-# LANGUAGE CPP #-} 8{-# LANGUAGE ScopedTypeVariables #-} 9{-# LANGUAGE FlexibleContexts #-} 10{-# LANGUAGE TypeFamilies #-} 11{-# LANGUAGE ViewPatterns #-} 12 13module RnSource ( 14 rnSrcDecls, addTcgDUs, findSplice 15 ) where 16 17#include "HsVersions.h" 18 19import GhcPrelude 20 21import {-# SOURCE #-} RnExpr( rnLExpr ) 22import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls ) 23 24import GHC.Hs 25import FieldLabel 26import RdrName 27import RnTypes 28import RnBinds 29import RnEnv 30import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames 31 , checkDupRdrNames, inHsDocContext, bindLocalNamesFV 32 , checkShadowedRdrNames, warnUnusedTypePatterns 33 , extendTyVarEnvFVRn, newLocalBndrsRn 34 , withHsDocContext ) 35import RnUnbound ( mkUnboundName, notInScopeErr ) 36import RnNames 37import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) 38import TcAnnotations ( annCtxt ) 39import TcRnMonad 40 41import ForeignCall ( CCallTarget(..) ) 42import Module 43import HscTypes ( Warnings(..), plusWarns ) 44import PrelNames ( applicativeClassName, pureAName, thenAName 45 , monadClassName, returnMName, thenMName 46 , semigroupClassName, sappendName 47 , monoidClassName, mappendName 48 ) 49import Name 50import NameSet 51import NameEnv 52import Avail 53import Outputable 54import Bag 55import BasicTypes ( pprRuleName, TypeOrKind(..) ) 56import FastString 57import SrcLoc 58import DynFlags 59import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith ) 60import HscTypes ( HscEnv, hsc_dflags ) 61import ListSetOps ( findDupsEq, removeDups, equivClasses ) 62import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..) 63 , stronglyConnCompFromEdgedVerticesUniq ) 64import UniqSet 65import OrdList 66import qualified GHC.LanguageExtensions as LangExt 67 68import Control.Monad 69import Control.Arrow ( first ) 70import Data.List ( mapAccumL ) 71import qualified Data.List.NonEmpty as NE 72import Data.List.NonEmpty ( NonEmpty(..) ) 73import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) 74import qualified Data.Set as Set ( difference, fromList, toList, null ) 75import Data.Function ( on ) 76 77{- | @rnSourceDecl@ "renames" declarations. 78It simultaneously performs dependency analysis and precedence parsing. 79It also does the following error checks: 80 81* Checks that tyvars are used properly. This includes checking 82 for undefined tyvars, and tyvars in contexts that are ambiguous. 83 (Some of this checking has now been moved to module @TcMonoType@, 84 since we don't have functional dependency information at this point.) 85 86* Checks that all variable occurrences are defined. 87 88* Checks the @(..)@ etc constraints in the export list. 89 90Brings the binders of the group into scope in the appropriate places; 91does NOT assume that anything is in scope already 92-} 93rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) 94-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files 95rnSrcDecls group@(HsGroup { hs_valds = val_decls, 96 hs_splcds = splice_decls, 97 hs_tyclds = tycl_decls, 98 hs_derivds = deriv_decls, 99 hs_fixds = fix_decls, 100 hs_warnds = warn_decls, 101 hs_annds = ann_decls, 102 hs_fords = foreign_decls, 103 hs_defds = default_decls, 104 hs_ruleds = rule_decls, 105 hs_docs = docs }) 106 = do { 107 -- (A) Process the fixity declarations, creating a mapping from 108 -- FastStrings to FixItems. 109 -- Also checks for duplicates. 110 local_fix_env <- makeMiniFixityEnv fix_decls ; 111 112 -- (B) Bring top level binders (and their fixities) into scope, 113 -- *except* for the value bindings, which get done in step (D) 114 -- with collectHsIdBinders. However *do* include 115 -- 116 -- * Class ops, data constructors, and record fields, 117 -- because they do not have value declarations. 118 -- 119 -- * For hs-boot files, include the value signatures 120 -- Again, they have no value declarations 121 -- 122 (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; 123 124 125 setEnvs tc_envs $ do { 126 127 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations 128 129 -- (D1) Bring pattern synonyms into scope. 130 -- Need to do this before (D2) because rnTopBindsLHS 131 -- looks up those pattern synonyms (#9889) 132 133 extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { 134 135 -- (D2) Rename the left-hand sides of the value bindings. 136 -- This depends on everything from (B) being in scope. 137 -- It uses the fixity env from (A) to bind fixities for view patterns. 138 new_lhs <- rnTopBindsLHS local_fix_env val_decls ; 139 140 -- Bind the LHSes (and their fixities) in the global rdr environment 141 let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders 142 -- They are already in scope 143 traceRn "rnSrcDecls" (ppr id_bndrs) ; 144 tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; 145 setEnvs tc_envs $ do { 146 147 -- Now everything is in scope, as the remaining renaming assumes. 148 149 -- (E) Rename type and class decls 150 -- (note that value LHSes need to be in scope for default methods) 151 -- 152 -- You might think that we could build proper def/use information 153 -- for type and class declarations, but they can be involved 154 -- in mutual recursion across modules, and we only do the SCC 155 -- analysis for them in the type checker. 156 -- So we content ourselves with gathering uses only; that 157 -- means we'll only report a declaration as unused if it isn't 158 -- mentioned at all. Ah well. 159 traceRn "Start rnTyClDecls" (ppr tycl_decls) ; 160 (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; 161 162 -- (F) Rename Value declarations right-hand sides 163 traceRn "Start rnmono" empty ; 164 let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; 165 is_boot <- tcIsHsBootOrSig ; 166 (rn_val_decls, bind_dus) <- if is_boot 167 -- For an hs-boot, use tc_bndrs (which collects how we're renamed 168 -- signatures), since val_bndr_set is empty (there are no x = ... 169 -- bindings in an hs-boot.) 170 then rnTopBindsBoot tc_bndrs new_lhs 171 else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; 172 traceRn "finish rnmono" (ppr rn_val_decls) ; 173 174 -- (G) Rename Fixity and deprecations 175 176 -- Rename fixity declarations and error if we try to 177 -- fix something from another module (duplicates were checked in (A)) 178 let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; 179 rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) 180 fix_decls ; 181 182 -- Rename deprec decls; 183 -- check for duplicates and ensure that deprecated things are defined locally 184 -- at the moment, we don't keep these around past renaming 185 rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; 186 187 -- (H) Rename Everything else 188 189 (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ 190 rnList rnHsRuleDecls rule_decls ; 191 -- Inside RULES, scoped type variables are on 192 (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; 193 (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; 194 (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; 195 (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; 196 (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; 197 -- Haddock docs; no free vars 198 rn_docs <- mapM (wrapLocM rnDocDecl) docs ; 199 200 last_tcg_env <- getGblEnv ; 201 -- (I) Compute the results and return 202 let {rn_group = HsGroup { hs_ext = noExtField, 203 hs_valds = rn_val_decls, 204 hs_splcds = rn_splice_decls, 205 hs_tyclds = rn_tycl_decls, 206 hs_derivds = rn_deriv_decls, 207 hs_fixds = rn_fix_decls, 208 hs_warnds = [], -- warns are returned in the tcg_env 209 -- (see below) not in the HsGroup 210 hs_fords = rn_foreign_decls, 211 hs_annds = rn_ann_decls, 212 hs_defds = rn_default_decls, 213 hs_ruleds = rn_rule_decls, 214 hs_docs = rn_docs } ; 215 216 tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; 217 other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; 218 other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 219 src_fvs5, src_fvs6, src_fvs7] ; 220 -- It is tiresome to gather the binders from type and class decls 221 222 src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; 223 -- Instance decls may have occurrences of things bound in bind_dus 224 -- so we must put other_fvs last 225 226 final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) 227 in -- we return the deprecs in the env, not in the HsGroup above 228 tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; 229 } ; 230 traceRn "finish rnSrc" (ppr rn_group) ; 231 traceRn "finish Dus" (ppr src_dus ) ; 232 return (final_tcg_env, rn_group) 233 }}}} 234rnSrcDecls (XHsGroup nec) = noExtCon nec 235 236addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 237-- This function could be defined lower down in the module hierarchy, 238-- but there doesn't seem anywhere very logical to put it. 239addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } 240 241rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) 242rnList f xs = mapFvRn (wrapLocFstM f) xs 243 244{- 245********************************************************* 246* * 247 HsDoc stuff 248* * 249********************************************************* 250-} 251 252rnDocDecl :: DocDecl -> RnM DocDecl 253rnDocDecl (DocCommentNext doc) = do 254 rn_doc <- rnHsDoc doc 255 return (DocCommentNext rn_doc) 256rnDocDecl (DocCommentPrev doc) = do 257 rn_doc <- rnHsDoc doc 258 return (DocCommentPrev rn_doc) 259rnDocDecl (DocCommentNamed str doc) = do 260 rn_doc <- rnHsDoc doc 261 return (DocCommentNamed str rn_doc) 262rnDocDecl (DocGroup lev doc) = do 263 rn_doc <- rnHsDoc doc 264 return (DocGroup lev rn_doc) 265 266{- 267********************************************************* 268* * 269 Source-code deprecations declarations 270* * 271********************************************************* 272 273Check that the deprecated names are defined, are defined locally, and 274that there are no duplicate deprecations. 275 276It's only imported deprecations, dealt with in RnIfaces, that we 277gather them together. 278-} 279 280-- checks that the deprecations are defined locally, and that there are no duplicates 281rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings 282rnSrcWarnDecls _ [] 283 = return NoWarnings 284 285rnSrcWarnDecls bndr_set decls' 286 = do { -- check for duplicates 287 ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups 288 in addErrAt loc (dupWarnDecl lrdr' rdr)) 289 warn_rdr_dups 290 ; pairs_s <- mapM (addLocM rn_deprec) decls 291 ; return (WarnSome ((concat pairs_s))) } 292 where 293 decls = concatMap (wd_warnings . unLoc) decls' 294 295 sig_ctxt = TopSigCtxt bndr_set 296 297 rn_deprec (Warning _ rdr_names txt) 298 -- ensures that the names are defined locally 299 = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) 300 rdr_names 301 ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } 302 rn_deprec (XWarnDecl nec) = noExtCon nec 303 304 what = text "deprecation" 305 306 warn_rdr_dups = findDupRdrNames 307 $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls 308 309findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] 310findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) 311 312-- look for duplicates among the OccNames; 313-- we check that the names are defined above 314-- invt: the lists returned by findDupsEq always have at least two elements 315 316dupWarnDecl :: Located RdrName -> RdrName -> SDoc 317-- Located RdrName -> DeprecDecl RdrName -> SDoc 318dupWarnDecl d rdr_name 319 = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), 320 text "also at " <+> ppr (getLoc d)] 321 322{- 323********************************************************* 324* * 325\subsection{Annotation declarations} 326* * 327********************************************************* 328-} 329 330rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) 331rnAnnDecl ann@(HsAnnotation _ s provenance expr) 332 = addErrCtxt (annCtxt ann) $ 333 do { (provenance', provenance_fvs) <- rnAnnProvenance provenance 334 ; (expr', expr_fvs) <- setStage (Splice Untyped) $ 335 rnLExpr expr 336 ; return (HsAnnotation noExtField s provenance' expr', 337 provenance_fvs `plusFV` expr_fvs) } 338rnAnnDecl (XAnnDecl nec) = noExtCon nec 339 340rnAnnProvenance :: AnnProvenance RdrName 341 -> RnM (AnnProvenance Name, FreeVars) 342rnAnnProvenance provenance = do 343 provenance' <- traverse lookupTopBndrRn provenance 344 return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) 345 346{- 347********************************************************* 348* * 349\subsection{Default declarations} 350* * 351********************************************************* 352-} 353 354rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) 355rnDefaultDecl (DefaultDecl _ tys) 356 = do { (tys', fvs) <- rnLHsTypes doc_str tys 357 ; return (DefaultDecl noExtField tys', fvs) } 358 where 359 doc_str = DefaultDeclCtx 360rnDefaultDecl (XDefaultDecl nec) = noExtCon nec 361 362{- 363********************************************************* 364* * 365\subsection{Foreign declarations} 366* * 367********************************************************* 368-} 369 370rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) 371rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) 372 = do { topEnv :: HscEnv <- getTopEnv 373 ; name' <- lookupLocatedTopBndrRn name 374 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty 375 376 -- Mark any PackageTarget style imports as coming from the current package 377 ; let unitId = thisPackage $ hsc_dflags topEnv 378 spec' = patchForeignImport unitId spec 379 380 ; return (ForeignImport { fd_i_ext = noExtField 381 , fd_name = name', fd_sig_ty = ty' 382 , fd_fi = spec' }, fvs) } 383 384rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) 385 = do { name' <- lookupLocatedOccRn name 386 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty 387 ; return (ForeignExport { fd_e_ext = noExtField 388 , fd_name = name', fd_sig_ty = ty' 389 , fd_fe = spec } 390 , fvs `addOneFV` unLoc name') } 391 -- NB: a foreign export is an *occurrence site* for name, so 392 -- we add it to the free-variable list. It might, for example, 393 -- be imported from another module 394 395rnHsForeignDecl (XForeignDecl nec) = noExtCon nec 396 397-- | For Windows DLLs we need to know what packages imported symbols are from 398-- to generate correct calls. Imported symbols are tagged with the current 399-- package, so if they get inlined across a package boundary we'll still 400-- know where they're from. 401-- 402patchForeignImport :: UnitId -> ForeignImport -> ForeignImport 403patchForeignImport unitId (CImport cconv safety fs spec src) 404 = CImport cconv safety fs (patchCImportSpec unitId spec) src 405 406patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec 407patchCImportSpec unitId spec 408 = case spec of 409 CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget 410 _ -> spec 411 412patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget 413patchCCallTarget unitId callTarget = 414 case callTarget of 415 StaticTarget src label Nothing isFun 416 -> StaticTarget src label (Just unitId) isFun 417 _ -> callTarget 418 419{- 420********************************************************* 421* * 422\subsection{Instance declarations} 423* * 424********************************************************* 425-} 426 427rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) 428rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) 429 = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi 430 ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } 431 432rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) 433 = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi 434 ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } 435 436rnSrcInstDecl (ClsInstD { cid_inst = cid }) 437 = do { traceRn "rnSrcIstDecl {" (ppr cid) 438 ; (cid', fvs) <- rnClsInstDecl cid 439 ; traceRn "rnSrcIstDecl end }" empty 440 ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } 441 442rnSrcInstDecl (XInstDecl nec) = noExtCon nec 443 444-- | Warn about non-canonical typeclass instance declarations 445-- 446-- A "non-canonical" instance definition can occur for instances of a 447-- class which redundantly defines an operation its superclass 448-- provides as well (c.f. `return`/`pure`). In such cases, a canonical 449-- instance is one where the subclass inherits its method 450-- implementation from its superclass instance (usually the subclass 451-- has a default method implementation to that effect). Consequently, 452-- a non-canonical instance occurs when this is not the case. 453-- 454-- See also descriptions of 'checkCanonicalMonadInstances' and 455-- 'checkCanonicalMonoidInstances' 456checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () 457checkCanonicalInstances cls poly_ty mbinds = do 458 whenWOptM Opt_WarnNonCanonicalMonadInstances 459 checkCanonicalMonadInstances 460 461 whenWOptM Opt_WarnNonCanonicalMonoidInstances 462 checkCanonicalMonoidInstances 463 464 where 465 -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance 466 -- declarations. Specifically, the following conditions are verified: 467 -- 468 -- In 'Monad' instances declarations: 469 -- 470 -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) 471 -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) 472 -- 473 -- In 'Applicative' instance declarations: 474 -- 475 -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). 476 -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). 477 -- 478 checkCanonicalMonadInstances 479 | cls == applicativeClassName = do 480 forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do 481 case mbind of 482 FunBind { fun_id = (dL->L _ name) 483 , fun_matches = mg } 484 | name == pureAName, isAliasMG mg == Just returnMName 485 -> addWarnNonCanonicalMethod1 486 Opt_WarnNonCanonicalMonadInstances "pure" "return" 487 488 | name == thenAName, isAliasMG mg == Just thenMName 489 -> addWarnNonCanonicalMethod1 490 Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" 491 492 _ -> return () 493 494 | cls == monadClassName = do 495 forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do 496 case mbind of 497 FunBind { fun_id = (dL->L _ name) 498 , fun_matches = mg } 499 | name == returnMName, isAliasMG mg /= Just pureAName 500 -> addWarnNonCanonicalMethod2 501 Opt_WarnNonCanonicalMonadInstances "return" "pure" 502 503 | name == thenMName, isAliasMG mg /= Just thenAName 504 -> addWarnNonCanonicalMethod2 505 Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" 506 507 _ -> return () 508 509 | otherwise = return () 510 511 -- | Check whether Monoid(mappend) is defined in terms of 512 -- Semigroup((<>)) (and not the other way round). Specifically, 513 -- the following conditions are verified: 514 -- 515 -- In 'Monoid' instances declarations: 516 -- 517 -- * If 'mappend' is overridden it must be canonical 518 -- (i.e. @mappend = (<>)@) 519 -- 520 -- In 'Semigroup' instance declarations: 521 -- 522 -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). 523 -- 524 checkCanonicalMonoidInstances 525 | cls == semigroupClassName = do 526 forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do 527 case mbind of 528 FunBind { fun_id = (dL->L _ name) 529 , fun_matches = mg } 530 | name == sappendName, isAliasMG mg == Just mappendName 531 -> addWarnNonCanonicalMethod1 532 Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" 533 534 _ -> return () 535 536 | cls == monoidClassName = do 537 forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do 538 case mbind of 539 FunBind { fun_id = (dL->L _ name) 540 , fun_matches = mg } 541 | name == mappendName, isAliasMG mg /= Just sappendName 542 -> addWarnNonCanonicalMethod2NoDefault 543 Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" 544 545 _ -> return () 546 547 | otherwise = return () 548 549 -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" 550 -- binding, and return @Just rhsName@ if this is the case 551 isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name 552 isAliasMG MG {mg_alts = (dL->L _ 553 [dL->L _ (Match { m_pats = [] 554 , m_grhss = grhss })])} 555 | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss 556 , EmptyLocalBinds _ <- unLoc lbinds 557 , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) 558 isAliasMG _ = Nothing 559 560 -- got "lhs = rhs" but expected something different 561 addWarnNonCanonicalMethod1 flag lhs rhs = do 562 addWarn (Reason flag) $ vcat 563 [ text "Noncanonical" <+> 564 quotes (text (lhs ++ " = " ++ rhs)) <+> 565 text "definition detected" 566 , instDeclCtxt1 poly_ty 567 , text "Move definition from" <+> 568 quotes (text rhs) <+> 569 text "to" <+> quotes (text lhs) 570 ] 571 572 -- expected "lhs = rhs" but got something else 573 addWarnNonCanonicalMethod2 flag lhs rhs = do 574 addWarn (Reason flag) $ vcat 575 [ text "Noncanonical" <+> 576 quotes (text lhs) <+> 577 text "definition detected" 578 , instDeclCtxt1 poly_ty 579 , text "Either remove definition for" <+> 580 quotes (text lhs) <+> text "or define as" <+> 581 quotes (text (lhs ++ " = " ++ rhs)) 582 ] 583 584 -- like above, but method has no default impl 585 addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do 586 addWarn (Reason flag) $ vcat 587 [ text "Noncanonical" <+> 588 quotes (text lhs) <+> 589 text "definition detected" 590 , instDeclCtxt1 poly_ty 591 , text "Define as" <+> 592 quotes (text (lhs ++ " = " ++ rhs)) 593 ] 594 595 -- stolen from TcInstDcls 596 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc 597 instDeclCtxt1 hs_inst_ty 598 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) 599 600 inst_decl_ctxt :: SDoc -> SDoc 601 inst_decl_ctxt doc = hang (text "in the instance declaration for") 602 2 (quotes doc <> text ".") 603 604 605rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) 606rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds 607 , cid_sigs = uprags, cid_tyfam_insts = ats 608 , cid_overlap_mode = oflag 609 , cid_datafam_insts = adts }) 610 = do { (inst_ty', inst_fvs) 611 <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty 612 ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' 613 ; cls <- 614 case hsTyGetAppHead_maybe head_ty' of 615 Just (dL->L _ cls) -> pure cls 616 Nothing -> do 617 -- The instance is malformed. We'd still like 618 -- to make *some* progress (rather than failing outright), so 619 -- we report an error and continue for as long as we can. 620 -- Importantly, this error should be thrown before we reach the 621 -- typechecker, lest we encounter different errors that are 622 -- hopelessly confusing (such as the one in #16114). 623 addErrAt (getLoc (hsSigType inst_ty)) $ 624 hang (text "Illegal class instance:" <+> quotes (ppr inst_ty)) 625 2 (vcat [ text "Class instances must be of the form" 626 , nest 2 $ text "context => C ty_1 ... ty_n" 627 , text "where" <+> quotes (char 'C') 628 <+> text "is a class" 629 ]) 630 pure $ mkUnboundName (mkTcOccFS (fsLit "<class>")) 631 632 -- Rename the bindings 633 -- The typechecker (not the renamer) checks that all 634 -- the bindings are for the right class 635 -- (Slightly strangely) when scoped type variables are on, the 636 -- forall-d tyvars scope over the method bindings too 637 ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags 638 639 ; checkCanonicalInstances cls inst_ty' mbinds' 640 641 -- Rename the associated types, and type signatures 642 -- Both need to have the instance type variables in scope 643 ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) 644 ; ((ats', adts'), more_fvs) 645 <- extendTyVarEnvFVRn ktv_names $ 646 do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats 647 ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts 648 ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } 649 650 ; let all_fvs = meth_fvs `plusFV` more_fvs 651 `plusFV` inst_fvs 652 ; return (ClsInstDecl { cid_ext = noExtField 653 , cid_poly_ty = inst_ty', cid_binds = mbinds' 654 , cid_sigs = uprags', cid_tyfam_insts = ats' 655 , cid_overlap_mode = oflag 656 , cid_datafam_insts = adts' }, 657 all_fvs) } 658 -- We return the renamed associated data type declarations so 659 -- that they can be entered into the list of type declarations 660 -- for the binding group, but we also keep a copy in the instance. 661 -- The latter is needed for well-formedness checks in the type 662 -- checker (eg, to ensure that all ATs of the instance actually 663 -- receive a declaration). 664 -- NB: Even the copies in the instance declaration carry copies of 665 -- the instance context after renaming. This is a bit 666 -- strange, but should not matter (and it would be more work 667 -- to remove the context). 668rnClsInstDecl (XClsInstDecl nec) = noExtCon nec 669 670rnFamInstEqn :: HsDocContext 671 -> AssocTyFamInfo 672 -> [Located RdrName] -- Kind variables from the equation's RHS 673 -> FamInstEqn GhcPs rhs 674 -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) 675 -> RnM (FamInstEqn GhcRn rhs', FreeVars) 676rnFamInstEqn doc atfi rhs_kvars 677 (HsIB { hsib_body = FamEqn { feqn_tycon = tycon 678 , feqn_bndrs = mb_bndrs 679 , feqn_pats = pats 680 , feqn_fixity = fixity 681 , feqn_rhs = payload }}) rn_payload 682 = do { let mb_cls = case atfi of 683 NonAssocTyFamEqn -> Nothing 684 AssocTyFamDeflt cls -> Just cls 685 AssocTyFamInst cls _ -> Just cls 686 ; tycon' <- lookupFamInstName mb_cls tycon 687 ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats 688 -- Use the "...Dups" form because it's needed 689 -- below to report unsed binder on the LHS 690 691 -- Implicitly bound variables, empty if we have an explicit 'forall' according 692 -- to the "forall-or-nothing" rule. 693 ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups 694 | otherwise = [] 695 ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars 696 697 ; let bndrs = fromMaybe [] mb_bndrs 698 bnd_vars = map hsLTyVarLocName bndrs 699 payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars 700 -- Make sure to filter out the kind variables that were explicitly 701 -- bound in the type patterns. 702 ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars 703 704 -- all names not bound in an explict forall 705 ; let all_imp_var_names = imp_var_names ++ payload_kvar_names 706 707 -- All the free vars of the family patterns 708 -- with a sensible binding location 709 ; ((bndrs', pats', payload'), fvs) 710 <- bindLocalNamesFV all_imp_var_names $ 711 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc) 712 Nothing bndrs $ \bndrs' -> 713 -- Note: If we pass mb_cls instead of Nothing here, 714 -- bindLHsTyVarBndrs will use class variables for any names 715 -- the user meant to bring in scope here. This is an explicit 716 -- forall, so we want fresh names, not class variables. 717 -- Thus: always pass Nothing 718 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats 719 ; (payload', rhs_fvs) <- rn_payload doc payload 720 721 -- Report unused binders on the LHS 722 -- See Note [Unused type variables in family instances] 723 ; let groups :: [NonEmpty (Located RdrName)] 724 groups = equivClasses cmpLocated $ 725 pat_kity_vars_with_dups 726 ; nms_dups <- mapM (lookupOccRn . unLoc) $ 727 [ tv | (tv :| (_:_)) <- groups ] 728 -- Add to the used variables 729 -- a) any variables that appear *more than once* on the LHS 730 -- e.g. F a Int a = Bool 731 -- b) for associated instances, the variables 732 -- of the instance decl. See 733 -- Note [Unused type variables in family instances] 734 ; let nms_used = extendNameSetList rhs_fvs $ 735 inst_tvs ++ nms_dups 736 inst_tvs = case atfi of 737 NonAssocTyFamEqn -> [] 738 AssocTyFamDeflt _ -> [] 739 AssocTyFamInst _ inst_tvs -> inst_tvs 740 all_nms = all_imp_var_names ++ hsLTyVarNames bndrs' 741 ; warnUnusedTypePatterns all_nms nms_used 742 743 ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) } 744 745 ; let all_fvs = fvs `addOneFV` unLoc tycon' 746 -- type instance => use, hence addOneFV 747 748 ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] 749 , hsib_body 750 = FamEqn { feqn_ext = noExtField 751 , feqn_tycon = tycon' 752 , feqn_bndrs = bndrs' <$ mb_bndrs 753 , feqn_pats = pats' 754 , feqn_fixity = fixity 755 , feqn_rhs = payload' } }, 756 all_fvs) } 757rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec 758rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec 759 760rnTyFamInstDecl :: AssocTyFamInfo 761 -> TyFamInstDecl GhcPs 762 -> RnM (TyFamInstDecl GhcRn, FreeVars) 763rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn }) 764 = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn 765 ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } 766 767-- | Tracks whether we are renaming: 768-- 769-- 1. A type family equation that is not associated 770-- with a parent type class ('NonAssocTyFamEqn') 771-- 772-- 2. An associated type family default delcaration ('AssocTyFamDeflt') 773-- 774-- 3. An associated type family instance declaration ('AssocTyFamInst') 775data AssocTyFamInfo 776 = NonAssocTyFamEqn 777 | AssocTyFamDeflt Name -- Name of the parent class 778 | AssocTyFamInst Name -- Name of the parent class 779 [Name] -- Names of the tyvars of the parent instance decl 780 781-- | Tracks whether we are renaming an equation in a closed type family 782-- equation ('ClosedTyFam') or not ('NotClosedTyFam'). 783data ClosedTyFamInfo 784 = NotClosedTyFam 785 | ClosedTyFam (Located RdrName) Name 786 -- The names (RdrName and Name) of the closed type family 787 788rnTyFamInstEqn :: AssocTyFamInfo 789 -> ClosedTyFamInfo 790 -> TyFamInstEqn GhcPs 791 -> RnM (TyFamInstEqn GhcRn, FreeVars) 792rnTyFamInstEqn atfi ctf_info 793 eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon 794 , feqn_rhs = rhs }}) 795 = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs 796 ; (eqn'@(HsIB { hsib_body = 797 FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs) 798 <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn 799 ; case ctf_info of 800 NotClosedTyFam -> pure () 801 ClosedTyFam fam_rdr_name fam_name -> 802 checkTc (fam_name == tycon') $ 803 withHsDocContext (TyFamilyCtx fam_rdr_name) $ 804 wrongTyFamName fam_name tycon' 805 ; pure (eqn', fvs) } 806rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec 807rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec 808 809rnTyFamDefltDecl :: Name 810 -> TyFamDefltDecl GhcPs 811 -> RnM (TyFamDefltDecl GhcRn, FreeVars) 812rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) 813 814rnDataFamInstDecl :: AssocTyFamInfo 815 -> DataFamInstDecl GhcPs 816 -> RnM (DataFamInstDecl GhcRn, FreeVars) 817rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body = 818 FamEqn { feqn_tycon = tycon 819 , feqn_rhs = rhs }})}) 820 = do { let rhs_kvs = extractDataDefnKindVars rhs 821 ; (eqn', fvs) <- 822 rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn 823 ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } 824rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec))) 825 = noExtCon nec 826rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec)) 827 = noExtCon nec 828 829-- Renaming of the associated types in instances. 830 831-- Rename associated type family decl in class 832rnATDecls :: Name -- Class 833 -> [LFamilyDecl GhcPs] 834 -> RnM ([LFamilyDecl GhcRn], FreeVars) 835rnATDecls cls at_decls 836 = rnList (rnFamDecl (Just cls)) at_decls 837 838rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames 839 decl GhcPs -> -- an instance. rnTyFamInstDecl 840 RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl 841 -> Name -- Class 842 -> [Name] 843 -> [Located (decl GhcPs)] 844 -> RnM ([Located (decl GhcRn)], FreeVars) 845-- Used for data and type family defaults in a class decl 846-- and the family instance declarations in an instance 847-- 848-- NB: We allow duplicate associated-type decls; 849-- See Note [Associated type instances] in TcInstDcls 850rnATInstDecls rnFun cls tv_ns at_insts 851 = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts 852 -- See Note [Renaming associated types] 853 854{- Note [Wildcards in family instances] 855~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 856Wild cards can be used in type/data family instance declarations to indicate 857that the name of a type variable doesn't matter. Each wild card will be 858replaced with a new unique type variable. For instance: 859 860 type family F a b :: * 861 type instance F Int _ = Int 862 863is the same as 864 865 type family F a b :: * 866 type instance F Int b = Int 867 868This is implemented as follows: Unnamed wildcards remain unchanged after 869the renamer, and then given fresh meta-variables during typechecking, and 870it is handled pretty much the same way as the ones in partial type signatures. 871We however don't want to emit hole constraints on wildcards in family 872instances, so we turn on PartialTypeSignatures and turn off warning flag to 873let typechecker know this. 874See related Note [Wildcards in visible kind application] in TcHsType.hs 875 876Note [Unused type variables in family instances] 877~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 878When the flag -fwarn-unused-type-patterns is on, the compiler reports 879warnings about unused type variables in type-family instances. A 880tpye variable is considered used (i.e. cannot be turned into a wildcard) 881when 882 883 * it occurs on the RHS of the family instance 884 e.g. type instance F a b = a -- a is used on the RHS 885 886 * it occurs multiple times in the patterns on the LHS 887 e.g. type instance F a a = Int -- a appears more than once on LHS 888 889 * it is one of the instance-decl variables, for associated types 890 e.g. instance C (a,b) where 891 type T (a,b) = a 892 Here the type pattern in the type instance must be the same as that 893 for the class instance, so 894 type T (a,_) = a 895 would be rejected. So we should not complain about an unused variable b 896 897As usual, the warnings are not reported for type variables with names 898beginning with an underscore. 899 900Extra-constraints wild cards are not supported in type/data family 901instance declarations. 902 903Relevant tickets: #3699, #10586, #10982 and #11451. 904 905Note [Renaming associated types] 906~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 907Check that the RHS of the decl mentions only type variables that are explicitly 908bound on the LHS. For example, this is not ok 909 class C a b where 910 type F a x :: * 911 instance C (p,q) r where 912 type F (p,q) x = (x, r) -- BAD: mentions 'r' 913c.f. #5515 914 915Kind variables, on the other hand, are allowed to be implicitly or explicitly 916bound. As examples, this (#9574) is acceptable: 917 class Funct f where 918 type Codomain f :: * 919 instance Funct ('KProxy :: KProxy o) where 920 -- o is implicitly bound by the kind signature 921 -- of the LHS type pattern ('KProxy) 922 type Codomain 'KProxy = NatTr (Proxy :: o -> *) 923And this (#14131) is also acceptable: 924 data family Nat :: k -> k -> * 925 -- k is implicitly bound by an invisible kind pattern 926 newtype instance Nat :: (k -> *) -> (k -> *) -> * where 927 Nat :: (forall xx. f xx -> g xx) -> Nat f g 928We could choose to disallow this, but then associated type families would not 929be able to be as expressive as top-level type synonyms. For example, this type 930synonym definition is allowed: 931 type T = (Nothing :: Maybe a) 932So for parity with type synonyms, we also allow: 933 type family T :: Maybe a 934 type instance T = (Nothing :: Maybe a) 935 936All this applies only for *instance* declarations. In *class* 937declarations there is no RHS to worry about, and the class variables 938can all be in scope (#5862): 939 class Category (x :: k -> k -> *) where 940 type Ob x :: k -> Constraint 941 id :: Ob x a => x a a 942 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c 943Here 'k' is in scope in the kind signature, just like 'x'. 944 945Although type family equations can bind type variables with explicit foralls, 946it need not be the case that all variables that appear on the RHS must be bound 947by a forall. For instance, the following is acceptable: 948 949 class C a where 950 type T a b 951 instance C (Maybe a) where 952 type forall b. T (Maybe a) b = Either a b 953 954Even though `a` is not bound by the forall, this is still accepted because `a` 955was previously bound by the `instance C (Maybe a)` part. (see #16116). 956 957In each case, the function which detects improperly bound variables on the RHS 958is TcValidity.checkValidFamPats. 959-} 960 961 962{- 963********************************************************* 964* * 965\subsection{Stand-alone deriving declarations} 966* * 967********************************************************* 968-} 969 970rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) 971rnSrcDerivDecl (DerivDecl _ ty mds overlap) 972 = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving 973 ; unless standalone_deriv_ok (addErr standaloneDerivErr) 974 ; (mds', ty', fvs) 975 <- rnLDerivStrategy DerivDeclCtx mds $ 976 rnHsSigWcType BindUnlessForall DerivDeclCtx ty 977 ; warnNoDerivStrat mds' loc 978 ; return (DerivDecl noExtField ty' mds' overlap, fvs) } 979 where 980 loc = getLoc $ hsib_body $ hswc_body ty 981rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec 982 983standaloneDerivErr :: SDoc 984standaloneDerivErr 985 = hang (text "Illegal standalone deriving declaration") 986 2 (text "Use StandaloneDeriving to enable this extension") 987 988{- 989********************************************************* 990* * 991\subsection{Rules} 992* * 993********************************************************* 994-} 995 996rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) 997rnHsRuleDecls (HsRules { rds_src = src 998 , rds_rules = rules }) 999 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules 1000 ; return (HsRules { rds_ext = noExtField 1001 , rds_src = src 1002 , rds_rules = rn_rules }, fvs) } 1003rnHsRuleDecls (XRuleDecls nec) = noExtCon nec 1004 1005rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) 1006rnHsRuleDecl (HsRule { rd_name = rule_name 1007 , rd_act = act 1008 , rd_tyvs = tyvs 1009 , rd_tmvs = tmvs 1010 , rd_lhs = lhs 1011 , rd_rhs = rhs }) 1012 = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs 1013 ; checkDupRdrNames rdr_names_w_loc 1014 ; checkShadowedRdrNames rdr_names_w_loc 1015 ; names <- newLocalBndrsRn rdr_names_w_loc 1016 ; let doc = RuleCtx (snd $ unLoc rule_name) 1017 ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' -> 1018 bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> 1019 do { (lhs', fv_lhs') <- rnLExpr lhs 1020 ; (rhs', fv_rhs') <- rnLExpr rhs 1021 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' 1022 ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs' 1023 , rd_name = rule_name 1024 , rd_act = act 1025 , rd_tyvs = tyvs' 1026 , rd_tmvs = tmvs' 1027 , rd_lhs = lhs' 1028 , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } 1029 where 1030 get_var (RuleBndrSig _ v _) = v 1031 get_var (RuleBndr _ v) = v 1032 get_var (XRuleBndr nec) = noExtCon nec 1033 in_rule = text "in the rule" <+> pprFullRuleName rule_name 1034rnHsRuleDecl (XRuleDecl nec) = noExtCon nec 1035 1036bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs 1037 -> [LRuleBndr GhcPs] -> [Name] 1038 -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) 1039 -> RnM (a, FreeVars) 1040bindRuleTmVars doc tyvs vars names thing_inside 1041 = go vars names $ \ vars' -> 1042 bindLocalNamesFV names (thing_inside vars') 1043 where 1044 go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside 1045 = go vars ns $ \ vars' -> 1046 thing_inside (cL l (RuleBndr noExtField (cL loc n)) : vars') 1047 1048 go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars) 1049 (n : ns) thing_inside 1050 = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> 1051 go vars ns $ \ vars' -> 1052 thing_inside (cL l (RuleBndrSig noExtField (cL loc n) bsig') : vars') 1053 1054 go [] [] thing_inside = thing_inside [] 1055 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) 1056 1057 bind_free_tvs = case tyvs of Nothing -> AlwaysBind 1058 Just _ -> NeverBind 1059 1060bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs] 1061 -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) 1062 -> RnM (b, FreeVars) 1063bindRuleTyVars doc in_doc (Just bndrs) thing_inside 1064 = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just) 1065bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing 1066 1067{- 1068Note [Rule LHS validity checking] 1069~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1070Check the shape of a transformation rule LHS. Currently we only allow 1071LHSs of the form @(f e1 .. en)@, where @f@ is not one of the 1072@forall@'d variables. 1073 1074We used restrict the form of the 'ei' to prevent you writing rules 1075with LHSs with a complicated desugaring (and hence unlikely to match); 1076(e.g. a case expression is not allowed: too elaborate.) 1077 1078But there are legitimate non-trivial args ei, like sections and 1079lambdas. So it seems simmpler not to check at all, and that is why 1080check_e is commented out. 1081-} 1082 1083checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () 1084checkValidRule rule_name ids lhs' fv_lhs' 1085 = do { -- Check for the form of the LHS 1086 case (validRuleLhs ids lhs') of 1087 Nothing -> return () 1088 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) 1089 1090 -- Check that LHS vars are all bound 1091 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] 1092 ; mapM_ (addErr . badRuleVar rule_name) bad_vars } 1093 1094validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) 1095-- Nothing => OK 1096-- Just e => Not ok, and e is the offending sub-expression 1097validRuleLhs foralls lhs 1098 = checkl lhs 1099 where 1100 checkl = check . unLoc 1101 1102 check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 1103 `mplus` checkl_e e2 1104 check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 1105 check (HsAppType _ e _) = checkl e 1106 check (HsVar _ lv) 1107 | (unLoc lv) `notElem` foralls = Nothing 1108 check other = Just other -- Failure 1109 1110 -- Check an argument 1111 checkl_e _ = Nothing 1112 -- Was (check_e e); see Note [Rule LHS validity checking] 1113 1114{- Commented out; see Note [Rule LHS validity checking] above 1115 check_e (HsVar v) = Nothing 1116 check_e (HsPar e) = checkl_e e 1117 check_e (HsLit e) = Nothing 1118 check_e (HsOverLit e) = Nothing 1119 1120 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 1121 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 1122 check_e (NegApp e _) = checkl_e e 1123 check_e (ExplicitList _ es) = checkl_es es 1124 check_e other = Just other -- Fails 1125 1126 checkl_es es = foldr (mplus . checkl_e) Nothing es 1127-} 1128 1129badRuleVar :: FastString -> Name -> SDoc 1130badRuleVar name var 1131 = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, 1132 text "Forall'd variable" <+> quotes (ppr var) <+> 1133 text "does not appear on left hand side"] 1134 1135badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc 1136badRuleLhsErr name lhs bad_e 1137 = sep [text "Rule" <+> pprRuleName name <> colon, 1138 nest 2 (vcat [err, 1139 text "in left-hand side:" <+> ppr lhs])] 1140 $$ 1141 text "LHS must be of form (f e1 .. en) where f is not forall'd" 1142 where 1143 err = case bad_e of 1144 HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual (unboundVarOcc uv)) 1145 _ -> text "Illegal expression:" <+> ppr bad_e 1146 1147{- ************************************************************** 1148 * * 1149 Renaming type, class, instance and role declarations 1150* * 1151***************************************************************** 1152 1153@rnTyDecl@ uses the `global name function' to create a new type 1154declaration in which local names have been replaced by their original 1155names, reporting any unknown names. 1156 1157Renaming type variables is a pain. Because they now contain uniques, 1158it is necessary to pass in an association list which maps a parsed 1159tyvar to its @Name@ representation. 1160In some cases (type signatures of values), 1161it is even necessary to go over the type first 1162in order to get the set of tyvars used by it, make an assoc list, 1163and then go over it again to rename the tyvars! 1164However, we can also do some scoping checks at the same time. 1165 1166Note [Dependency analysis of type, class, and instance decls] 1167~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1168A TyClGroup represents a strongly connected components of 1169type/class/instance decls, together with the role annotations for the 1170type/class declarations. The renamer uses strongly connected 1171comoponent analysis to build these groups. We do this for a number of 1172reasons: 1173 1174* Improve kind error messages. Consider 1175 1176 data T f a = MkT f a 1177 data S f a = MkS f (T f a) 1178 1179 This has a kind error, but the error message is better if you 1180 check T first, (fixing its kind) and *then* S. If you do kind 1181 inference together, you might get an error reported in S, which 1182 is jolly confusing. See #4875 1183 1184 1185* Increase kind polymorphism. See TcTyClsDecls 1186 Note [Grouping of type and class declarations] 1187 1188Why do the instance declarations participate? At least two reasons 1189 1190* Consider (#11348) 1191 1192 type family F a 1193 type instance F Int = Bool 1194 1195 data R = MkR (F Int) 1196 1197 type Foo = 'MkR 'True 1198 1199 For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't 1200 know that unless we've looked at the type instance declaration for F 1201 before kind-checking Foo. 1202 1203* Another example is this (#3990). 1204 1205 data family Complex a 1206 data instance Complex Double = CD {-# UNPACK #-} !Double 1207 {-# UNPACK #-} !Double 1208 1209 data T = T {-# UNPACK #-} !(Complex Double) 1210 1211 Here, to generate the right kind of unpacked implementation for T, 1212 we must have access to the 'data instance' declaration. 1213 1214* Things become more complicated when we introduce transitive 1215 dependencies through imported definitions, like in this scenario: 1216 1217 A.hs 1218 type family Closed (t :: Type) :: Type where 1219 Closed t = Open t 1220 1221 type family Open (t :: Type) :: Type 1222 1223 B.hs 1224 data Q where 1225 Q :: Closed Bool -> Q 1226 1227 type instance Open Int = Bool 1228 1229 type S = 'Q 'True 1230 1231 Somehow, we must ensure that the instance Open Int = Bool is checked before 1232 the type synonym S. While we know that S depends upon 'Q depends upon Closed, 1233 we have no idea that Closed depends upon Open! 1234 1235 To accomodate for these situations, we ensure that an instance is checked 1236 before every @TyClDecl@ on which it does not depend. That's to say, instances 1237 are checked as early as possible in @tcTyAndClassDecls@. 1238 1239------------------------------------ 1240So much for WHY. What about HOW? It's pretty easy: 1241 1242(1) Rename the type/class, instance, and role declarations 1243 individually 1244 1245(2) Do strongly-connected component analysis of the type/class decls, 1246 We'll make a TyClGroup for each SCC 1247 1248 In this step we treat a reference to a (promoted) data constructor 1249 K as a dependency on its parent type. Thus 1250 data T = K1 | K2 1251 data S = MkS (Proxy 'K1) 1252 Here S depends on 'K1 and hence on its parent T. 1253 1254 In this step we ignore instances; see 1255 Note [No dependencies on data instances] 1256 1257(3) Attach roles to the appropriate SCC 1258 1259(4) Attach instances to the appropriate SCC. 1260 We add an instance decl to SCC when: 1261 all its free types/classes are bound in this SCC or earlier ones 1262 1263(5) We make an initial TyClGroup, with empty group_tyclds, for any 1264 (orphan) instances that affect only imported types/classes 1265 1266Steps (3) and (4) are done by the (mapAccumL mk_group) call. 1267 1268Note [No dependencies on data instances] 1269~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1270Consider this 1271 data family D a 1272 data instance D Int = D1 1273 data S = MkS (Proxy 'D1) 1274 1275Here the declaration of S depends on the /data instance/ declaration 1276for 'D Int'. That makes things a lot more complicated, especially 1277if the data instance is an associated type of an enclosing class instance. 1278(And the class instance might have several associated type instances 1279with different dependency structure!) 1280 1281Ugh. For now we simply don't allow promotion of data constructors for 1282data instances. See Note [AFamDataCon: not promoting data family 1283constructors] in TcEnv 1284-} 1285 1286 1287rnTyClDecls :: [TyClGroup GhcPs] 1288 -> RnM ([TyClGroup GhcRn], FreeVars) 1289-- Rename the declarations and do dependency analysis on them 1290rnTyClDecls tycl_ds 1291 = do { -- Rename the type/class, instance, and role declaraations 1292 ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds) 1293 ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) 1294 ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) 1295 ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) 1296 ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) 1297 1298 -- Do SCC analysis on the type/class decls 1299 ; rdr_env <- getGlobalRdrEnv 1300 ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs 1301 role_annot_env = mkRoleAnnotEnv role_annots 1302 (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs 1303 1304 inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs 1305 (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map 1306 1307 first_group 1308 | null init_inst_ds = [] 1309 | otherwise = [TyClGroup { group_ext = noExtField 1310 , group_tyclds = [] 1311 , group_kisigs = [] 1312 , group_roles = [] 1313 , group_instds = init_inst_ds }] 1314 1315 (final_inst_ds, groups) 1316 = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs 1317 1318 all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` 1319 foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV` 1320 foldr (plusFV . snd) emptyFVs kisigs_w_fvs 1321 1322 all_groups = first_group ++ groups 1323 1324 ; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map 1325 $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds ) 1326 1327 ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) 1328 ; return (all_groups, all_fvs) } 1329 where 1330 mk_group :: RoleAnnotEnv 1331 -> KindSigEnv 1332 -> InstDeclFreeVarsMap 1333 -> SCC (LTyClDecl GhcRn) 1334 -> (InstDeclFreeVarsMap, TyClGroup GhcRn) 1335 mk_group role_env kisig_env inst_map scc 1336 = (inst_map', group) 1337 where 1338 tycl_ds = flattenSCC scc 1339 bndrs = map (tcdName . unLoc) tycl_ds 1340 roles = getRoleAnnots bndrs role_env 1341 kisigs = getKindSigs bndrs kisig_env 1342 (inst_ds, inst_map') = getInsts bndrs inst_map 1343 group = TyClGroup { group_ext = noExtField 1344 , group_tyclds = tycl_ds 1345 , group_kisigs = kisigs 1346 , group_roles = roles 1347 , group_instds = inst_ds } 1348 1349-- | Free variables of standalone kind signatures. 1350newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) 1351 1352lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars 1353lookupKindSig_FV_Env (KindSig_FV_Env e) name 1354 = fromMaybe emptyFVs (lookupNameEnv e name) 1355 1356-- | Standalone kind signatures. 1357type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) 1358 1359mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) 1360mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) 1361 where 1362 kisig_env = mapNameEnv fst compound_env 1363 kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) 1364 compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) 1365 = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs 1366 1367getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] 1368getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs 1369 1370rnStandaloneKindSignatures 1371 :: NameSet -- names of types and classes in the current TyClGroup 1372 -> [LStandaloneKindSig GhcPs] 1373 -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] 1374rnStandaloneKindSignatures tc_names kisigs 1375 = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs 1376 get_name = standaloneKindSigName . unLoc 1377 ; mapM_ dupKindSig_Err dup_kisigs 1378 ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups 1379 } 1380 1381rnStandaloneKindSignature 1382 :: NameSet -- names of types and classes in the current TyClGroup 1383 -> StandaloneKindSig GhcPs 1384 -> RnM (StandaloneKindSig GhcRn, FreeVars) 1385rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) 1386 = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures 1387 ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr 1388 ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v 1389 ; let doc = StandaloneKindSigCtx (ppr v) 1390 ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki 1391 ; return (StandaloneKindSig noExtField new_v new_ki, fvs) 1392 } 1393 where 1394 standaloneKiSigErr :: SDoc 1395 standaloneKiSigErr = 1396 hang (text "Illegal standalone kind signature") 1397 2 (text "Did you mean to enable StandaloneKindSignatures?") 1398rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec 1399 1400depAnalTyClDecls :: GlobalRdrEnv 1401 -> KindSig_FV_Env 1402 -> [(LTyClDecl GhcRn, FreeVars)] 1403 -> [SCC (LTyClDecl GhcRn)] 1404-- See Note [Dependency analysis of type, class, and instance decls] 1405depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs 1406 = stronglyConnCompFromEdgedVerticesUniq edges 1407 where 1408 edges :: [ Node Name (LTyClDecl GhcRn) ] 1409 edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps)) 1410 | (d, fvs) <- ds_w_fvs, 1411 let { name = tcdName (unLoc d) 1412 ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name 1413 ; deps = fvs `plusFV` kisig_fvs 1414 } 1415 ] 1416 -- It's OK to use nonDetEltsUFM here as 1417 -- stronglyConnCompFromEdgedVertices is still deterministic 1418 -- even if the edges are in nondeterministic order as explained 1419 -- in Note [Deterministic SCC] in Digraph. 1420 1421toParents :: GlobalRdrEnv -> NameSet -> NameSet 1422toParents rdr_env ns 1423 = nonDetFoldUniqSet add emptyNameSet ns 1424 -- It's OK to use nonDetFoldUFM because we immediately forget the 1425 -- ordering by creating a set 1426 where 1427 add n s = extendNameSet s (getParent rdr_env n) 1428 1429getParent :: GlobalRdrEnv -> Name -> Name 1430getParent rdr_env n 1431 = case lookupGRE_Name rdr_env n of 1432 Just gre -> case gre_par gre of 1433 ParentIs { par_is = p } -> p 1434 FldParent { par_is = p } -> p 1435 _ -> n 1436 Nothing -> n 1437 1438 1439{- ****************************************************** 1440* * 1441 Role annotations 1442* * 1443****************************************************** -} 1444 1445-- | Renames role annotations, returning them as the values in a NameEnv 1446-- and checks for duplicate role annotations. 1447-- It is quite convenient to do both of these in the same place. 1448-- See also Note [Role annotations in the renamer] 1449rnRoleAnnots :: NameSet 1450 -> [LRoleAnnotDecl GhcPs] 1451 -> RnM [LRoleAnnotDecl GhcRn] 1452rnRoleAnnots tc_names role_annots 1453 = do { -- Check for duplicates *before* renaming, to avoid 1454 -- lumping together all the unboundNames 1455 let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots 1456 get_name = roleAnnotDeclName . unLoc 1457 ; mapM_ dupRoleAnnotErr dup_annots 1458 ; mapM (wrapLocM rn_role_annot1) no_dups } 1459 where 1460 rn_role_annot1 (RoleAnnotDecl _ tycon roles) 1461 = do { -- the name is an *occurrence*, but look it up only in the 1462 -- decls defined in this group (see #10263) 1463 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) 1464 (text "role annotation") 1465 tycon 1466 ; return $ RoleAnnotDecl noExtField tycon' roles } 1467 rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec 1468 1469dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () 1470dupRoleAnnotErr list 1471 = addErrAt loc $ 1472 hang (text "Duplicate role annotations for" <+> 1473 quotes (ppr $ roleAnnotDeclName first_decl) <> colon) 1474 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) 1475 where 1476 sorted_list = NE.sortBy cmp_annot list 1477 ((dL->L loc first_decl) :| _) = sorted_list 1478 1479 pp_role_annot (dL->L loc decl) = hang (ppr decl) 1480 4 (text "-- written at" <+> ppr loc) 1481 1482 cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 1483 1484dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () 1485dupKindSig_Err list 1486 = addErrAt loc $ 1487 hang (text "Duplicate standalone kind signatures for" <+> 1488 quotes (ppr $ standaloneKindSigName first_decl) <> colon) 1489 2 (vcat $ map pp_kisig $ NE.toList sorted_list) 1490 where 1491 sorted_list = NE.sortBy cmp_loc list 1492 ((dL->L loc first_decl) :| _) = sorted_list 1493 1494 pp_kisig (dL->L loc decl) = 1495 hang (ppr decl) 4 (text "-- written at" <+> ppr loc) 1496 1497 cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 1498 1499{- Note [Role annotations in the renamer] 1500~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1501We must ensure that a type's role annotation is put in the same group as the 1502proper type declaration. This is because role annotations are needed during 1503type-checking when creating the type's TyCon. So, rnRoleAnnots builds a 1504NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that 1505type, if any. Then, this map can be used to add the role annotations to the 1506groups after dependency analysis. 1507 1508This process checks for duplicate role annotations, where we must be careful 1509to do the check *before* renaming to avoid calling all unbound names duplicates 1510of one another. 1511 1512The renaming process, as usual, might identify and report errors for unbound 1513names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using 1514lookupGlobalOccRn led to #8485). 1515-} 1516 1517 1518{- ****************************************************** 1519* * 1520 Dependency info for instances 1521* * 1522****************************************************** -} 1523 1524---------------------------------------------------------- 1525-- | 'InstDeclFreeVarsMap is an association of an 1526-- @InstDecl@ with @FreeVars@. The @FreeVars@ are 1527-- the tycon names that are both 1528-- a) free in the instance declaration 1529-- b) bound by this group of type/class/instance decls 1530type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] 1531 1532-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the 1533-- @FreeVars@ which are *not* the binders of a @TyClDecl@. 1534mkInstDeclFreeVarsMap :: GlobalRdrEnv 1535 -> NameSet 1536 -> [(LInstDecl GhcRn, FreeVars)] 1537 -> InstDeclFreeVarsMap 1538mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs 1539 = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) 1540 | (inst_decl, fvs) <- inst_ds_fvs ] 1541 1542-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the 1543-- @InstDeclFreeVarsMap@ with these entries removed. 1544-- We call (getInsts tcs instd_map) when we've completed the declarations 1545-- for 'tcs'. The call returns (inst_decls, instd_map'), where 1546-- inst_decls are the instance declarations all of 1547-- whose free vars are now defined 1548-- instd_map' is the inst-decl map with 'tcs' removed from 1549-- the free-var set 1550getInsts :: [Name] -> InstDeclFreeVarsMap 1551 -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) 1552getInsts bndrs inst_decl_map 1553 = partitionWith pick_me inst_decl_map 1554 where 1555 pick_me :: (LInstDecl GhcRn, FreeVars) 1556 -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) 1557 pick_me (decl, fvs) 1558 | isEmptyNameSet depleted_fvs = Left decl 1559 | otherwise = Right (decl, depleted_fvs) 1560 where 1561 depleted_fvs = delFVs bndrs fvs 1562 1563{- ****************************************************** 1564* * 1565 Renaming a type or class declaration 1566* * 1567****************************************************** -} 1568 1569rnTyClDecl :: TyClDecl GhcPs 1570 -> RnM (TyClDecl GhcRn, FreeVars) 1571 1572-- All flavours of top-level type family declarations ("type family", "newtype 1573-- family", and "data family") 1574rnTyClDecl (FamDecl { tcdFam = fam }) 1575 = do { (fam', fvs) <- rnFamDecl Nothing fam 1576 ; return (FamDecl noExtField fam', fvs) } 1577 1578rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, 1579 tcdFixity = fixity, tcdRhs = rhs }) 1580 = do { tycon' <- lookupLocatedTopBndrRn tycon 1581 ; let kvs = extractHsTyRdrTyVarsKindVars rhs 1582 doc = TySynCtx tycon 1583 ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) 1584 ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> 1585 do { (rhs', fvs) <- rnTySyn doc rhs 1586 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' 1587 , tcdFixity = fixity 1588 , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } 1589 1590-- "data", "newtype" declarations 1591rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec 1592rnTyClDecl (DataDecl 1593 { tcdLName = tycon, tcdTyVars = tyvars, 1594 tcdFixity = fixity, 1595 tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data 1596 , dd_kindSig = kind_sig} }) 1597 = do { tycon' <- lookupLocatedTopBndrRn tycon 1598 ; let kvs = extractDataDefnKindVars defn 1599 doc = TyDataCtx tycon 1600 ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) 1601 ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> 1602 do { (defn', fvs) <- rnDataDefn doc defn 1603 ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig 1604 ; let rn_info = DataDeclRn { tcdDataCusk = cusk 1605 , tcdFVs = fvs } 1606 ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) 1607 ; return (DataDecl { tcdLName = tycon' 1608 , tcdTyVars = tyvars' 1609 , tcdFixity = fixity 1610 , tcdDataDefn = defn' 1611 , tcdDExt = rn_info }, fvs) } } 1612 1613rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, 1614 tcdTyVars = tyvars, tcdFixity = fixity, 1615 tcdFDs = fds, tcdSigs = sigs, 1616 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, 1617 tcdDocs = docs}) 1618 = do { lcls' <- lookupLocatedTopBndrRn lcls 1619 ; let cls' = unLoc lcls' 1620 kvs = [] -- No scoped kind vars except those in 1621 -- kind signatures on the tyvars 1622 1623 -- Tyvars scope over superclass context and method signatures 1624 ; ((tyvars', context', fds', ats'), stuff_fvs) 1625 <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do 1626 -- Checks for distinct tyvars 1627 { (context', cxt_fvs) <- rnContext cls_doc context 1628 ; fds' <- rnFds fds 1629 -- The fundeps have no free variables 1630 ; (ats', fv_ats) <- rnATDecls cls' ats 1631 ; let fvs = cxt_fvs `plusFV` 1632 fv_ats 1633 ; return ((tyvars', context', fds', ats'), fvs) } 1634 1635 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs 1636 1637 -- No need to check for duplicate associated type decls 1638 -- since that is done by RnNames.extendGlobalRdrEnvRn 1639 1640 -- Check the signatures 1641 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). 1642 ; let sig_rdr_names_w_locs = 1643 [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs 1644 , op <- ops] 1645 ; checkDupRdrNames sig_rdr_names_w_locs 1646 -- Typechecker is responsible for checking that we only 1647 -- give default-method bindings for things in this class. 1648 -- The renamer *could* check this for class decls, but can't 1649 -- for instance decls. 1650 1651 -- The newLocals call is tiresome: given a generic class decl 1652 -- class C a where 1653 -- op :: a -> a 1654 -- op {| x+y |} (Inl a) = ... 1655 -- op {| x+y |} (Inr b) = ... 1656 -- op {| a*b |} (a*b) = ... 1657 -- we want to name both "x" tyvars with the same unique, so that they are 1658 -- easy to group together in the typechecker. 1659 ; (mbinds', sigs', meth_fvs) 1660 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs 1661 -- No need to check for duplicate method signatures 1662 -- since that is done by RnNames.extendGlobalRdrEnvRn 1663 -- and the methods are already in scope 1664 1665 -- Haddock docs 1666 ; docs' <- mapM (wrapLocM rnDocDecl) docs 1667 1668 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs 1669 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', 1670 tcdTyVars = tyvars', tcdFixity = fixity, 1671 tcdFDs = fds', tcdSigs = sigs', 1672 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', 1673 tcdDocs = docs', tcdCExt = all_fvs }, 1674 all_fvs ) } 1675 where 1676 cls_doc = ClassDeclCtx lcls 1677 1678rnTyClDecl (XTyClDecl nec) = noExtCon nec 1679 1680-- Does the data type declaration include a CUSK? 1681data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool 1682data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do 1683 { -- See Note [Unlifted Newtypes and CUSKs], and for a broader 1684 -- picture, see Note [Implementation of UnliftedNewtypes]. 1685 ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes 1686 ; let non_cusk_newtype 1687 | NewType <- new_or_data = 1688 unlifted_newtypes && isNothing kind_sig 1689 | otherwise = False 1690 -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls 1691 ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype 1692 } 1693 1694{- Note [Unlifted Newtypes and CUSKs] 1695~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1696When unlifted newtypes are enabled, a newtype must have a kind signature 1697in order to be considered have a CUSK. This is because the flow of 1698kind inference works differently. Consider: 1699 1700 newtype Foo = FooC Int 1701 1702When UnliftedNewtypes is disabled, we decide that Foo has kind 1703`TYPE 'LiftedRep` without looking inside the data constructor. So, we 1704can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, 1705we fill in the kind of Foo as a metavar that gets solved by unification 1706with the kind of the field inside FooC (that is, Int, whose kind is 1707`TYPE 'LiftedRep`). But since we have to look inside the data constructors 1708to figure out the kind signature of Foo, it does not have a CUSK. 1709 1710See Note [Implementation of UnliftedNewtypes] for where this fits in to 1711the broader picture of UnliftedNewtypes. 1712-} 1713 1714-- "type" and "type instance" declarations 1715rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) 1716rnTySyn doc rhs = rnLHsType doc rhs 1717 1718rnDataDefn :: HsDocContext -> HsDataDefn GhcPs 1719 -> RnM (HsDataDefn GhcRn, FreeVars) 1720rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType 1721 , dd_ctxt = context, dd_cons = condecls 1722 , dd_kindSig = m_sig, dd_derivs = derivs }) 1723 = do { checkTc (h98_style || null (unLoc context)) 1724 (badGadtStupidTheta doc) 1725 1726 ; (m_sig', sig_fvs) <- case m_sig of 1727 Just sig -> first Just <$> rnLHsKind doc sig 1728 Nothing -> return (Nothing, emptyFVs) 1729 ; (context', fvs1) <- rnContext doc context 1730 ; (derivs', fvs3) <- rn_derivs derivs 1731 1732 -- For the constructor declarations, drop the LocalRdrEnv 1733 -- in the GADT case, where the type variables in the declaration 1734 -- do not scope over the constructor signatures 1735 -- data T a where { T1 :: forall b. b-> b } 1736 ; let { zap_lcl_env | h98_style = \ thing -> thing 1737 | otherwise = setLocalRdrEnv emptyLocalRdrEnv } 1738 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls 1739 -- No need to check for duplicate constructor decls 1740 -- since that is done by RnNames.extendGlobalRdrEnvRn 1741 1742 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` 1743 con_fvs `plusFV` sig_fvs 1744 ; return ( HsDataDefn { dd_ext = noExtField 1745 , dd_ND = new_or_data, dd_cType = cType 1746 , dd_ctxt = context', dd_kindSig = m_sig' 1747 , dd_cons = condecls' 1748 , dd_derivs = derivs' } 1749 , all_fvs ) 1750 } 1751 where 1752 h98_style = case condecls of -- Note [Stupid theta] 1753 (dL->L _ (ConDeclGADT {})) : _ -> False 1754 _ -> True 1755 1756 rn_derivs (dL->L loc ds) 1757 = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies 1758 ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) 1759 multipleDerivClausesErr 1760 ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds 1761 ; return (cL loc ds', fvs) } 1762rnDataDefn _ (XHsDataDefn nec) = noExtCon nec 1763 1764warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) 1765 -> SrcSpan 1766 -> RnM () 1767warnNoDerivStrat mds loc 1768 = do { dyn_flags <- getDynFlags 1769 ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ 1770 case mds of 1771 Nothing -> addWarnAt 1772 (Reason Opt_WarnMissingDerivingStrategies) 1773 loc 1774 (if xopt LangExt.DerivingStrategies dyn_flags 1775 then no_strat_warning 1776 else no_strat_warning $+$ deriv_strat_nenabled 1777 ) 1778 _ -> pure () 1779 } 1780 where 1781 no_strat_warning :: SDoc 1782 no_strat_warning = text "No deriving strategy specified. Did you want stock" 1783 <> text ", newtype, or anyclass?" 1784 deriv_strat_nenabled :: SDoc 1785 deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy." 1786 1787rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs 1788 -> RnM (LHsDerivingClause GhcRn, FreeVars) 1789rnLHsDerivingClause doc 1790 (dL->L loc (HsDerivingClause 1791 { deriv_clause_ext = noExtField 1792 , deriv_clause_strategy = dcs 1793 , deriv_clause_tys = (dL->L loc' dct) })) 1794 = do { (dcs', dct', fvs) 1795 <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct 1796 ; warnNoDerivStrat dcs' loc 1797 ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField 1798 , deriv_clause_strategy = dcs' 1799 , deriv_clause_tys = cL loc' dct' }) 1800 , fvs ) } 1801rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec)) 1802 = noExtCon nec 1803rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match" 1804 -- due to #15884 1805 1806rnLDerivStrategy :: forall a. 1807 HsDocContext 1808 -> Maybe (LDerivStrategy GhcPs) 1809 -> RnM (a, FreeVars) 1810 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) 1811rnLDerivStrategy doc mds thing_inside 1812 = case mds of 1813 Nothing -> boring_case Nothing 1814 Just (dL->L loc ds) -> 1815 setSrcSpan loc $ do 1816 (ds', thing, fvs) <- rn_deriv_strat ds 1817 pure (Just (cL loc ds'), thing, fvs) 1818 where 1819 rn_deriv_strat :: DerivStrategy GhcPs 1820 -> RnM (DerivStrategy GhcRn, a, FreeVars) 1821 rn_deriv_strat ds = do 1822 let extNeeded :: LangExt.Extension 1823 extNeeded 1824 | ViaStrategy{} <- ds 1825 = LangExt.DerivingVia 1826 | otherwise 1827 = LangExt.DerivingStrategies 1828 1829 unlessXOptM extNeeded $ 1830 failWith $ illegalDerivStrategyErr ds 1831 1832 case ds of 1833 StockStrategy -> boring_case StockStrategy 1834 AnyclassStrategy -> boring_case AnyclassStrategy 1835 NewtypeStrategy -> boring_case NewtypeStrategy 1836 ViaStrategy via_ty -> 1837 do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty 1838 let HsIB { hsib_ext = via_imp_tvs 1839 , hsib_body = via_body } = via_ty' 1840 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body 1841 via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs 1842 via_tvs = via_imp_tvs ++ via_exp_tvs 1843 (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside 1844 pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) 1845 1846 boring_case :: ds -> RnM (ds, a, FreeVars) 1847 boring_case ds = do 1848 (thing, fvs) <- thing_inside 1849 pure (ds, thing, fvs) 1850 1851badGadtStupidTheta :: HsDocContext -> SDoc 1852badGadtStupidTheta _ 1853 = vcat [text "No context is allowed on a GADT-style data declaration", 1854 text "(You can put a context on each constructor, though.)"] 1855 1856illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc 1857illegalDerivStrategyErr ds 1858 = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds 1859 , text enableStrategy ] 1860 1861 where 1862 enableStrategy :: String 1863 enableStrategy 1864 | ViaStrategy{} <- ds 1865 = "Use DerivingVia to enable this extension" 1866 | otherwise 1867 = "Use DerivingStrategies to enable this extension" 1868 1869multipleDerivClausesErr :: SDoc 1870multipleDerivClausesErr 1871 = vcat [ text "Illegal use of multiple, consecutive deriving clauses" 1872 , text "Use DerivingStrategies to allow this" ] 1873 1874rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested 1875 -- inside an *class decl* for cls 1876 -- used for associated types 1877 -> FamilyDecl GhcPs 1878 -> RnM (FamilyDecl GhcRn, FreeVars) 1879rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars 1880 , fdFixity = fixity 1881 , fdInfo = info, fdResultSig = res_sig 1882 , fdInjectivityAnn = injectivity }) 1883 = do { tycon' <- lookupLocatedTopBndrRn tycon 1884 ; ((tyvars', res_sig', injectivity'), fv1) <- 1885 bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ -> 1886 do { let rn_sig = rnFamResultSig doc 1887 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig 1888 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') 1889 injectivity 1890 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } 1891 ; (info', fv2) <- rn_info tycon' info 1892 ; return (FamilyDecl { fdExt = noExtField 1893 , fdLName = tycon', fdTyVars = tyvars' 1894 , fdFixity = fixity 1895 , fdInfo = info', fdResultSig = res_sig' 1896 , fdInjectivityAnn = injectivity' } 1897 , fv1 `plusFV` fv2) } 1898 where 1899 doc = TyFamilyCtx tycon 1900 kvs = extractRdrKindSigVars res_sig 1901 1902 ---------------------- 1903 rn_info :: Located Name 1904 -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) 1905 rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns)) 1906 = do { (eqns', fvs) 1907 <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) 1908 -- no class context 1909 eqns 1910 ; return (ClosedTypeFamily (Just eqns'), fvs) } 1911 rn_info _ (ClosedTypeFamily Nothing) 1912 = return (ClosedTypeFamily Nothing, emptyFVs) 1913 rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs) 1914 rn_info _ DataFamily = return (DataFamily, emptyFVs) 1915rnFamDecl _ (XFamilyDecl nec) = noExtCon nec 1916 1917rnFamResultSig :: HsDocContext 1918 -> FamilyResultSig GhcPs 1919 -> RnM (FamilyResultSig GhcRn, FreeVars) 1920rnFamResultSig _ (NoSig _) 1921 = return (NoSig noExtField, emptyFVs) 1922rnFamResultSig doc (KindSig _ kind) 1923 = do { (rndKind, ftvs) <- rnLHsKind doc kind 1924 ; return (KindSig noExtField rndKind, ftvs) } 1925rnFamResultSig doc (TyVarSig _ tvbndr) 1926 = do { -- `TyVarSig` tells us that user named the result of a type family by 1927 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to 1928 -- be sure that the supplied result name is not identical to an 1929 -- already in-scope type variable from an enclosing class. 1930 -- 1931 -- Example of disallowed declaration: 1932 -- class C a b where 1933 -- type F b = a | a -> b 1934 rdr_env <- getLocalRdrEnv 1935 ; let resName = hsLTyVarName tvbndr 1936 ; when (resName `elemLocalRdrEnv` rdr_env) $ 1937 addErrAt (getLoc tvbndr) $ 1938 (hsep [ text "Type variable", quotes (ppr resName) <> comma 1939 , text "naming a type family result," 1940 ] $$ 1941 text "shadows an already bound type variable") 1942 1943 ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for 1944 -- scoping checks that are irrelevant here 1945 tvbndr $ \ tvbndr' -> 1946 return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) } 1947rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec 1948 1949-- Note [Renaming injectivity annotation] 1950-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1951-- 1952-- During renaming of injectivity annotation we have to make several checks to 1953-- make sure that it is well-formed. At the moment injectivity annotation 1954-- consists of a single injectivity condition, so the terms "injectivity 1955-- annotation" and "injectivity condition" might be used interchangeably. See 1956-- Note [Injectivity annotation] for a detailed discussion of currently allowed 1957-- injectivity annotations. 1958-- 1959-- Checking LHS is simple because the only type variable allowed on the LHS of 1960-- injectivity condition is the variable naming the result in type family head. 1961-- Example of disallowed annotation: 1962-- 1963-- type family Foo a b = r | b -> a 1964-- 1965-- Verifying RHS of injectivity consists of checking that: 1966-- 1967-- 1. only variables defined in type family head appear on the RHS (kind 1968-- variables are also allowed). Example of disallowed annotation: 1969-- 1970-- type family Foo a = r | r -> b 1971-- 1972-- 2. for associated types the result variable does not shadow any of type 1973-- class variables. Example of disallowed annotation: 1974-- 1975-- class Foo a b where 1976-- type F a = b | b -> a 1977-- 1978-- Breaking any of these assumptions results in an error. 1979 1980-- | Rename injectivity annotation. Note that injectivity annotation is just the 1981-- part after the "|". Everything that appears before it is renamed in 1982-- rnFamDecl. 1983rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in 1984 -- type family head 1985 -> LFamilyResultSig GhcRn -- ^ Result signature 1986 -> LInjectivityAnn GhcPs -- ^ Injectivity annotation 1987 -> RnM (LInjectivityAnn GhcRn) 1988rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) 1989 (dL->L srcSpan (InjectivityAnn injFrom injTo)) 1990 = do 1991 { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors) 1992 <- askNoErrs $ 1993 bindLocalNames [hsLTyVarName resTv] $ 1994 -- The return type variable scopes over the injectivity annotation 1995 -- e.g. type family F a = (r::*) | r -> a 1996 do { injFrom' <- rnLTyVar injFrom 1997 ; injTo' <- mapM rnLTyVar injTo 1998 ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') } 1999 2000 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs 2001 resName = hsLTyVarName resTv 2002 -- See Note [Renaming injectivity annotation] 2003 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) 2004 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames 2005 2006 -- if renaming of type variables ended with errors (eg. there were 2007 -- not-in-scope variables) don't check the validity of injectivity 2008 -- annotation. This gives better error messages. 2009 ; when (noRnErrors && not lhsValid) $ 2010 addErrAt (getLoc injFrom) 2011 ( vcat [ text $ "Incorrect type variable on the LHS of " 2012 ++ "injectivity condition" 2013 , nest 5 2014 ( vcat [ text "Expected :" <+> ppr resName 2015 , text "Actual :" <+> ppr injFrom ])]) 2016 2017 ; when (noRnErrors && not (Set.null rhsValid)) $ 2018 do { let errorVars = Set.toList rhsValid 2019 ; addErrAt srcSpan $ ( hsep 2020 [ text "Unknown type variable" <> plural errorVars 2021 , text "on the RHS of injectivity condition:" 2022 , interpp'SP errorVars ] ) } 2023 2024 ; return injDecl' } 2025 2026-- We can only hit this case when the user writes injectivity annotation without 2027-- naming the result: 2028-- 2029-- type family F a | result -> a 2030-- type family F a :: * | result -> a 2031-- 2032-- So we rename injectivity annotation like we normally would except that 2033-- this time we expect "result" to be reported not in scope by rnLTyVar. 2034rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) = 2035 setSrcSpan srcSpan $ do 2036 (injDecl', _) <- askNoErrs $ do 2037 injFrom' <- rnLTyVar injFrom 2038 injTo' <- mapM rnLTyVar injTo 2039 return $ cL srcSpan (InjectivityAnn injFrom' injTo') 2040 return $ injDecl' 2041 2042{- 2043Note [Stupid theta] 2044~~~~~~~~~~~~~~~~~~~ 2045#3850 complains about a regression wrt 6.10 for 2046 data Show a => T a 2047There is no reason not to allow the stupid theta if there are no data 2048constructors. It's still stupid, but does no harm, and I don't want 2049to cause programs to break unnecessarily (notably HList). So if there 2050are no data constructors we allow h98_style = True 2051-} 2052 2053 2054{- ***************************************************** 2055* * 2056 Support code for type/data declarations 2057* * 2058***************************************************** -} 2059 2060--------------- 2061wrongTyFamName :: Name -> Name -> SDoc 2062wrongTyFamName fam_tc_name eqn_tc_name 2063 = hang (text "Mismatched type name in type family instance.") 2064 2 (vcat [ text "Expected:" <+> ppr fam_tc_name 2065 , text " Actual:" <+> ppr eqn_tc_name ]) 2066 2067----------------- 2068rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) 2069rnConDecls = mapFvRn (wrapLocFstM rnConDecl) 2070 2071rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) 2072rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs 2073 , con_mb_cxt = mcxt, con_args = args 2074 , con_doc = mb_doc }) 2075 = do { _ <- addLocM checkConName name 2076 ; new_name <- lookupLocatedTopBndrRn name 2077 ; mb_doc' <- rnMbLHsDoc mb_doc 2078 2079 -- We bind no implicit binders here; this is just like 2080 -- a nested HsForAllTy. E.g. consider 2081 -- data T a = forall (b::k). MkT (...) 2082 -- The 'k' will already be in scope from the bindHsQTyVars 2083 -- for the data decl itself. So we'll get 2084 -- data T {k} a = ... 2085 -- And indeed we may later discover (a::k). But that's the 2086 -- scoping we get. So no implicit binders at the existential forall 2087 2088 ; let ctxt = ConDeclCtx [new_name] 2089 ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt)) 2090 Nothing ex_tvs $ \ new_ex_tvs -> 2091 do { (new_context, fvs1) <- rnMbContext ctxt mcxt 2092 ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args 2093 ; let all_fvs = fvs1 `plusFV` fvs2 2094 ; traceRn "rnConDecl" (ppr name <+> vcat 2095 [ text "ex_tvs:" <+> ppr ex_tvs 2096 , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) 2097 2098 ; return (decl { con_ext = noExtField 2099 , con_name = new_name, con_ex_tvs = new_ex_tvs 2100 , con_mb_cxt = new_context, con_args = new_args 2101 , con_doc = mb_doc' }, 2102 all_fvs) }} 2103 2104rnConDecl decl@(ConDeclGADT { con_names = names 2105 , con_forall = (dL->L _ explicit_forall) 2106 , con_qvars = qtvs 2107 , con_mb_cxt = mcxt 2108 , con_args = args 2109 , con_res_ty = res_ty 2110 , con_doc = mb_doc }) 2111 = do { mapM_ (addLocM checkConName) names 2112 ; new_names <- mapM lookupLocatedTopBndrRn names 2113 ; mb_doc' <- rnMbLHsDoc mb_doc 2114 2115 ; let explicit_tkvs = hsQTvExplicit qtvs 2116 theta = hsConDeclTheta mcxt 2117 arg_tys = hsConDeclArgTys args 2118 2119 -- We must ensure that we extract the free tkvs in left-to-right 2120 -- order of their appearance in the constructor type. 2121 -- That order governs the order the implicitly-quantified type 2122 -- variable, and hence the order needed for visible type application 2123 -- See #14808. 2124 free_tkvs = extractHsTvBndrs explicit_tkvs $ 2125 extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty]) 2126 2127 ctxt = ConDeclCtx new_names 2128 mb_ctxt = Just (inHsDocContext ctxt) 2129 2130 ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall ) 2131 ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs -> 2132 bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs -> 2133 do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt 2134 ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args 2135 ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty 2136 2137 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 2138 (args', res_ty') 2139 = case args of 2140 InfixCon {} -> pprPanic "rnConDecl" (ppr names) 2141 RecCon {} -> (new_args, new_res_ty) 2142 PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty 2143 -> ASSERT( null as ) 2144 -- See Note [GADT abstract syntax] in GHC.Hs.Decls 2145 (PrefixCon arg_tys, final_res_ty) 2146 2147 new_qtvs = HsQTvs { hsq_ext = implicit_tkvs 2148 , hsq_explicit = explicit_tkvs } 2149 2150 ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) 2151 ; return (decl { con_g_ext = noExtField, con_names = new_names 2152 , con_qvars = new_qtvs, con_mb_cxt = new_cxt 2153 , con_args = args', con_res_ty = res_ty' 2154 , con_doc = mb_doc' }, 2155 all_fvs) } } 2156 2157rnConDecl (XConDecl nec) = noExtCon nec 2158 2159 2160rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) 2161 -> RnM (Maybe (LHsContext GhcRn), FreeVars) 2162rnMbContext _ Nothing = return (Nothing, emptyFVs) 2163rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt 2164 ; return (Just ctx',fvs) } 2165 2166rnConDeclDetails 2167 :: Name 2168 -> HsDocContext 2169 -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs]) 2170 -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), 2171 FreeVars) 2172rnConDeclDetails _ doc (PrefixCon tys) 2173 = do { (new_tys, fvs) <- rnLHsTypes doc tys 2174 ; return (PrefixCon new_tys, fvs) } 2175 2176rnConDeclDetails _ doc (InfixCon ty1 ty2) 2177 = do { (new_ty1, fvs1) <- rnLHsType doc ty1 2178 ; (new_ty2, fvs2) <- rnLHsType doc ty2 2179 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } 2180 2181rnConDeclDetails con doc (RecCon (dL->L l fields)) 2182 = do { fls <- lookupConstructorFields con 2183 ; (new_fields, fvs) <- rnConDeclFields doc fls fields 2184 -- No need to check for duplicate fields 2185 -- since that is done by RnNames.extendGlobalRdrEnvRn 2186 ; return (RecCon (cL l new_fields), fvs) } 2187 2188------------------------------------------------- 2189 2190-- | Brings pattern synonym names and also pattern synonym selectors 2191-- from record pattern synonyms into scope. 2192extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv 2193 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a 2194extendPatSynEnv val_decls local_fix_env thing = do { 2195 names_with_fls <- new_ps val_decls 2196 ; let pat_syn_bndrs = concat [ name: map flSelector fields 2197 | (name, fields) <- names_with_fls ] 2198 ; let avails = map avail pat_syn_bndrs 2199 ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env 2200 2201 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls 2202 final_gbl_env = gbl_env { tcg_field_env = field_env' } 2203 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } 2204 where 2205 new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] 2206 new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds 2207 new_ps _ = panic "new_ps" 2208 2209 new_ps' :: LHsBindLR GhcPs GhcPs 2210 -> [(Name, [FieldLabel])] 2211 -> TcM [(Name, [FieldLabel])] 2212 new_ps' bind names 2213 | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n) 2214 , psb_args = RecCon as }))) <- bind 2215 = do 2216 bnd_name <- newTopSrcBinder (cL bind_loc n) 2217 let rnames = map recordPatSynSelectorId as 2218 mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs 2219 mkFieldOcc (dL->L l name) = cL l (FieldOcc noExtField (cL l name)) 2220 field_occs = map mkFieldOcc rnames 2221 flds <- mapM (newRecordSelector False [bnd_name]) field_occs 2222 return ((bnd_name, flds): names) 2223 | (dL->L bind_loc (PatSynBind _ 2224 (PSB { psb_id = (dL->L _ n)}))) <- bind 2225 = do 2226 bnd_name <- newTopSrcBinder (cL bind_loc n) 2227 return ((bnd_name, []): names) 2228 | otherwise 2229 = return names 2230 2231{- 2232********************************************************* 2233* * 2234\subsection{Support code to rename types} 2235* * 2236********************************************************* 2237-} 2238 2239rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] 2240rnFds fds 2241 = mapM (wrapLocM rn_fds) fds 2242 where 2243 rn_fds (tys1, tys2) 2244 = do { tys1' <- rnHsTyVars tys1 2245 ; tys2' <- rnHsTyVars tys2 2246 ; return (tys1', tys2') } 2247 2248rnHsTyVars :: [Located RdrName] -> RnM [Located Name] 2249rnHsTyVars tvs = mapM rnHsTyVar tvs 2250 2251rnHsTyVar :: Located RdrName -> RnM (Located Name) 2252rnHsTyVar (dL->L l tyvar) = do 2253 tyvar' <- lookupOccRn tyvar 2254 return (cL l tyvar') 2255 2256{- 2257********************************************************* 2258* * 2259 findSplice 2260* * 2261********************************************************* 2262 2263This code marches down the declarations, looking for the first 2264Template Haskell splice. As it does so it 2265 a) groups the declarations into a HsGroup 2266 b) runs any top-level quasi-quotes 2267-} 2268 2269findSplice :: [LHsDecl GhcPs] 2270 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) 2271findSplice ds = addl emptyRdrGroup ds 2272 2273addl :: HsGroup GhcPs -> [LHsDecl GhcPs] 2274 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) 2275-- This stuff reverses the declarations (again) but it doesn't matter 2276addl gp [] = return (gp, Nothing) 2277addl gp ((dL->L l d) : ds) = add gp l d ds 2278 2279 2280add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] 2281 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) 2282 2283-- #10047: Declaration QuasiQuoters are expanded immediately, without 2284-- causing a group split 2285add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds 2286 = do { (ds', _) <- rnTopSpliceDecls qq 2287 ; addl gp (ds' ++ ds) 2288 } 2289 2290add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds 2291 = do { -- We've found a top-level splice. If it is an *implicit* one 2292 -- (i.e. a naked top level expression) 2293 case flag of 2294 ExplicitSplice -> return () 2295 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell 2296 ; unless th_on $ setSrcSpan loc $ 2297 failWith badImplicitSplice } 2298 2299 ; return (gp, Just (splice, ds)) } 2300 where 2301 badImplicitSplice = text "Parse error: module header, import declaration" 2302 $$ text "or top-level declaration expected." 2303 -- The compiler should suggest the above, and not using 2304 -- TemplateHaskell since the former suggestion is more 2305 -- relevant to the larger base of users. 2306 -- See #12146 for discussion. 2307 2308-- Class declarations: pull out the fixity signatures to the top 2309add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds 2310 | isClassDecl d 2311 = let fsigs = [ cL l f 2312 | (dL->L l (FixSig _ f)) <- tcdSigs d ] in 2313 addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds 2314 | otherwise 2315 = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds 2316 2317-- Signatures: fixity sigs go a different place than all others 2318add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds 2319 = addl (gp {hs_fixds = cL l f : ts}) ds 2320 2321-- Standalone kind signatures: added to the TyClGroup 2322add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds 2323 = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds 2324 2325add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds 2326 = addl (gp {hs_valds = add_sig (cL l d) ts}) ds 2327 2328-- Value declarations: use add_bind 2329add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds 2330 = addl (gp { hs_valds = add_bind (cL l d) ts }) ds 2331 2332-- Role annotations: added to the TyClGroup 2333add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds 2334 = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds 2335 2336-- NB instance declarations go into TyClGroups. We throw them into the first 2337-- group, just as we do for the TyClD case. The renamer will go on to group 2338-- and order them later. 2339add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds 2340 = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds 2341 2342-- The rest are routine 2343add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds 2344 = addl (gp { hs_derivds = cL l d : ts }) ds 2345add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds 2346 = addl (gp { hs_defds = cL l d : ts }) ds 2347add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds 2348 = addl (gp { hs_fords = cL l d : ts }) ds 2349add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds 2350 = addl (gp { hs_warnds = cL l d : ts }) ds 2351add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds 2352 = addl (gp { hs_annds = cL l d : ts }) ds 2353add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds 2354 = addl (gp { hs_ruleds = cL l d : ts }) ds 2355add gp l (DocD _ d) ds 2356 = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds 2357add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec 2358add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec 2359add (XHsGroup nec) _ _ _ = noExtCon nec 2360 2361add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] 2362 -> [TyClGroup (GhcPass p)] 2363add_tycld d [] = [TyClGroup { group_ext = noExtField 2364 , group_tyclds = [d] 2365 , group_kisigs = [] 2366 , group_roles = [] 2367 , group_instds = [] 2368 } 2369 ] 2370add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) 2371 = ds { group_tyclds = d : tyclds } : dss 2372add_tycld _ (XTyClGroup nec: _) = noExtCon nec 2373 2374add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] 2375 -> [TyClGroup (GhcPass p)] 2376add_instd d [] = [TyClGroup { group_ext = noExtField 2377 , group_tyclds = [] 2378 , group_kisigs = [] 2379 , group_roles = [] 2380 , group_instds = [d] 2381 } 2382 ] 2383add_instd d (ds@(TyClGroup { group_instds = instds }):dss) 2384 = ds { group_instds = d : instds } : dss 2385add_instd _ (XTyClGroup nec: _) = noExtCon nec 2386 2387add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] 2388 -> [TyClGroup (GhcPass p)] 2389add_role_annot d [] = [TyClGroup { group_ext = noExtField 2390 , group_tyclds = [] 2391 , group_kisigs = [] 2392 , group_roles = [d] 2393 , group_instds = [] 2394 } 2395 ] 2396add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) 2397 = tycls { group_roles = d : roles } : rest 2398add_role_annot _ (XTyClGroup nec: _) = noExtCon nec 2399 2400add_kisig :: LStandaloneKindSig (GhcPass p) 2401 -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] 2402add_kisig d [] = [TyClGroup { group_ext = noExtField 2403 , group_tyclds = [] 2404 , group_kisigs = [d] 2405 , group_roles = [] 2406 , group_instds = [] 2407 } 2408 ] 2409add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) 2410 = tycls { group_kisigs = d : kisigs } : rest 2411add_kisig _ (XTyClGroup nec : _) = noExtCon nec 2412 2413add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a 2414add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs 2415add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind" 2416 2417add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) 2418add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) 2419add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig" 2420