1{- 2% 3(c) The University of Glasgow 2006 4(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 5 6\section[TcExpr]{Typecheck an expression} 7-} 8 9{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} 10{-# LANGUAGE FlexibleContexts #-} 11{-# LANGUAGE TypeFamilies #-} 12 13module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, 14 tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC, 15 tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, 16 tcCheckId, 17 addExprErrCtxt, 18 getFixedTyVars ) where 19 20#include "HsVersions.h" 21 22import GhcPrelude 23 24import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) 25import THNames( liftStringName, liftName ) 26 27import GHC.Hs 28import TcHsSyn 29import TcRnMonad 30import TcUnify 31import BasicTypes 32import Inst 33import TcBinds ( chooseInferredQuantifiers, tcLocalBinds ) 34import TcSigs ( tcUserTypeSig, tcInstSig ) 35import TcSimplify ( simplifyInfer, InferMode(..) ) 36import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst ) 37import FamInstEnv ( FamInstEnvs ) 38import RnEnv ( addUsedGRE ) 39import RnUtils ( addNameClashErrRn, unknownSubordinateErr ) 40import TcEnv 41import TcArrows 42import TcMatches 43import TcHsType 44import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) 45import TcPat 46import TcMType 47import TcOrigin 48import TcType 49import Id 50import IdInfo 51import ConLike 52import DataCon 53import PatSyn 54import Name 55import NameEnv 56import NameSet 57import RdrName 58import TyCon 59import TyCoRep 60import TyCoPpr 61import TyCoSubst (substTyWithInScope) 62import Type 63import TcEvidence 64import VarSet 65import TysWiredIn 66import TysPrim( intPrimTy ) 67import PrimOp( tagToEnumKey ) 68import PrelNames 69import DynFlags 70import SrcLoc 71import Util 72import VarEnv ( emptyTidyEnv, mkInScopeSet ) 73import ListSetOps 74import Maybes 75import Outputable 76import FastString 77import Control.Monad 78import Class(classTyCon) 79import UniqSet ( nonDetEltsUniqSet ) 80import qualified GHC.LanguageExtensions as LangExt 81 82import Data.Function 83import Data.List (partition, sortBy, groupBy, intersect) 84import qualified Data.Set as Set 85 86{- 87************************************************************************ 88* * 89\subsection{Main wrappers} 90* * 91************************************************************************ 92-} 93 94tcPolyExpr, tcPolyExprNC 95 :: LHsExpr GhcRn -- Expression to type check 96 -> TcSigmaType -- Expected type (could be a polytype) 97 -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type 98 99-- tcPolyExpr is a convenient place (frequent but not too frequent) 100-- place to add context information. 101-- The NC version does not do so, usually because the caller wants 102-- to do so himself. 103 104tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty) 105tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty) 106 107-- these versions take an ExpType 108tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType 109 -> TcM (LHsExpr GhcTcId) 110tc_poly_expr expr res_ty 111 = addExprErrCtxt expr $ 112 do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty } 113 114tc_poly_expr_nc (L loc expr) res_ty 115 = setSrcSpan loc $ 116 do { traceTc "tcPolyExprNC" (ppr res_ty) 117 ; (wrap, expr') 118 <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> 119 tcExpr expr res_ty 120 ; return $ L loc (mkHsWrap wrap expr') } 121 122--------------- 123tcMonoExpr, tcMonoExprNC 124 :: LHsExpr GhcRn -- Expression to type check 125 -> ExpRhoType -- Expected type 126 -- Definitely no foralls at the top 127 -> TcM (LHsExpr GhcTcId) 128 129tcMonoExpr expr res_ty 130 = addErrCtxt (exprCtxt expr) $ 131 tcMonoExprNC expr res_ty 132 133tcMonoExprNC (L loc expr) res_ty 134 = setSrcSpan loc $ 135 do { expr' <- tcExpr expr res_ty 136 ; return (L loc expr') } 137 138--------------- 139tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId 140 , TcSigmaType ) 141-- Infer a *sigma*-type. 142tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr) 143 144tcInferSigmaNC (L loc expr) 145 = setSrcSpan loc $ 146 do { (expr', sigma) <- tcInferNoInst (tcExpr expr) 147 ; return (L loc expr', sigma) } 148 149tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType) 150-- Infer a *rho*-type. The return type is always (shallowly) instantiated. 151tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) 152 153tcInferRhoNC expr 154 = do { (expr', sigma) <- tcInferSigmaNC expr 155 ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma 156 ; return (mkLHsWrap wrap expr', rho) } 157 158 159{- 160************************************************************************ 161* * 162 tcExpr: the main expression typechecker 163* * 164************************************************************************ 165 166NB: The res_ty is always deeply skolemised. 167-} 168 169tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) 170tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty 171tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty 172 173tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty 174tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty 175 176tcExpr e@(HsLit x lit) res_ty 177 = do { let lit_ty = hsLitType lit 178 ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } 179 180tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty 181 ; return (HsPar x expr') } 182 183tcExpr (HsSCC x src lbl expr) res_ty 184 = do { expr' <- tcMonoExpr expr res_ty 185 ; return (HsSCC x src lbl expr') } 186 187tcExpr (HsTickPragma x src info srcInfo expr) res_ty 188 = do { expr' <- tcMonoExpr expr res_ty 189 ; return (HsTickPragma x src info srcInfo expr') } 190 191tcExpr (HsCoreAnn x src lbl expr) res_ty 192 = do { expr' <- tcMonoExpr expr res_ty 193 ; return (HsCoreAnn x src lbl expr') } 194 195tcExpr (HsOverLit x lit) res_ty 196 = do { lit' <- newOverloadedLit lit res_ty 197 ; return (HsOverLit x lit') } 198 199tcExpr (NegApp x expr neg_expr) res_ty 200 = do { (expr', neg_expr') 201 <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ 202 \[arg_ty] -> 203 tcMonoExpr expr (mkCheckExpType arg_ty) 204 ; return (NegApp x expr' neg_expr') } 205 206tcExpr e@(HsIPVar _ x) res_ty 207 = do { {- Implicit parameters must have a *tau-type* not a 208 type scheme. We enforce this by creating a fresh 209 type variable as its type. (Because res_ty may not 210 be a tau-type.) -} 211 ip_ty <- newOpenFlexiTyVarTy 212 ; let ip_name = mkStrLitTy (hsIPNameFS x) 213 ; ipClass <- tcLookupClass ipClassName 214 ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) 215 ; tcWrapResult e 216 (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) 217 ip_ty res_ty } 218 where 219 -- Coerces a dictionary for `IP "x" t` into `t`. 220 fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ 221 unwrapIP $ mkClassPred ipClass [x,ty] 222 origin = IPOccOrigin x 223 224tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty 225 = do { -- See Note [Type-checking overloaded labels] 226 loc <- getSrcSpanM 227 ; case mb_fromLabel of 228 Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty 229 Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName 230 ; alpha <- newFlexiTyVarTy liftedTypeKind 231 ; let pred = mkClassPred isLabelClass [lbl, alpha] 232 ; loc <- getSrcSpanM 233 ; var <- emitWantedEvVar origin pred 234 ; tcWrapResult e 235 (fromDict pred (HsVar noExtField (L loc var))) 236 alpha res_ty } } 237 where 238 -- Coerces a dictionary for `IsLabel "x" t` into `t`, 239 -- or `HasField "x" r a into `r -> a`. 240 fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred 241 origin = OverLabelOrigin l 242 lbl = mkStrLitTy l 243 244 applyFromLabel loc fromLabel = 245 HsAppType noExtField 246 (L loc (HsVar noExtField (L loc fromLabel))) 247 (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) 248 249tcExpr (HsLam x match) res_ty 250 = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty 251 ; return (mkHsWrap wrap (HsLam x match')) } 252 where 253 match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } 254 herald = sep [ text "The lambda expression" <+> 255 quotes (pprSetDepth (PartWay 1) $ 256 pprMatches match), 257 -- The pprSetDepth makes the abstraction print briefly 258 text "has"] 259 260tcExpr e@(HsLamCase x matches) res_ty 261 = do { (matches', wrap) 262 <- tcMatchLambda msg match_ctxt matches res_ty 263 -- The laziness annotation is because we don't want to fail here 264 -- if there are multiple arguments 265 ; return (mkHsWrap wrap $ HsLamCase x matches') } 266 where 267 msg = sep [ text "The function" <+> quotes (ppr e) 268 , text "requires"] 269 match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } 270 271tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty 272 = do { let loc = getLoc (hsSigWcType sig_ty) 273 ; sig_info <- checkNoErrs $ -- Avoid error cascade 274 tcUserTypeSig loc sig_ty Nothing 275 ; (expr', poly_ty) <- tcExprSig expr sig_info 276 ; let expr'' = ExprWithTySig noExtField expr' sig_ty 277 ; tcWrapResult e expr'' poly_ty res_ty } 278 279{- 280Note [Type-checking overloaded labels] 281~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 282Recall that we have 283 284 module GHC.OverloadedLabels where 285 class IsLabel (x :: Symbol) a where 286 fromLabel :: a 287 288We translate `#foo` to `fromLabel @"foo"`, where we use 289 290 * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not 291 * `GHC.OverloadedLabels.fromLabel`. 292 293In the `RebindableSyntax` case, the renamer will have filled in the 294first field of `HsOverLabel` with the `fromLabel` function to use, and 295we simply apply it to the appropriate visible type argument. 296 297In the `OverloadedLabels` case, when we see an overloaded label like 298`#foo`, we generate a fresh variable `alpha` for the type and emit an 299`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a 300single method, it is represented by a newtype, so we can coerce 301`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). 302 303-} 304 305 306{- 307************************************************************************ 308* * 309 Infix operators and sections 310* * 311************************************************************************ 312 313Note [Left sections] 314~~~~~~~~~~~~~~~~~~~~ 315Left sections, like (4 *), are equivalent to 316 \ x -> (*) 4 x, 317or, if PostfixOperators is enabled, just 318 (*) 4 319With PostfixOperators we don't actually require the function to take 320two arguments at all. For example, (x `not`) means (not x); you get 321postfix operators! Not Haskell 98, but it's less work and kind of 322useful. 323 324Note [Typing rule for ($)] 325~~~~~~~~~~~~~~~~~~~~~~~~~~ 326People write 327 runST $ blah 328so much, where 329 runST :: (forall s. ST s a) -> a 330that I have finally given in and written a special type-checking 331rule just for saturated applications of ($). 332 * Infer the type of the first argument 333 * Decompose it; should be of form (arg2_ty -> res_ty), 334 where arg2_ty might be a polytype 335 * Use arg2_ty to typecheck arg2 336-} 337 338tcExpr expr@(OpApp fix arg1 op arg2) res_ty 339 | (L loc (HsVar _ (L lv op_name))) <- op 340 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] 341 = do { traceTc "Application rule" (ppr op) 342 ; (arg1', arg1_ty) <- tcInferSigma arg1 343 344 ; let doc = text "The first argument of ($) takes" 345 orig1 = lexprCtOrigin arg1 346 ; (wrap_arg1, [arg2_sigma], op_res_ty) <- 347 matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty 348 349 -- We have (arg1 $ arg2) 350 -- So: arg1_ty = arg2_ty -> op_res_ty 351 -- where arg2_sigma maybe polymorphic; that's the point 352 353 ; arg2' <- tcArg op arg2 arg2_sigma 2 354 355 -- Make sure that the argument type has kind '*' 356 -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b 357 -- Eg we do not want to allow (D# $ 4.0#) #5570 358 -- (which gives a seg fault) 359 ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) 360 (tcTypeKind arg2_sigma) liftedTypeKind 361 -- Ignore the evidence. arg2_sigma must have type * or #, 362 -- because we know (arg2_sigma -> op_res_ty) is well-kinded 363 -- (because otherwise matchActualFunTys would fail) 364 -- So this 'unifyKind' will either succeed with Refl, or will 365 -- produce an insoluble constraint * ~ #, which we'll report later. 366 367 -- NB: unlike the argument type, the *result* type, op_res_ty can 368 -- have any kind (#8739), so we don't need to check anything for that 369 370 ; op_id <- tcLookupId op_name 371 ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty 372 , arg2_sigma 373 , op_res_ty]) 374 (HsVar noExtField (L lv op_id))) 375 -- arg1' :: arg1_ty 376 -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) 377 -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty 378 379 expr' = OpApp fix (mkLHsWrap wrap_arg1 arg1') op' arg2' 380 381 ; tcWrapResult expr expr' op_res_ty res_ty } 382 383 | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op 384 , Just sig_ty <- obviousSig (unLoc arg1) 385 -- See Note [Disambiguating record fields] 386 = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty 387 ; sel_name <- disambiguateSelector lbl sig_tc_ty 388 ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl)) 389 ; tcExpr (OpApp fix arg1 op' arg2) res_ty 390 } 391 392 | otherwise 393 = do { traceTc "Non Application rule" (ppr op) 394 ; (wrap, op', [HsValArg arg1', HsValArg arg2']) 395 <- tcApp (Just $ mk_op_msg op) 396 op [HsValArg arg1, HsValArg arg2] res_ty 397 ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') } 398 399-- Right sections, equivalent to \ x -> x `op` expr, or 400-- \ x -> op x expr 401 402tcExpr expr@(SectionR x op arg2) res_ty 403 = do { (op', op_ty) <- tcInferFun op 404 ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) 405 <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty 406 ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) 407 (mkVisFunTy arg1_ty op_res_ty) res_ty 408 ; arg2' <- tcArg op arg2 arg2_ty 2 409 ; return ( mkHsWrap wrap_res $ 410 SectionR x (mkLHsWrap wrap_fun op') arg2' ) } 411 where 412 fn_orig = lexprCtOrigin op 413 -- It's important to use the origin of 'op', so that call-stacks 414 -- come out right; they are driven by the OccurrenceOf CtOrigin 415 -- See #13285 416 417tcExpr expr@(SectionL x arg1 op) res_ty 418 = do { (op', op_ty) <- tcInferFun op 419 ; dflags <- getDynFlags -- Note [Left sections] 420 ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 421 | otherwise = 2 422 423 ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) 424 <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 425 n_reqd_args op_ty 426 ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) 427 (mkVisFunTys arg_tys op_res_ty) res_ty 428 ; arg1' <- tcArg op arg1 arg1_ty 1 429 ; return ( mkHsWrap wrap_res $ 430 SectionL x arg1' (mkLHsWrap wrap_fn op') ) } 431 where 432 fn_orig = lexprCtOrigin op 433 -- It's important to use the origin of 'op', so that call-stacks 434 -- come out right; they are driven by the OccurrenceOf CtOrigin 435 -- See #13285 436 437tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty 438 | all tupArgPresent tup_args 439 = do { let arity = length tup_args 440 tup_tc = tupleTyCon boxity arity 441 -- NB: tupleTyCon doesn't flatten 1-tuples 442 -- See Note [Don't flatten tuples from HsSyn] in MkCore 443 ; res_ty <- expTypeToType res_ty 444 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty 445 -- Unboxed tuples have RuntimeRep vars, which we 446 -- don't care about here 447 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon 448 ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys 449 Boxed -> arg_tys 450 ; tup_args1 <- tcTupArgs tup_args arg_tys' 451 ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } 452 453 | otherwise 454 = -- The tup_args are a mixture of Present and Missing (for tuple sections) 455 do { let arity = length tup_args 456 457 ; arg_tys <- case boxity of 458 { Boxed -> newFlexiTyVarTys arity liftedTypeKind 459 ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } 460 ; let actual_res_ty 461 = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args] 462 (mkTupleTy1 boxity arg_tys) 463 -- See Note [Don't flatten tuples from HsSyn] in MkCore 464 465 ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple") 466 (Just expr) 467 actual_res_ty res_ty 468 469 -- Handle tuple sections where 470 ; tup_args1 <- tcTupArgs tup_args arg_tys 471 472 ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) } 473 474tcExpr (ExplicitSum _ alt arity expr) res_ty 475 = do { let sum_tc = sumTyCon arity 476 ; res_ty <- expTypeToType res_ty 477 ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty 478 ; -- Drop levity vars, we don't care about them here 479 let arg_tys' = drop arity arg_tys 480 ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) 481 ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } 482 483-- This will see the empty list only when -XOverloadedLists. 484-- See Note [Empty lists] in GHC.Hs.Expr. 485tcExpr (ExplicitList _ witness exprs) res_ty 486 = case witness of 487 Nothing -> do { res_ty <- expTypeToType res_ty 488 ; (coi, elt_ty) <- matchExpectedListTy res_ty 489 ; exprs' <- mapM (tc_elt elt_ty) exprs 490 ; return $ 491 mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } 492 493 Just fln -> do { ((exprs', elt_ty), fln') 494 <- tcSyntaxOp ListOrigin fln 495 [synKnownType intTy, SynList] res_ty $ 496 \ [elt_ty] -> 497 do { exprs' <- 498 mapM (tc_elt elt_ty) exprs 499 ; return (exprs', elt_ty) } 500 501 ; return $ ExplicitList elt_ty (Just fln') exprs' } 502 where tc_elt elt_ty expr = tcPolyExpr expr elt_ty 503 504{- 505************************************************************************ 506* * 507 Let, case, if, do 508* * 509************************************************************************ 510-} 511 512tcExpr (HsLet x (L l binds) expr) res_ty 513 = do { (binds', expr') <- tcLocalBinds binds $ 514 tcMonoExpr expr res_ty 515 ; return (HsLet x (L l binds') expr') } 516 517tcExpr (HsCase x scrut matches) res_ty 518 = do { -- We used to typecheck the case alternatives first. 519 -- The case patterns tend to give good type info to use 520 -- when typechecking the scrutinee. For example 521 -- case (map f) of 522 -- (x:xs) -> ... 523 -- will report that map is applied to too few arguments 524 -- 525 -- But now, in the GADT world, we need to typecheck the scrutinee 526 -- first, to get type info that may be refined in the case alternatives 527 (scrut', scrut_ty) <- tcInferRho scrut 528 529 ; traceTc "HsCase" (ppr scrut_ty) 530 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty 531 ; return (HsCase x scrut' matches') } 532 where 533 match_ctxt = MC { mc_what = CaseAlt, 534 mc_body = tcBody } 535 536tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' 537 = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) 538 ; res_ty <- tauifyExpType res_ty 539 -- Just like Note [Case branches must never infer a non-tau type] 540 -- in TcMatches (See #10619) 541 542 ; b1' <- tcMonoExpr b1 res_ty 543 ; b2' <- tcMonoExpr b2 res_ty 544 ; return (HsIf x Nothing pred' b1' b2') } 545 546tcExpr (HsIf x (Just fun) pred b1 b2) res_ty 547 = do { ((pred', b1', b2'), fun') 548 <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ 549 \ [pred_ty, b1_ty, b2_ty] -> 550 do { pred' <- tcPolyExpr pred pred_ty 551 ; b1' <- tcPolyExpr b1 b1_ty 552 ; b2' <- tcPolyExpr b2 b2_ty 553 ; return (pred', b1', b2') } 554 ; return (HsIf x (Just fun') pred' b1' b2') } 555 556tcExpr (HsMultiIf _ alts) res_ty 557 = do { res_ty <- if isSingleton alts 558 then return res_ty 559 else tauifyExpType res_ty 560 -- Just like TcMatches 561 -- Note [Case branches must never infer a non-tau type] 562 563 ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts 564 ; res_ty <- readExpType res_ty 565 ; return (HsMultiIf res_ty alts') } 566 where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } 567 568tcExpr (HsDo _ do_or_lc stmts) res_ty 569 = do { expr' <- tcDoStmts do_or_lc stmts res_ty 570 ; return expr' } 571 572tcExpr (HsProc x pat cmd) res_ty 573 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty 574 ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } 575 576-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. 577-- See Note [Grand plan for static forms] in StaticPtrTable for an overview. 578-- To type check 579-- (static e) :: p a 580-- we want to check (e :: a), 581-- and wrap (static e) in a call to 582-- fromStaticPtr :: IsStatic p => StaticPtr a -> p a 583 584tcExpr (HsStatic fvs expr) res_ty 585 = do { res_ty <- expTypeToType res_ty 586 ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty 587 ; (expr', lie) <- captureConstraints $ 588 addErrCtxt (hang (text "In the body of a static form:") 589 2 (ppr expr) 590 ) $ 591 tcPolyExprNC expr expr_ty 592 593 -- Check that the free variables of the static form are closed. 594 -- It's OK to use nonDetEltsUniqSet here as the only side effects of 595 -- checkClosedInStaticForm are error messages. 596 ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs 597 598 -- Require the type of the argument to be Typeable. 599 -- The evidence is not used, but asking the constraint ensures that 600 -- the current implementation is as restrictive as future versions 601 -- of the StaticPointers extension. 602 ; typeableClass <- tcLookupClass typeableClassName 603 ; _ <- emitWantedEvVar StaticOrigin $ 604 mkTyConApp (classTyCon typeableClass) 605 [liftedTypeKind, expr_ty] 606 607 -- Insert the constraints of the static form in a global list for later 608 -- validation. 609 ; emitStaticConstraints lie 610 611 -- Wrap the static form with the 'fromStaticPtr' call. 612 ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName 613 [p_ty] 614 ; let wrap = mkWpTyApps [expr_ty] 615 ; loc <- getSrcSpanM 616 ; return $ mkHsWrapCo co $ HsApp noExtField 617 (L loc $ mkHsWrap wrap fromStaticPtr) 618 (L loc (HsStatic fvs expr')) 619 } 620 621{- 622************************************************************************ 623* * 624 Record construction and update 625* * 626************************************************************************ 627-} 628 629tcExpr expr@(RecordCon { rcon_con_name = L loc con_name 630 , rcon_flds = rbinds }) res_ty 631 = do { con_like <- tcLookupConLike con_name 632 633 -- Check for missing fields 634 ; checkMissingFields con_like rbinds 635 636 ; (con_expr, con_sigma) <- tcInferId con_name 637 ; (con_wrap, con_tau) <- 638 topInstantiate (OccurrenceOf con_name) con_sigma 639 -- a shallow instantiation should really be enough for 640 -- a data constructor. 641 ; let arity = conLikeArity con_like 642 Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau 643 ; case conLikeWrapId_maybe con_like of 644 Nothing -> nonBidirectionalErr (conLikeName con_like) 645 Just con_id -> do { 646 res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon") 647 (Just expr) actual_res_ty res_ty 648 ; rbinds' <- tcRecordBinds con_like arg_tys rbinds 649 ; return $ 650 mkHsWrap res_wrap $ 651 RecordCon { rcon_ext = RecordConTc 652 { rcon_con_like = con_like 653 , rcon_con_expr = mkHsWrap con_wrap con_expr } 654 , rcon_con_name = L loc con_id 655 , rcon_flds = rbinds' } } } 656 657{- 658Note [Type of a record update] 659~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 660The main complication with RecordUpd is that we need to explicitly 661handle the *non-updated* fields. Consider: 662 663 data T a b c = MkT1 { fa :: a, fb :: (b,c) } 664 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } 665 | MkT3 { fd :: a } 666 667 upd :: T a b c -> (b',c) -> T a b' c 668 upd t x = t { fb = x} 669 670The result type should be (T a b' c) 671not (T a b c), because 'b' *is not* mentioned in a non-updated field 672not (T a b' c'), because 'c' *is* mentioned in a non-updated field 673NB that it's not good enough to look at just one constructor; we must 674look at them all; cf #3219 675 676After all, upd should be equivalent to: 677 upd t x = case t of 678 MkT1 p q -> MkT1 p x 679 MkT2 a b -> MkT2 p b 680 MkT3 d -> error ... 681 682So we need to give a completely fresh type to the result record, 683and then constrain it by the fields that are *not* updated ("p" above). 684We call these the "fixed" type variables, and compute them in getFixedTyVars. 685 686Note that because MkT3 doesn't contain all the fields being updated, 687its RHS is simply an error, so it doesn't impose any type constraints. 688Hence the use of 'relevant_cont'. 689 690Note [Implicit type sharing] 691~~~~~~~~~~~~~~~~~~~~~~~~~~~ 692We also take into account any "implicit" non-update fields. For example 693 data T a b where { MkT { f::a } :: T a a; ... } 694So the "real" type of MkT is: forall ab. (a~b) => a -> T a b 695 696Then consider 697 upd t x = t { f=x } 698We infer the type 699 upd :: T a b -> a -> T a b 700 upd (t::T a b) (x::a) 701 = case t of { MkT (co:a~b) (_:a) -> MkT co x } 702We can't give it the more general type 703 upd :: T a b -> c -> T c b 704 705Note [Criteria for update] 706~~~~~~~~~~~~~~~~~~~~~~~~~~ 707We want to allow update for existentials etc, provided the updated 708field isn't part of the existential. For example, this should be ok. 709 data T a where { MkT { f1::a, f2::b->b } :: T a } 710 f :: T a -> b -> T b 711 f t b = t { f1=b } 712 713The criterion we use is this: 714 715 The types of the updated fields 716 mention only the universally-quantified type variables 717 of the data constructor 718 719NB: this is not (quite) the same as being a "naughty" record selector 720(See Note [Naughty record selectors]) in TcTyClsDecls), at least 721in the case of GADTs. Consider 722 data T a where { MkT :: { f :: a } :: T [a] } 723Then f is not "naughty" because it has a well-typed record selector. 724But we don't allow updates for 'f'. (One could consider trying to 725allow this, but it makes my head hurt. Badly. And no one has asked 726for it.) 727 728In principle one could go further, and allow 729 g :: T a -> T a 730 g t = t { f2 = \x -> x } 731because the expression is polymorphic...but that seems a bridge too far. 732 733Note [Data family example] 734~~~~~~~~~~~~~~~~~~~~~~~~~~ 735 data instance T (a,b) = MkT { x::a, y::b } 736 ---> 737 data :TP a b = MkT { a::a, y::b } 738 coTP a b :: T (a,b) ~ :TP a b 739 740Suppose r :: T (t1,t2), e :: t3 741Then r { x=e } :: T (t3,t1) 742 ---> 743 case r |> co1 of 744 MkT x y -> MkT e y |> co2 745 where co1 :: T (t1,t2) ~ :TP t1 t2 746 co2 :: :TP t3 t2 ~ T (t3,t2) 747The wrapping with co2 is done by the constructor wrapper for MkT 748 749Outgoing invariants 750~~~~~~~~~~~~~~~~~~~ 751In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): 752 753 * cons are the data constructors to be updated 754 755 * in_inst_tys, out_inst_tys have same length, and instantiate the 756 *representation* tycon of the data cons. In Note [Data 757 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] 758 759Note [Mixed Record Field Updates] 760~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 761Consider the following pattern synonym. 762 763 data MyRec = MyRec { foo :: Int, qux :: String } 764 765 pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} 766 767This allows updates such as the following 768 769 updater :: MyRec -> MyRec 770 updater a = a {f1 = 1 } 771 772It would also make sense to allow the following update (which we reject). 773 774 updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" 775 776This leads to confusing behaviour when the selectors in fact refer the same 777field. 778 779 updater a = a {f1 = 1, foo = 2} ==? ??? 780 781For this reason, we reject a mixture of pattern synonym and normal record 782selectors in the same update block. Although of course we still allow the 783following. 784 785 updater a = (a {f1 = 1}) {foo = 2} 786 787 > updater (MyRec 0 "str") 788 MyRec 2 "str" 789 790-} 791 792tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty 793 = ASSERT( notNull rbnds ) 794 do { -- STEP -2: typecheck the record_expr, the record to be updated 795 (record_expr', record_rho) <- tcInferRho record_expr 796 797 -- STEP -1 See Note [Disambiguating record fields] 798 -- After this we know that rbinds is unambiguous 799 ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty 800 ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds 801 upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds 802 sel_ids = map selectorAmbiguousFieldOcc upd_flds 803 -- STEP 0 804 -- Check that the field names are really field names 805 -- and they are all field names for proper records or 806 -- all field names for pattern synonyms. 807 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) 808 | fld <- rbinds, 809 -- Excludes class ops 810 let L loc sel_id = hsRecUpdFieldId (unLoc fld), 811 not (isRecordSelector sel_id), 812 let fld_name = idName sel_id ] 813 ; unless (null bad_guys) (sequence bad_guys >> failM) 814 -- See note [Mixed Record Selectors] 815 ; let (data_sels, pat_syn_sels) = 816 partition isDataConRecordSelector sel_ids 817 ; MASSERT( all isPatSynRecordSelector pat_syn_sels ) 818 ; checkTc ( null data_sels || null pat_syn_sels ) 819 ( mixedSelectors data_sels pat_syn_sels ) 820 821 -- STEP 1 822 -- Figure out the tycon and data cons from the first field name 823 ; let -- It's OK to use the non-tc splitters here (for a selector) 824 sel_id : _ = sel_ids 825 826 mtycon :: Maybe TyCon 827 mtycon = case idDetails sel_id of 828 RecSelId (RecSelData tycon) _ -> Just tycon 829 _ -> Nothing 830 831 con_likes :: [ConLike] 832 con_likes = case idDetails sel_id of 833 RecSelId (RecSelData tc) _ 834 -> map RealDataCon (tyConDataCons tc) 835 RecSelId (RecSelPatSyn ps) _ 836 -> [PatSynCon ps] 837 _ -> panic "tcRecordUpd" 838 -- NB: for a data type family, the tycon is the instance tycon 839 840 relevant_cons = conLikesWithFields con_likes upd_fld_occs 841 -- A constructor is only relevant to this process if 842 -- it contains *all* the fields that are being updated 843 -- Other ones will cause a runtime error if they occur 844 845 -- Step 2 846 -- Check that at least one constructor has all the named fields 847 -- i.e. has an empty set of bad fields returned by badFields 848 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) 849 850 -- Take apart a representative constructor 851 ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons 852 (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) 853 = conLikeFullSig con1 854 con1_flds = map flLabel $ conLikeFieldLabels con1 855 con1_tv_tys = mkTyVarTys con1_tvs 856 con1_res_ty = case mtycon of 857 Just tc -> mkFamilyTyConApp tc con1_tv_tys 858 Nothing -> conLikeResTy con1 con1_tv_tys 859 860 -- Check that we're not dealing with a unidirectional pattern 861 -- synonym 862 ; unless (isJust $ conLikeWrapId_maybe con1) 863 (nonBidirectionalErr (conLikeName con1)) 864 865 -- STEP 3 Note [Criteria for update] 866 -- Check that each updated field is polymorphic; that is, its type 867 -- mentions only the universally-quantified variables of the data con 868 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys 869 bad_upd_flds = filter bad_fld flds1_w_tys 870 con1_tv_set = mkVarSet con1_tvs 871 bad_fld (fld, ty) = fld `elem` upd_fld_occs && 872 not (tyCoVarsOfType ty `subVarSet` con1_tv_set) 873 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) 874 875 -- STEP 4 Note [Type of a record update] 876 -- Figure out types for the scrutinee and result 877 -- Both are of form (T a b c), with fresh type variables, but with 878 -- common variables where the scrutinee and result must have the same type 879 -- These are variables that appear in *any* arg of *any* of the 880 -- relevant constructors *except* in the updated fields 881 -- 882 ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons 883 is_fixed_tv tv = tv `elemVarSet` fixed_tvs 884 885 mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) 886 -- Deals with instantiation of kind variables 887 -- c.f. TcMType.newMetaTyVars 888 mk_inst_ty subst (tv, result_inst_ty) 889 | is_fixed_tv tv -- Same as result type 890 = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) 891 | otherwise -- Fresh type, of correct kind 892 = do { (subst', new_tv) <- newMetaTyVarX subst tv 893 ; return (subst', mkTyVarTy new_tv) } 894 895 ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs 896 ; let result_inst_tys = mkTyVarTys con1_tvs' 897 init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) 898 899 ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst 900 (con1_tvs `zip` result_inst_tys) 901 902 ; let rec_res_ty = TcType.substTy result_subst con1_res_ty 903 scrut_ty = TcType.substTy scrut_subst con1_res_ty 904 con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys 905 906 ; wrap_res <- tcSubTypeHR (exprCtOrigin expr) 907 (Just expr) rec_res_ty res_ty 908 ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty 909 -- NB: normal unification is OK here (as opposed to subsumption), 910 -- because for this to work out, both record_rho and scrut_ty have 911 -- to be normal datatypes -- no contravariant stuff can go on 912 913 -- STEP 5 914 -- Typecheck the bindings 915 ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds 916 917 -- STEP 6: Deal with the stupid theta 918 ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) 919 ; instStupidTheta RecordUpdOrigin theta' 920 921 -- Step 7: make a cast for the scrutinee, in the 922 -- case that it's from a data family 923 ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty 924 fam_co | Just tycon <- mtycon 925 , Just co_con <- tyConFamilyCoercion_maybe tycon 926 = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) 927 | otherwise 928 = idHsWrapper 929 930 -- Step 8: Check that the req constraints are satisfied 931 -- For normal data constructors req_theta is empty but we must do 932 -- this check for pattern synonyms. 933 ; let req_theta' = substThetaUnchecked scrut_subst req_theta 934 ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' 935 936 -- Phew! 937 ; return $ 938 mkHsWrap wrap_res $ 939 RecordUpd { rupd_expr 940 = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') 941 , rupd_flds = rbinds' 942 , rupd_ext = RecordUpdTc 943 { rupd_cons = relevant_cons 944 , rupd_in_tys = scrut_inst_tys 945 , rupd_out_tys = result_inst_tys 946 , rupd_wrap = req_wrap }} } 947 948tcExpr e@(HsRecFld _ f) res_ty 949 = tcCheckRecSelId e f res_ty 950 951{- 952************************************************************************ 953* * 954 Arithmetic sequences e.g. [a,b..] 955 and their parallel-array counterparts e.g. [: a,b.. :] 956 957* * 958************************************************************************ 959-} 960 961tcExpr (ArithSeq _ witness seq) res_ty 962 = tcArithSeq witness seq res_ty 963 964{- 965************************************************************************ 966* * 967 Template Haskell 968* * 969************************************************************************ 970-} 971 972-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'. 973-- Here we get rid of it and add the finalizers to the global environment. 974-- 975-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. 976tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) 977 res_ty 978 = do addModFinalizersWithLclEnv mod_finalizers 979 tcExpr expr res_ty 980tcExpr (HsSpliceE _ splice) res_ty 981 = tcSpliceExpr splice res_ty 982tcExpr e@(HsBracket _ brack) res_ty 983 = tcTypedBracket e brack res_ty 984tcExpr e@(HsRnBracketOut _ brack ps) res_ty 985 = tcUntypedBracket e brack ps res_ty 986 987{- 988************************************************************************ 989* * 990 Catch-all 991* * 992************************************************************************ 993-} 994 995tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) 996 -- Include ArrForm, ArrApp, which shouldn't appear at all 997 -- Also HsTcBracketOut, HsQuasiQuoteE 998 999{- 1000************************************************************************ 1001* * 1002 Arithmetic sequences [a..b] etc 1003* * 1004************************************************************************ 1005-} 1006 1007tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType 1008 -> TcM (HsExpr GhcTcId) 1009 1010tcArithSeq witness seq@(From expr) res_ty 1011 = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty 1012 ; expr' <- tcPolyExpr expr elt_ty 1013 ; enum_from <- newMethodFromName (ArithSeqOrigin seq) 1014 enumFromName [elt_ty] 1015 ; return $ mkHsWrap wrap $ 1016 ArithSeq enum_from wit' (From expr') } 1017 1018tcArithSeq witness seq@(FromThen expr1 expr2) res_ty 1019 = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty 1020 ; expr1' <- tcPolyExpr expr1 elt_ty 1021 ; expr2' <- tcPolyExpr expr2 elt_ty 1022 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) 1023 enumFromThenName [elt_ty] 1024 ; return $ mkHsWrap wrap $ 1025 ArithSeq enum_from_then wit' (FromThen expr1' expr2') } 1026 1027tcArithSeq witness seq@(FromTo expr1 expr2) res_ty 1028 = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty 1029 ; expr1' <- tcPolyExpr expr1 elt_ty 1030 ; expr2' <- tcPolyExpr expr2 elt_ty 1031 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) 1032 enumFromToName [elt_ty] 1033 ; return $ mkHsWrap wrap $ 1034 ArithSeq enum_from_to wit' (FromTo expr1' expr2') } 1035 1036tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty 1037 = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty 1038 ; expr1' <- tcPolyExpr expr1 elt_ty 1039 ; expr2' <- tcPolyExpr expr2 elt_ty 1040 ; expr3' <- tcPolyExpr expr3 elt_ty 1041 ; eft <- newMethodFromName (ArithSeqOrigin seq) 1042 enumFromThenToName [elt_ty] 1043 ; return $ mkHsWrap wrap $ 1044 ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } 1045 1046----------------- 1047arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType 1048 -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc)) 1049arithSeqEltType Nothing res_ty 1050 = do { res_ty <- expTypeToType res_ty 1051 ; (coi, elt_ty) <- matchExpectedListTy res_ty 1052 ; return (mkWpCastN coi, elt_ty, Nothing) } 1053arithSeqEltType (Just fl) res_ty 1054 = do { (elt_ty, fl') 1055 <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ 1056 \ [elt_ty] -> return elt_ty 1057 ; return (idHsWrapper, elt_ty, Just fl') } 1058 1059{- 1060************************************************************************ 1061* * 1062 Applications 1063* * 1064************************************************************************ 1065-} 1066 1067-- HsArg is defined in GHC.Hs.Types 1068 1069wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn) 1070 => LHsExpr (GhcPass id) 1071 -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)] 1072 -> LHsExpr (GhcPass id) 1073wrapHsArgs f [] = f 1074wrapHsArgs f (HsValArg a : args) = wrapHsArgs (mkHsApp f a) args 1075wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t) args 1076wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExtField f) args 1077 1078isHsValArg :: HsArg tm ty -> Bool 1079isHsValArg (HsValArg {}) = True 1080isHsValArg (HsTypeArg {}) = False 1081isHsValArg (HsArgPar {}) = False 1082 1083isArgPar :: HsArg tm ty -> Bool 1084isArgPar (HsArgPar {}) = True 1085isArgPar (HsValArg {}) = False 1086isArgPar (HsTypeArg {}) = False 1087 1088isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d) 1089isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp 1090isArgPar_maybe _ = Nothing 1091 1092type LHsExprArgIn = HsArg (LHsExpr GhcRn) (LHsWcType GhcRn) 1093type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn) 1094 1095tcApp1 :: HsExpr GhcRn -- either HsApp or HsAppType 1096 -> ExpRhoType -> TcM (HsExpr GhcTcId) 1097tcApp1 e res_ty 1098 = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty 1099 ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) } 1100 1101tcApp :: Maybe SDoc -- like "The function `f' is applied to" 1102 -- or leave out to get exactly that message 1103 -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args 1104 -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) 1105 -- (wrap, fun, args). For an ordinary function application, 1106 -- these should be assembled as (wrap (fun args)). 1107 -- But OpApp is slightly different, so that's why the caller 1108 -- must assemble 1109 1110tcApp m_herald (L sp (HsPar _ fun)) args res_ty 1111 = tcApp m_herald fun (HsArgPar sp : args) res_ty 1112 1113tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty 1114 = tcApp m_herald fun (HsValArg arg1 : args) res_ty 1115 1116tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty 1117 = tcApp m_herald fun (HsTypeArg noSrcSpan ty1 : args) res_ty 1118 1119tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty 1120 | Ambiguous _ lbl <- fld_lbl -- Still ambiguous 1121 , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first 1122 , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates 1123 = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty 1124 ; sel_name <- disambiguateSelector lbl sig_tc_ty 1125 ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) 1126 ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty } 1127 1128tcApp _m_herald (L loc (HsVar _ (L _ fun_id))) args res_ty 1129 -- Special typing rule for tagToEnum# 1130 | fun_id `hasKey` tagToEnumKey 1131 , n_val_args == 1 1132 = tcTagToEnum loc fun_id args res_ty 1133 where 1134 n_val_args = count isHsValArg args 1135 1136tcApp m_herald fun args res_ty 1137 = do { (tc_fun, fun_ty) <- tcInferFun fun 1138 ; tcFunApp m_herald fun tc_fun fun_ty args res_ty } 1139 1140--------------------- 1141tcFunApp :: Maybe SDoc -- like "The function `f' is applied to" 1142 -- or leave out to get exactly that message 1143 -> LHsExpr GhcRn -- Renamed function 1144 -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type 1145 -> [LHsExprArgIn] -- Arguments 1146 -> ExpRhoType -- Overall result type 1147 -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) 1148 -- (wrapper-for-result, fun, args) 1149 -- For an ordinary function application, 1150 -- these should be assembled as wrap_res[ fun args ] 1151 -- But OpApp is slightly different, so that's why the caller 1152 -- must assemble 1153 1154-- tcFunApp deals with the general case; 1155-- the special cases are handled by tcApp 1156tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty 1157 = do { let orig = lexprCtOrigin rn_fun 1158 1159 ; traceTc "tcFunApp" (ppr rn_fun <+> dcolon <+> ppr fun_sigma $$ ppr rn_args $$ ppr res_ty) 1160 ; (wrap_fun, tc_args, actual_res_ty) 1161 <- tcArgs rn_fun fun_sigma orig rn_args 1162 (m_herald `orElse` mk_app_msg rn_fun rn_args) 1163 1164 -- this is just like tcWrapResult, but the types don't line 1165 -- up to call that function 1166 ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $ 1167 tcSubTypeDS_NC_O orig GenSigCtxt 1168 (Just $ unLoc $ wrapHsArgs rn_fun rn_args) 1169 actual_res_ty res_ty 1170 1171 ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) } 1172 1173mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc 1174mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr) 1175 , text "is applied to"] 1176 where 1177 what | null type_app_args = "function" 1178 | otherwise = "expression" 1179 -- Include visible type arguments (but not other arguments) in the herald. 1180 -- See Note [Herald for matchExpectedFunTys] in TcUnify. 1181 expr = mkHsAppTypes fun type_app_args 1182 type_app_args = [hs_ty | HsTypeArg _ hs_ty <- args] 1183 1184mk_op_msg :: LHsExpr GhcRn -> SDoc 1185mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" 1186 1187---------------- 1188tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) 1189-- Infer type of a function 1190tcInferFun (L loc (HsVar _ (L _ name))) 1191 = do { (fun, ty) <- setSrcSpan loc (tcInferId name) 1192 -- Don't wrap a context around a plain Id 1193 ; return (L loc fun, ty) } 1194 1195tcInferFun (L loc (HsRecFld _ f)) 1196 = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) 1197 -- Don't wrap a context around a plain Id 1198 ; return (L loc fun, ty) } 1199 1200tcInferFun fun 1201 = tcInferSigma fun 1202 -- NB: tcInferSigma; see TcUnify 1203 -- Note [Deep instantiation of InferResult] in TcUnify 1204 1205 1206---------------- 1207-- | Type-check the arguments to a function, possibly including visible type 1208-- applications 1209tcArgs :: LHsExpr GhcRn -- ^ The function itself (for err msgs only) 1210 -> TcSigmaType -- ^ the (uninstantiated) type of the function 1211 -> CtOrigin -- ^ the origin for the function's type 1212 -> [LHsExprArgIn] -- ^ the args 1213 -> SDoc -- ^ the herald for matchActualFunTys 1214 -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType) 1215 -- ^ (a wrapper for the function, the tc'd args, result type) 1216tcArgs fun orig_fun_ty fun_orig orig_args herald 1217 = go [] 1 orig_fun_ty orig_args 1218 where 1219 -- Don't count visible type arguments when determining how many arguments 1220 -- an expression is given in an arity mismatch error, since visible type 1221 -- arguments reported as a part of the expression herald itself. 1222 -- See Note [Herald for matchExpectedFunTys] in TcUnify. 1223 orig_expr_args_arity = count isHsValArg orig_args 1224 1225 fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] 1226 = case fun of 1227 L _ (HsUnboundVar {}) -> True 1228 _ -> False 1229 1230 go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty) 1231 1232 go acc_args n fun_ty (HsArgPar sp : args) 1233 = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args 1234 ; return (inner_wrap, HsArgPar sp : args', res_ty) 1235 } 1236 1237 go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args) 1238 | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] 1239 = go acc_args (n+1) fun_ty args 1240 1241 | otherwise 1242 = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty 1243 -- wrap1 :: fun_ty "->" upsilon_ty 1244 ; case tcSplitForAllTy_maybe upsilon_ty of 1245 Just (tvb, inner_ty) 1246 | binderArgFlag tvb == Specified -> 1247 -- It really can't be Inferred, because we've justn 1248 -- instantiated those. But, oddly, it might just be Required. 1249 -- See Note [Required quantifiers in the type of a term] 1250 do { let tv = binderVar tvb 1251 kind = tyVarKind tv 1252 ; ty_arg <- tcHsTypeApp hs_ty_arg kind 1253 1254 ; inner_ty <- zonkTcType inner_ty 1255 -- See Note [Visible type application zonk] 1256 ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) 1257 1258 insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty 1259 -- NB: tv and ty_arg have the same kind, so this 1260 -- substitution is kind-respecting 1261 ; traceTc "VTA" (vcat [ppr tv, debugPprType kind 1262 , debugPprType ty_arg 1263 , debugPprType (tcTypeKind ty_arg) 1264 , debugPprType inner_ty 1265 , debugPprType insted_ty ]) 1266 1267 ; (inner_wrap, args', res_ty) 1268 <- go acc_args (n+1) insted_ty args 1269 -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty 1270 ; let inst_wrap = mkWpTyApps [ty_arg] 1271 ; return ( inner_wrap <.> inst_wrap <.> wrap1 1272 , HsTypeArg l hs_ty_arg : args' 1273 , res_ty ) } 1274 _ -> ty_app_err upsilon_ty hs_ty_arg } 1275 1276 go acc_args n fun_ty (HsValArg arg : args) 1277 = do { (wrap, [arg_ty], res_ty) 1278 <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty 1279 acc_args orig_expr_args_arity 1280 -- wrap :: fun_ty "->" arg_ty -> res_ty 1281 ; arg' <- tcArg fun arg arg_ty n 1282 ; (inner_wrap, args', inner_res_ty) 1283 <- go (arg_ty : acc_args) (n+1) res_ty args 1284 -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty 1285 ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap 1286 , HsValArg arg' : args' 1287 , inner_res_ty ) } 1288 where 1289 doc = text "When checking the" <+> speakNth n <+> 1290 text "argument to" <+> quotes (ppr fun) 1291 1292 ty_app_err ty arg 1293 = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty 1294 ; failWith $ 1295 text "Cannot apply expression of type" <+> quotes (ppr ty) $$ 1296 text "to a visible type argument" <+> quotes (ppr arg) } 1297 1298{- Note [Required quantifiers in the type of a term] 1299~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1300Consider (#15859) 1301 1302 data A k :: k -> Type -- A :: forall k -> k -> Type 1303 type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type 1304 a = (undefind :: KindOf A) @Int 1305 1306With ImpredicativeTypes (thin ice, I know), we instantiate 1307KindOf at type (forall k -> k -> Type), so 1308 KindOf A = forall k -> k -> Type 1309whose first argument is Required 1310 1311We want to reject this type application to Int, but in earlier 1312GHCs we had an ASSERT that Required could not occur here. 1313 1314The ice is thin; c.f. Note [No Required TyCoBinder in terms] 1315in TyCoRep. 1316 1317Note [VTA for out-of-scope functions] 1318~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1319Suppose 'wurble' is not in scope, and we have 1320 (wurble @Int @Bool True 'x') 1321 1322Then the renamer will make (HsUnboundVar "wurble) for 'wurble', 1323and the typechecker will typecheck it with tcUnboundId, giving it 1324a type 'alpha', and emitting a deferred CHoleCan constraint, to 1325be reported later. 1326 1327But then comes the visible type application. If we do nothing, we'll 1328generate an immediate failure (in tc_app_err), saying that a function 1329of type 'alpha' can't be applied to Bool. That's insane! And indeed 1330users complain bitterly (#13834, #17150.) 1331 1332The right error is the CHoleCan, which has /already/ been emitted by 1333tcUnboundId. It later reports 'wurble' as out of scope, and tries to 1334give its type. 1335 1336Fortunately in tcArgs we still have access to the function, so we can 1337check if it is a HsUnboundVar. We use this info to simply skip over 1338any visible type arguments. We've already inferred the type of the 1339function, so we'll /already/ have emitted a CHoleCan constraint; 1340failing preserves that constraint. 1341 1342We do /not/ want to fail altogether in this case (via failM) becuase 1343that may abandon an entire instance decl, which (in the presence of 1344-fdefer-type-errors) leads to leading to #17792. 1345 1346Downside; the typechecked term has lost its visible type arguments; we 1347don't even kind-check them. But let's jump that bridge if we come to 1348it. Meanwhile, let's not crash! 1349 1350Note [Visible type application zonk] 1351~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1352* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). 1353 1354* tcHsTypeApp only guarantees that 1355 - ty_arg is zonked 1356 - kind(zonk(tv)) = kind(ty_arg) 1357 (checkExpectedKind zonks as it goes). 1358 1359So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) 1360and inner_ty. Otherwise we can build an ill-kinded type. An example was 1361#14158, where we had: 1362 id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a 1363and we had the visible type application 1364 id @(->) 1365 1366* We instantiated k := kappa, yielding 1367 forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a 1368* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). 1369* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, 1370 Here q1 :: RuntimeRep 1371* Now we substitute 1372 cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * 1373 but we must first zonk the inner_ty to get 1374 forall (a :: TYPE q1). cat a a 1375 so that the result of substitution is well-kinded 1376 Failing to do so led to #14158. 1377-} 1378 1379---------------- 1380tcArg :: LHsExpr GhcRn -- The function (for error messages) 1381 -> LHsExpr GhcRn -- Actual arguments 1382 -> TcRhoType -- expected arg type 1383 -> Int -- # of argument 1384 -> TcM (LHsExpr GhcTcId) -- Resulting argument 1385tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ 1386 tcPolyExprNC arg ty 1387 1388---------------- 1389tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId] 1390tcTupArgs args tys 1391 = ASSERT( equalLength args tys ) mapM go (args `zip` tys) 1392 where 1393 go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) 1394 go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty 1395 ; return (L l (Present x expr')) } 1396 go (L _ (XTupArg nec), _) = noExtCon nec 1397 1398--------------------------- 1399-- See TcType.SyntaxOpType also for commentary 1400tcSyntaxOp :: CtOrigin 1401 -> SyntaxExpr GhcRn 1402 -> [SyntaxOpType] -- ^ shape of syntax operator arguments 1403 -> ExpRhoType -- ^ overall result type 1404 -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments 1405 -> TcM (a, SyntaxExpr GhcTcId) 1406-- ^ Typecheck a syntax operator 1407-- The operator is a variable or a lambda at this stage (i.e. renamer 1408-- output) 1409tcSyntaxOp orig expr arg_tys res_ty 1410 = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) 1411 1412-- | Slightly more general version of 'tcSyntaxOp' that allows the caller 1413-- to specify the shape of the result of the syntax operator 1414tcSyntaxOpGen :: CtOrigin 1415 -> SyntaxExpr GhcRn 1416 -> [SyntaxOpType] 1417 -> SyntaxOpType 1418 -> ([TcSigmaType] -> TcM a) 1419 -> TcM (a, SyntaxExpr GhcTcId) 1420tcSyntaxOpGen orig op arg_tys res_ty thing_inside 1421 = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op 1422 ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) 1423 ; (result, expr_wrap, arg_wraps, res_wrap) 1424 <- tcSynArgA orig sigma arg_tys res_ty $ 1425 thing_inside 1426 ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) 1427 ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr 1428 , syn_arg_wraps = arg_wraps 1429 , syn_res_wrap = res_wrap }) } 1430 1431{- 1432Note [tcSynArg] 1433~~~~~~~~~~~~~~~ 1434Because of the rich structure of SyntaxOpType, we must do the 1435contra-/covariant thing when working down arrows, to get the 1436instantiation vs. skolemisation decisions correct (and, more 1437obviously, the orientation of the HsWrappers). We thus have 1438two tcSynArgs. 1439-} 1440 1441-- works on "expected" types, skolemising where necessary 1442-- See Note [tcSynArg] 1443tcSynArgE :: CtOrigin 1444 -> TcSigmaType 1445 -> SyntaxOpType -- ^ shape it is expected to have 1446 -> ([TcSigmaType] -> TcM a) -- ^ check the arguments 1447 -> TcM (a, HsWrapper) 1448 -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) 1449tcSynArgE orig sigma_ty syn_ty thing_inside 1450 = do { (skol_wrap, (result, ty_wrapper)) 1451 <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty -> 1452 go rho_ty syn_ty 1453 ; return (result, skol_wrap <.> ty_wrapper) } 1454 where 1455 go rho_ty SynAny 1456 = do { result <- thing_inside [rho_ty] 1457 ; return (result, idHsWrapper) } 1458 1459 go rho_ty SynRho -- same as SynAny, because we skolemise eagerly 1460 = do { result <- thing_inside [rho_ty] 1461 ; return (result, idHsWrapper) } 1462 1463 go rho_ty SynList 1464 = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty 1465 ; result <- thing_inside [elt_ty] 1466 ; return (result, mkWpCastN list_co) } 1467 1468 go rho_ty (SynFun arg_shape res_shape) 1469 = do { ( ( ( (result, arg_ty, res_ty) 1470 , res_wrapper ) -- :: res_ty_out "->" res_ty 1471 , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out 1472 , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty 1473 <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $ 1474 \ [arg_ty] res_ty -> 1475 do { arg_tc_ty <- expTypeToType arg_ty 1476 ; res_tc_ty <- expTypeToType res_ty 1477 1478 -- another nested arrow is too much for now, 1479 -- but I bet we'll never need this 1480 ; MASSERT2( case arg_shape of 1481 SynFun {} -> False; 1482 _ -> True 1483 , text "Too many nested arrows in SyntaxOpType" $$ 1484 pprCtOrigin orig ) 1485 1486 ; tcSynArgA orig arg_tc_ty [] arg_shape $ 1487 \ arg_results -> 1488 tcSynArgE orig res_tc_ty res_shape $ 1489 \ res_results -> 1490 do { result <- thing_inside (arg_results ++ res_results) 1491 ; return (result, arg_tc_ty, res_tc_ty) }} 1492 1493 ; return ( result 1494 , match_wrapper <.> 1495 mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper 1496 arg_ty res_ty doc ) } 1497 where 1498 herald = text "This rebindable syntax expects a function with" 1499 doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig 1500 1501 go rho_ty (SynType the_ty) 1502 = do { wrap <- tcSubTypeET orig GenSigCtxt the_ty rho_ty 1503 ; result <- thing_inside [] 1504 ; return (result, wrap) } 1505 1506-- works on "actual" types, instantiating where necessary 1507-- See Note [tcSynArg] 1508tcSynArgA :: CtOrigin 1509 -> TcSigmaType 1510 -> [SyntaxOpType] -- ^ argument shapes 1511 -> SyntaxOpType -- ^ result shape 1512 -> ([TcSigmaType] -> TcM a) -- ^ check the arguments 1513 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) 1514 -- ^ returns a wrapper to be applied to the original function, 1515 -- wrappers to be applied to arguments 1516 -- and a wrapper to be applied to the overall expression 1517tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside 1518 = do { (match_wrapper, arg_tys, res_ty) 1519 <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty 1520 -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) 1521 ; ((result, res_wrapper), arg_wrappers) 1522 <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> 1523 tc_syn_arg res_ty res_shape $ \ res_results -> 1524 thing_inside (arg_results ++ res_results) 1525 ; return (result, match_wrapper, arg_wrappers, res_wrapper) } 1526 where 1527 herald = text "This rebindable syntax expects a function with" 1528 1529 tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] 1530 -> ([TcSigmaType] -> TcM a) 1531 -> TcM (a, [HsWrapper]) 1532 -- the wrappers are for arguments 1533 tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside 1534 = do { ((result, arg_wraps), arg_wrap) 1535 <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results -> 1536 tc_syn_args_e arg_tys arg_shapes $ \ args_results -> 1537 thing_inside (arg1_results ++ args_results) 1538 ; return (result, arg_wrap : arg_wraps) } 1539 tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] 1540 1541 tc_syn_arg :: TcSigmaType -> SyntaxOpType 1542 -> ([TcSigmaType] -> TcM a) 1543 -> TcM (a, HsWrapper) 1544 -- the wrapper applies to the overall result 1545 tc_syn_arg res_ty SynAny thing_inside 1546 = do { result <- thing_inside [res_ty] 1547 ; return (result, idHsWrapper) } 1548 tc_syn_arg res_ty SynRho thing_inside 1549 = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty 1550 -- inst_wrap :: res_ty "->" rho_ty 1551 ; result <- thing_inside [rho_ty] 1552 ; return (result, inst_wrap) } 1553 tc_syn_arg res_ty SynList thing_inside 1554 = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty 1555 -- inst_wrap :: res_ty "->" rho_ty 1556 ; (list_co, elt_ty) <- matchExpectedListTy rho_ty 1557 -- list_co :: [elt_ty] ~N rho_ty 1558 ; result <- thing_inside [elt_ty] 1559 ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } 1560 tc_syn_arg _ (SynFun {}) _ 1561 = pprPanic "tcSynArgA hits a SynFun" (ppr orig) 1562 tc_syn_arg res_ty (SynType the_ty) thing_inside 1563 = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty 1564 ; result <- thing_inside [] 1565 ; return (result, wrap) } 1566 1567{- 1568Note [Push result type in] 1569~~~~~~~~~~~~~~~~~~~~~~~~~~ 1570Unify with expected result before type-checking the args so that the 1571info from res_ty percolates to args. This is when we might detect a 1572too-few args situation. (One can think of cases when the opposite 1573order would give a better error message.) 1574experimenting with putting this first. 1575 1576Here's an example where it actually makes a real difference 1577 1578 class C t a b | t a -> b 1579 instance C Char a Bool 1580 1581 data P t a = forall b. (C t a b) => MkP b 1582 data Q t = MkQ (forall a. P t a) 1583 1584 f1, f2 :: Q Char; 1585 f1 = MkQ (MkP True) 1586 f2 = MkQ (MkP True :: forall a. P Char a) 1587 1588With the change, f1 will type-check, because the 'Char' info from 1589the signature is propagated into MkQ's argument. With the check 1590in the other order, the extra signature in f2 is reqd. 1591 1592************************************************************************ 1593* * 1594 Expressions with a type signature 1595 expr :: type 1596* * 1597********************************************************************* -} 1598 1599tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType) 1600tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) 1601 = setSrcSpan loc $ -- Sets the location for the implication constraint 1602 do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id 1603 ; given <- newEvVars theta 1604 ; traceTc "tcExprSig: CompleteSig" $ 1605 vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id) 1606 , text "tv_prs:" <+> ppr tv_prs ] 1607 1608 ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs 1609 skol_tvs = map snd tv_prs 1610 ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $ 1611 tcExtendNameTyVarEnv tv_prs $ 1612 tcPolyExprNC expr tau 1613 1614 ; let poly_wrap = mkWpTyLams skol_tvs 1615 <.> mkWpLams given 1616 <.> mkWpLet ev_binds 1617 ; return (mkLHsWrap poly_wrap expr', idType poly_id) } 1618 1619tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) 1620 = setSrcSpan loc $ -- Sets the location for the implication constraint 1621 do { (tclvl, wanted, (expr', sig_inst)) 1622 <- pushLevelAndCaptureConstraints $ 1623 do { sig_inst <- tcInstSig sig 1624 ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $ 1625 tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ 1626 tcPolyExprNC expr (sig_inst_tau sig_inst) 1627 ; return (expr', sig_inst) } 1628 -- See Note [Partial expression signatures] 1629 ; let tau = sig_inst_tau sig_inst 1630 infer_mode | null (sig_inst_theta sig_inst) 1631 , isNothing (sig_inst_wcx sig_inst) 1632 = ApplyMR 1633 | otherwise 1634 = NoRestrictions 1635 ; (qtvs, givens, ev_binds, residual, _) 1636 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted 1637 ; emitConstraints residual 1638 1639 ; tau <- zonkTcType tau 1640 ; let inferred_theta = map evVarPred givens 1641 tau_tvs = tyCoVarsOfType tau 1642 ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta 1643 tau_tvs qtvs (Just sig_inst) 1644 ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau 1645 my_sigma = mkForAllTys binders (mkPhiTy my_theta tau) 1646 ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. 1647 then return idHsWrapper -- Fast path; also avoids complaint when we infer 1648 -- an ambiguous type and have AllowAmbiguousType 1649 -- e..g infer x :: forall a. F a -> Int 1650 else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma 1651 1652 ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) 1653 ; let poly_wrap = wrap 1654 <.> mkWpTyLams qtvs 1655 <.> mkWpLams givens 1656 <.> mkWpLet ev_binds 1657 ; return (mkLHsWrap poly_wrap expr', my_sigma) } 1658 1659 1660{- Note [Partial expression signatures] 1661~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1662Partial type signatures on expressions are easy to get wrong. But 1663here is a guiding principile 1664 e :: ty 1665should behave like 1666 let x :: ty 1667 x = e 1668 in x 1669 1670So for partial signatures we apply the MR if no context is given. So 1671 e :: IO _ apply the MR 1672 e :: _ => IO _ do not apply the MR 1673just like in TcBinds.decideGeneralisationPlan 1674 1675This makes a difference (#11670): 1676 peek :: Ptr a -> IO CLong 1677 peek ptr = peekElemOff undefined 0 :: _ 1678from (peekElemOff undefined 0) we get 1679 type: IO w 1680 constraints: Storable w 1681 1682We must NOT try to generalise over 'w' because the signature specifies 1683no constraints so we'll complain about not being able to solve 1684Storable w. Instead, don't generalise; then _ gets instantiated to 1685CLong, as it should. 1686-} 1687 1688{- ********************************************************************* 1689* * 1690 tcInferId 1691* * 1692********************************************************************* -} 1693 1694tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) 1695tcCheckId name res_ty 1696 = do { (expr, actual_res_ty) <- tcInferId name 1697 ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) 1698 ; addFunResCtxt False (HsVar noExtField (noLoc name)) actual_res_ty res_ty $ 1699 tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr 1700 actual_res_ty res_ty } 1701 1702tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) 1703tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty 1704 = do { (expr, actual_res_ty) <- tcInferRecSelId f 1705 ; addFunResCtxt False (HsRecFld noExtField f) actual_res_ty res_ty $ 1706 tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } 1707tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty 1708 = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of 1709 Nothing -> ambiguousSelector lbl 1710 Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg 1711 ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) 1712 res_ty } 1713tcCheckRecSelId _ (XAmbiguousFieldOcc nec) _ = noExtCon nec 1714 1715------------------------ 1716tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) 1717tcInferRecSelId (Unambiguous sel (L _ lbl)) 1718 = do { (expr', ty) <- tc_infer_id lbl sel 1719 ; return (expr', ty) } 1720tcInferRecSelId (Ambiguous _ lbl) 1721 = ambiguousSelector lbl 1722tcInferRecSelId (XAmbiguousFieldOcc nec) = noExtCon nec 1723 1724------------------------ 1725tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) 1726-- Look up an occurrence of an Id 1727-- Do not instantiate its type 1728tcInferId id_name 1729 | id_name `hasKey` tagToEnumKey 1730 = failWithTc (text "tagToEnum# must appear applied to one argument") 1731 -- tcApp catches the case (tagToEnum# arg) 1732 1733 | id_name `hasKey` assertIdKey 1734 = do { dflags <- getDynFlags 1735 ; if gopt Opt_IgnoreAsserts dflags 1736 then tc_infer_id (nameRdrName id_name) id_name 1737 else tc_infer_assert id_name } 1738 1739 | otherwise 1740 = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name 1741 ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) 1742 ; return (expr, ty) } 1743 1744tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) 1745-- Deal with an occurrence of 'assert' 1746-- See Note [Adding the implicit parameter to 'assert'] 1747tc_infer_assert assert_name 1748 = do { assert_error_id <- tcLookupId assertErrorName 1749 ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) 1750 (idType assert_error_id) 1751 ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) 1752 } 1753 1754tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType) 1755tc_infer_id lbl id_name 1756 = do { thing <- tcLookup id_name 1757 ; case thing of 1758 ATcId { tct_id = id } 1759 -> do { check_naughty id -- Note [Local record selectors] 1760 ; checkThLocalId id 1761 ; return_id id } 1762 1763 AGlobal (AnId id) 1764 -> do { check_naughty id 1765 ; return_id id } 1766 -- A global cannot possibly be ill-staged 1767 -- nor does it need the 'lifting' treatment 1768 -- hence no checkTh stuff here 1769 1770 AGlobal (AConLike cl) -> case cl of 1771 RealDataCon con -> return_data_con con 1772 PatSynCon ps -> tcPatSynBuilderOcc ps 1773 1774 _ -> failWithTc $ 1775 ppr thing <+> text "used where a value identifier was expected" } 1776 where 1777 return_id id = return (HsVar noExtField (noLoc id), idType id) 1778 1779 return_data_con con 1780 -- For data constructors, must perform the stupid-theta check 1781 | null stupid_theta 1782 = return (HsConLikeOut noExtField (RealDataCon con), con_ty) 1783 1784 | otherwise 1785 -- See Note [Instantiating stupid theta] 1786 = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty 1787 ; (subst, tvs') <- newMetaTyVars tvs 1788 ; let tys' = mkTyVarTys tvs' 1789 theta' = substTheta subst theta 1790 rho' = substTy subst rho 1791 ; wrap <- instCall (OccurrenceOf id_name) tys' theta' 1792 ; addDataConStupidTheta con tys' 1793 ; return ( mkHsWrap wrap (HsConLikeOut noExtField (RealDataCon con)) 1794 , rho') } 1795 1796 where 1797 con_ty = dataConUserType con 1798 stupid_theta = dataConStupidTheta con 1799 1800 check_naughty id 1801 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) 1802 | otherwise = return () 1803 1804 1805tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId) 1806-- Typecheck an occurrence of an unbound Id 1807-- 1808-- Some of these started life as a true expression hole "_". 1809-- Others might simply be variables that accidentally have no binding site 1810-- 1811-- We turn all of them into HsVar, since HsUnboundVar can't contain an 1812-- Id; and indeed the evidence for the CHoleCan does bind it, so it's 1813-- not unbound any more! 1814tcUnboundId rn_expr unbound res_ty 1815 = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) 1816 ; let occ = unboundVarOcc unbound 1817 ; name <- newSysName occ 1818 ; let ev = mkLocalId name ty 1819 ; can <- newHoleCt (ExprHole unbound) ev ty 1820 ; emitInsoluble can 1821 ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr 1822 (HsVar noExtField (noLoc ev)) ty res_ty } 1823 1824 1825{- 1826Note [Adding the implicit parameter to 'assert'] 1827~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1828The typechecker transforms (assert e1 e2) to (assertError e1 e2). 1829This isn't really the Right Thing because there's no way to "undo" 1830if you want to see the original source code in the typechecker 1831output. We'll have fix this in due course, when we care more about 1832being able to reconstruct the exact original program. 1833 1834Note [tagToEnum#] 1835~~~~~~~~~~~~~~~~~ 1836Nasty check to ensure that tagToEnum# is applied to a type that is an 1837enumeration TyCon. Unification may refine the type later, but this 1838check won't see that, alas. It's crude, because it relies on our 1839knowing *now* that the type is ok, which in turn relies on the 1840eager-unification part of the type checker pushing enough information 1841here. In theory the Right Thing to do is to have a new form of 1842constraint but I definitely cannot face that! And it works ok as-is. 1843 1844Here's are two cases that should fail 1845 f :: forall a. a 1846 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable 1847 1848 g :: Int 1849 g = tagToEnum# 0 -- Int is not an enumeration 1850 1851When data type families are involved it's a bit more complicated. 1852 data family F a 1853 data instance F [Int] = A | B | C 1854Then we want to generate something like 1855 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] 1856Usually that coercion is hidden inside the wrappers for 1857constructors of F [Int] but here we have to do it explicitly. 1858 1859It's all grotesquely complicated. 1860 1861Note [Instantiating stupid theta] 1862~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1863Normally, when we infer the type of an Id, we don't instantiate, 1864because we wish to allow for visible type application later on. 1865But if a datacon has a stupid theta, we're a bit stuck. We need 1866to emit the stupid theta constraints with instantiated types. It's 1867difficult to defer this to the lazy instantiation, because a stupid 1868theta has no spot to put it in a type. So we just instantiate eagerly 1869in this case. Thus, users cannot use visible type application with 1870a data constructor sporting a stupid theta. I won't feel so bad for 1871the users that complain. 1872 1873-} 1874 1875tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType 1876 -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) 1877-- tagToEnum# :: forall a. Int# -> a 1878-- See Note [tagToEnum#] Urgh! 1879tcTagToEnum loc fun_name args res_ty 1880 = do { fun <- tcLookupId fun_name 1881 1882 ; let pars1 = mapMaybe isArgPar_maybe before 1883 pars2 = mapMaybe isArgPar_maybe after 1884 -- args contains exactly one HsValArg 1885 (before, _:after) = break isHsValArg args 1886 1887 ; arg <- case filterOut isArgPar args of 1888 [HsTypeArg _ hs_ty_arg, HsValArg term_arg] 1889 -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind 1890 ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty 1891 -- other than influencing res_ty, we just 1892 -- don't care about a type arg passed in. 1893 -- So drop the evidence. 1894 ; return term_arg } 1895 [HsValArg term_arg] -> do { _ <- expTypeToType res_ty 1896 ; return term_arg } 1897 _ -> too_many_args "tagToEnum#" args 1898 1899 ; res_ty <- readExpType res_ty 1900 ; ty' <- zonkTcType res_ty 1901 1902 -- Check that the type is algebraic 1903 ; let mb_tc_app = tcSplitTyConApp_maybe ty' 1904 Just (tc, tc_args) = mb_tc_app 1905 ; checkTc (isJust mb_tc_app) 1906 (mk_error ty' doc1) 1907 1908 -- Look through any type family 1909 ; fam_envs <- tcGetFamInstEnvs 1910 ; let (rep_tc, rep_args, coi) 1911 = tcLookupDataFamInst fam_envs tc tc_args 1912 -- coi :: tc tc_args ~R rep_tc rep_args 1913 1914 ; checkTc (isEnumerationTyCon rep_tc) 1915 (mk_error ty' doc2) 1916 1917 ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) 1918 ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExtField (L loc fun))) 1919 rep_ty = mkTyConApp rep_tc rep_args 1920 out_args = concat 1921 [ pars1 1922 , [HsValArg arg'] 1923 , pars2 1924 ] 1925 1926 ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) } 1927 -- coi is a Representational coercion 1928 where 1929 doc1 = vcat [ text "Specify the type by giving a type signature" 1930 , text "e.g. (tagToEnum# x) :: Bool" ] 1931 doc2 = text "Result type must be an enumeration type" 1932 1933 mk_error :: TcType -> SDoc -> SDoc 1934 mk_error ty what 1935 = hang (text "Bad call to tagToEnum#" 1936 <+> text "at type" <+> ppr ty) 1937 2 what 1938 1939too_many_args :: String -> [LHsExprArgIn] -> TcM a 1940too_many_args fun args 1941 = failWith $ 1942 hang (text "Too many type arguments to" <+> text fun <> colon) 1943 2 (sep (map pp args)) 1944 where 1945 pp (HsValArg e) = ppr e 1946 pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t 1947 pp (HsTypeArg _ (XHsWildCardBndrs nec)) = noExtCon nec 1948 pp (HsArgPar _) = empty 1949 1950 1951{- 1952************************************************************************ 1953* * 1954 Template Haskell checks 1955* * 1956************************************************************************ 1957-} 1958 1959checkThLocalId :: Id -> TcM () 1960checkThLocalId id 1961 = do { mb_local_use <- getStageAndBindLevel (idName id) 1962 ; case mb_local_use of 1963 Just (top_lvl, bind_lvl, use_stage) 1964 | thLevel use_stage > bind_lvl 1965 -> checkCrossStageLifting top_lvl id use_stage 1966 _ -> return () -- Not a locally-bound thing, or 1967 -- no cross-stage link 1968 } 1969 1970-------------------------------------- 1971checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM () 1972-- If we are inside typed brackets, and (use_lvl > bind_lvl) 1973-- we must check whether there's a cross-stage lift to do 1974-- Examples \x -> [|| x ||] 1975-- [|| map ||] 1976-- There is no error-checking to do, because the renamer did that 1977-- 1978-- This is similar to checkCrossStageLifting in RnSplice, but 1979-- this code is applied to *typed* brackets. 1980 1981checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var)) 1982 | isTopLevel top_lvl 1983 = when (isExternalName id_name) (keepAlive id_name) 1984 -- See Note [Keeping things alive for Template Haskell] in RnSplice 1985 1986 | otherwise 1987 = -- Nested identifiers, such as 'x' in 1988 -- E.g. \x -> [|| h x ||] 1989 -- We must behave as if the reference to x was 1990 -- h $(lift x) 1991 -- We use 'x' itself as the splice proxy, used by 1992 -- the desugarer to stitch it all back together. 1993 -- If 'x' occurs many times we may get many identical 1994 -- bindings of the same splice proxy, but that doesn't 1995 -- matter, although it's a mite untidy. 1996 do { let id_ty = idType id 1997 ; checkTc (isTauTy id_ty) (polySpliceErr id) 1998 -- If x is polymorphic, its occurrence sites might 1999 -- have different instantiations, so we can't use plain 2000 -- 'x' as the splice proxy name. I don't know how to 2001 -- solve this, and it's probably unimportant, so I'm 2002 -- just going to flag an error for now 2003 2004 ; lift <- if isStringTy id_ty then 2005 do { sid <- tcLookupId THNames.liftStringName 2006 -- See Note [Lifting strings] 2007 ; return (HsVar noExtField (noLoc sid)) } 2008 else 2009 setConstraintVar lie_var $ 2010 -- Put the 'lift' constraint into the right LIE 2011 newMethodFromName (OccurrenceOf id_name) 2012 THNames.liftName 2013 [getRuntimeRep id_ty, id_ty] 2014 2015 -- Update the pending splices 2016 ; ps <- readMutVar ps_var 2017 ; let pending_splice = PendingTcSplice id_name 2018 (nlHsApp (noLoc lift) (nlHsVar id)) 2019 ; writeMutVar ps_var (pending_splice : ps) 2020 2021 ; return () } 2022 where 2023 id_name = idName id 2024 2025checkCrossStageLifting _ _ _ = return () 2026 2027polySpliceErr :: Id -> SDoc 2028polySpliceErr id 2029 = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) 2030 2031{- 2032Note [Lifting strings] 2033~~~~~~~~~~~~~~~~~~~~~~ 2034If we see $(... [| s |] ...) where s::String, we don't want to 2035generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. 2036So this conditional short-circuits the lifting mechanism to generate 2037(liftString "xy") in that case. I didn't want to use overlapping instances 2038for the Lift class in TH.Syntax, because that can lead to overlapping-instance 2039errors in a polymorphic situation. 2040 2041If this check fails (which isn't impossible) we get another chance; see 2042Note [Converting strings] in Convert.hs 2043 2044Local record selectors 2045~~~~~~~~~~~~~~~~~~~~~~ 2046Record selectors for TyCons in this module are ordinary local bindings, 2047which show up as ATcIds rather than AGlobals. So we need to check for 2048naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. 2049 2050 2051************************************************************************ 2052* * 2053\subsection{Record bindings} 2054* * 2055************************************************************************ 2056-} 2057 2058getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet 2059-- These tyvars must not change across the updates 2060getFixedTyVars upd_fld_occs univ_tvs cons 2061 = mkVarSet [tv1 | con <- cons 2062 , let (u_tvs, _, eqspec, prov_theta 2063 , req_theta, arg_tys, _) 2064 = conLikeFullSig con 2065 theta = eqSpecPreds eqspec 2066 ++ prov_theta 2067 ++ req_theta 2068 flds = conLikeFieldLabels con 2069 fixed_tvs = exactTyCoVarsOfTypes fixed_tys 2070 -- fixed_tys: See Note [Type of a record update] 2071 `unionVarSet` tyCoVarsOfTypes theta 2072 -- Universally-quantified tyvars that 2073 -- appear in any of the *implicit* 2074 -- arguments to the constructor are fixed 2075 -- See Note [Implicit type sharing] 2076 2077 fixed_tys = [ty | (fl, ty) <- zip flds arg_tys 2078 , not (flLabel fl `elem` upd_fld_occs)] 2079 , (tv1,tv) <- univ_tvs `zip` u_tvs 2080 , tv `elemVarSet` fixed_tvs ] 2081 2082{- 2083Note [Disambiguating record fields] 2084~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2085When the -XDuplicateRecordFields extension is used, and the renamer 2086encounters a record selector or update that it cannot immediately 2087disambiguate (because it involves fields that belong to multiple 2088datatypes), it will defer resolution of the ambiguity to the 2089typechecker. In this case, the `Ambiguous` constructor of 2090`AmbiguousFieldOcc` is used. 2091 2092Consider the following definitions: 2093 2094 data S = MkS { foo :: Int } 2095 data T = MkT { foo :: Int, bar :: Int } 2096 data U = MkU { bar :: Int, baz :: Int } 2097 2098When the renamer sees `foo` as a selector or an update, it will not 2099know which parent datatype is in use. 2100 2101For selectors, there are two possible ways to disambiguate: 2102 21031. Check if the pushed-in type is a function whose domain is a 2104 datatype, for example: 2105 2106 f s = (foo :: S -> Int) s 2107 2108 g :: T -> Int 2109 g = foo 2110 2111 This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`. 2112 21132. Check if the selector is applied to an argument that has a type 2114 signature, for example: 2115 2116 h = foo (s :: S) 2117 2118 This is checked by `tcApp`. 2119 2120 2121Updates are slightly more complex. The `disambiguateRecordBinds` 2122function tries to determine the parent datatype in three ways: 2123 21241. Check for types that have all the fields being updated. For example: 2125 2126 f x = x { foo = 3, bar = 2 } 2127 2128 Here `f` must be updating `T` because neither `S` nor `U` have 2129 both fields. This may also discover that no possible type exists. 2130 For example the following will be rejected: 2131 2132 f' x = x { foo = 3, baz = 3 } 2133 21342. Use the type being pushed in, if it is already a TyConApp. The 2135 following are valid updates to `T`: 2136 2137 g :: T -> T 2138 g x = x { foo = 3 } 2139 2140 g' x = x { foo = 3 } :: T 2141 21423. Use the type signature of the record expression, if it exists and 2143 is a TyConApp. Thus this is valid update to `T`: 2144 2145 h x = (x :: T) { foo = 3 } 2146 2147 2148Note that we do not look up the types of variables being updated, and 2149no constraint-solving is performed, so for example the following will 2150be rejected as ambiguous: 2151 2152 let bad (s :: S) = foo s 2153 2154 let r :: T 2155 r = blah 2156 in r { foo = 3 } 2157 2158 \r. (r { foo = 3 }, r :: T ) 2159 2160We could add further tests, of a more heuristic nature. For example, 2161rather than looking for an explicit signature, we could try to infer 2162the type of the argument to a selector or the record expression being 2163updated, in case we are lucky enough to get a TyConApp straight 2164away. However, it might be hard for programmers to predict whether a 2165particular update is sufficiently obvious for the signature to be 2166omitted. Moreover, this might change the behaviour of typechecker in 2167non-obvious ways. 2168 2169See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. 2170-} 2171 2172-- Given a RdrName that refers to multiple record fields, and the type 2173-- of its argument, try to determine the name of the selector that is 2174-- meant. 2175disambiguateSelector :: Located RdrName -> Type -> TcM Name 2176disambiguateSelector lr@(L _ rdr) parent_type 2177 = do { fam_inst_envs <- tcGetFamInstEnvs 2178 ; case tyConOf fam_inst_envs parent_type of 2179 Nothing -> ambiguousSelector lr 2180 Just p -> 2181 do { xs <- lookupParents rdr 2182 ; let parent = RecSelData p 2183 ; case lookup parent xs of 2184 Just gre -> do { addUsedGRE True gre 2185 ; return (gre_name gre) } 2186 Nothing -> failWithTc (fieldNotInType parent rdr) } } 2187 2188-- This field name really is ambiguous, so add a suitable "ambiguous 2189-- occurrence" error, then give up. 2190ambiguousSelector :: Located RdrName -> TcM a 2191ambiguousSelector (L _ rdr) 2192 = do { env <- getGlobalRdrEnv 2193 ; let gres = lookupGRE_RdrName rdr env 2194 ; setErrCtxt [] $ addNameClashErrRn rdr gres 2195 ; failM } 2196 2197-- Disambiguate the fields in a record update. 2198-- See Note [Disambiguating record fields] 2199disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType 2200 -> [LHsRecUpdField GhcRn] -> ExpRhoType 2201 -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] 2202disambiguateRecordBinds record_expr record_rho rbnds res_ty 2203 -- Are all the fields unambiguous? 2204 = case mapM isUnambiguous rbnds of 2205 -- If so, just skip to looking up the Ids 2206 -- Always the case if DuplicateRecordFields is off 2207 Just rbnds' -> mapM lookupSelector rbnds' 2208 Nothing -> -- If not, try to identify a single parent 2209 do { fam_inst_envs <- tcGetFamInstEnvs 2210 -- Look up the possible parents for each field 2211 ; rbnds_with_parents <- getUpdFieldsParents 2212 ; let possible_parents = map (map fst . snd) rbnds_with_parents 2213 -- Identify a single parent 2214 ; p <- identifyParent fam_inst_envs possible_parents 2215 -- Pick the right selector with that parent for each field 2216 ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } 2217 where 2218 -- Extract the selector name of a field update if it is unambiguous 2219 isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) 2220 isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of 2221 Unambiguous sel_name _ -> Just (x, sel_name) 2222 Ambiguous{} -> Nothing 2223 XAmbiguousFieldOcc{} -> Nothing 2224 2225 -- Look up the possible parents and selector GREs for each field 2226 getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn 2227 , [(RecSelParent, GlobalRdrElt)])] 2228 getUpdFieldsParents 2229 = fmap (zip rbnds) $ mapM 2230 (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc) 2231 rbnds 2232 2233 -- Given a the lists of possible parents for each field, 2234 -- identify a single parent 2235 identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent 2236 identifyParent fam_inst_envs possible_parents 2237 = case foldr1 intersect possible_parents of 2238 -- No parents for all fields: record update is ill-typed 2239 [] -> failWithTc (noPossibleParents rbnds) 2240 2241 -- Exactly one datatype with all the fields: use that 2242 [p] -> return p 2243 2244 -- Multiple possible parents: try harder to disambiguate 2245 -- Can we get a parent TyCon from the pushed-in type? 2246 _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p) 2247 2248 -- Does the expression being updated have a type signature? 2249 -- If so, try to extract a parent TyCon from it 2250 | Just {} <- obviousSig (unLoc record_expr) 2251 , Just tc <- tyConOf fam_inst_envs record_rho 2252 -> return (RecSelData tc) 2253 2254 -- Nothing else we can try... 2255 _ -> failWithTc badOverloadedUpdate 2256 2257 -- Make a field unambiguous by choosing the given parent. 2258 -- Emits an error if the field cannot have that parent, 2259 -- e.g. if the user writes 2260 -- r { x = e } :: T 2261 -- where T does not have field x. 2262 pickParent :: RecSelParent 2263 -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) 2264 -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) 2265 pickParent p (upd, xs) 2266 = case lookup p xs of 2267 -- Phew! The parent is valid for this field. 2268 -- Previously ambiguous fields must be marked as 2269 -- used now that we know which one is meant, but 2270 -- unambiguous ones shouldn't be recorded again 2271 -- (giving duplicate deprecation warnings). 2272 Just gre -> do { unless (null (tail xs)) $ do 2273 let L loc _ = hsRecFieldLbl (unLoc upd) 2274 setSrcSpan loc $ addUsedGRE True gre 2275 ; lookupSelector (upd, gre_name gre) } 2276 -- The field doesn't belong to this parent, so report 2277 -- an error but keep going through all the fields 2278 Nothing -> do { addErrTc (fieldNotInType p 2279 (unLoc (hsRecUpdFieldRdr (unLoc upd)))) 2280 ; lookupSelector (upd, gre_name (snd (head xs))) } 2281 2282 -- Given a (field update, selector name) pair, look up the 2283 -- selector to give a field update with an unambiguous Id 2284 lookupSelector :: (LHsRecUpdField GhcRn, Name) 2285 -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) 2286 lookupSelector (L l upd, n) 2287 = do { i <- tcLookupId n 2288 ; let L loc af = hsRecFieldLbl upd 2289 lbl = rdrNameAmbiguousFieldOcc af 2290 ; return $ L l upd { hsRecFieldLbl 2291 = L loc (Unambiguous i (L loc lbl)) } } 2292 2293 2294-- Extract the outermost TyCon of a type, if there is one; for 2295-- data families this is the representation tycon (because that's 2296-- where the fields live). 2297tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon 2298tyConOf fam_inst_envs ty0 2299 = case tcSplitTyConApp_maybe ty of 2300 Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) 2301 Nothing -> Nothing 2302 where 2303 (_, _, ty) = tcSplitSigmaTy ty0 2304 2305-- Variant of tyConOf that works for ExpTypes 2306tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon 2307tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 2308 2309-- For an ambiguous record field, find all the candidate record 2310-- selectors (as GlobalRdrElts) and their parents. 2311lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] 2312lookupParents rdr 2313 = do { env <- getGlobalRdrEnv 2314 ; let gres = lookupGRE_RdrName rdr env 2315 ; mapM lookupParent gres } 2316 where 2317 lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) 2318 lookupParent gre = do { id <- tcLookupId (gre_name gre) 2319 ; if isRecordSelector id 2320 then return (recordSelectorTyCon id, gre) 2321 else failWithTc (notSelector (gre_name gre)) } 2322 2323-- A type signature on the argument of an ambiguous record selector or 2324-- the record expression in an update must be "obvious", i.e. the 2325-- outermost constructor ignoring parentheses. 2326obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) 2327obviousSig (ExprWithTySig _ _ ty) = Just ty 2328obviousSig (HsPar _ p) = obviousSig (unLoc p) 2329obviousSig _ = Nothing 2330 2331 2332{- 2333Game plan for record bindings 2334~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 23351. Find the TyCon for the bindings, from the first field label. 2336 23372. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. 2338 2339For each binding field = value 2340 23413. Instantiate the field type (from the field label) using the type 2342 envt from step 2. 2343 23444 Type check the value using tcArg, passing the field type as 2345 the expected argument type. 2346 2347This extends OK when the field types are universally quantified. 2348-} 2349 2350tcRecordBinds 2351 :: ConLike 2352 -> [TcType] -- Expected type for each field 2353 -> HsRecordBinds GhcRn 2354 -> TcM (HsRecordBinds GhcTcId) 2355 2356tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) 2357 = do { mb_binds <- mapM do_bind rbinds 2358 ; return (HsRecFields (catMaybes mb_binds) dd) } 2359 where 2360 fields = map flSelector $ conLikeFieldLabels con_like 2361 flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys 2362 2363 do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) 2364 -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))) 2365 do_bind (L l fld@(HsRecField { hsRecFieldLbl = f 2366 , hsRecFieldArg = rhs })) 2367 2368 = do { mb <- tcRecordField con_like flds_w_tys f rhs 2369 ; case mb of 2370 Nothing -> return Nothing 2371 Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' 2372 , hsRecFieldArg = rhs' }))) } 2373 2374tcRecordUpd 2375 :: ConLike 2376 -> [TcType] -- Expected type for each field 2377 -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] 2378 -> TcM [LHsRecUpdField GhcTcId] 2379 2380tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds 2381 where 2382 fields = map flSelector $ conLikeFieldLabels con_like 2383 flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys 2384 2385 do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) 2386 -> TcM (Maybe (LHsRecUpdField GhcTcId)) 2387 do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af 2388 , hsRecFieldArg = rhs })) 2389 = do { let lbl = rdrNameAmbiguousFieldOcc af 2390 sel_id = selectorAmbiguousFieldOcc af 2391 f = L loc (FieldOcc (idName sel_id) (L loc lbl)) 2392 ; mb <- tcRecordField con_like flds_w_tys f rhs 2393 ; case mb of 2394 Nothing -> return Nothing 2395 Just (f', rhs') -> 2396 return (Just 2397 (L l (fld { hsRecFieldLbl 2398 = L loc (Unambiguous 2399 (extFieldOcc (unLoc f')) 2400 (L loc lbl)) 2401 , hsRecFieldArg = rhs' }))) } 2402 2403tcRecordField :: ConLike -> Assoc Name Type 2404 -> LFieldOcc GhcRn -> LHsExpr GhcRn 2405 -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) 2406tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs 2407 | Just field_ty <- assocMaybe flds_w_tys sel_name 2408 = addErrCtxt (fieldCtxt field_lbl) $ 2409 do { rhs' <- tcPolyExprNC rhs field_ty 2410 ; let field_id = mkUserLocal (nameOccName sel_name) 2411 (nameUnique sel_name) 2412 field_ty loc 2413 -- Yuk: the field_id has the *unique* of the selector Id 2414 -- (so we can find it easily) 2415 -- but is a LocalId with the appropriate type of the RHS 2416 -- (so the desugarer knows the type of local binder to make) 2417 ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } 2418 | otherwise 2419 = do { addErrTc (badFieldCon con_like field_lbl) 2420 ; return Nothing } 2421 where 2422 field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) 2423tcRecordField _ _ (L _ (XFieldOcc nec)) _ = noExtCon nec 2424 2425 2426checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () 2427checkMissingFields con_like rbinds 2428 | null field_labels -- Not declared as a record; 2429 -- But C{} is still valid if no strict fields 2430 = if any isBanged field_strs then 2431 -- Illegal if any arg is strict 2432 addErrTc (missingStrictFields con_like []) 2433 else do 2434 warn <- woptM Opt_WarnMissingFields 2435 when (warn && notNull field_strs && null field_labels) 2436 (warnTc (Reason Opt_WarnMissingFields) True 2437 (missingFields con_like [])) 2438 2439 | otherwise = do -- A record 2440 unless (null missing_s_fields) 2441 (addErrTc (missingStrictFields con_like missing_s_fields)) 2442 2443 warn <- woptM Opt_WarnMissingFields 2444 when (warn && notNull missing_ns_fields) 2445 (warnTc (Reason Opt_WarnMissingFields) True 2446 (missingFields con_like missing_ns_fields)) 2447 2448 where 2449 missing_s_fields 2450 = [ flLabel fl | (fl, str) <- field_info, 2451 isBanged str, 2452 not (fl `elemField` field_names_used) 2453 ] 2454 missing_ns_fields 2455 = [ flLabel fl | (fl, str) <- field_info, 2456 not (isBanged str), 2457 not (fl `elemField` field_names_used) 2458 ] 2459 2460 field_names_used = hsRecFields rbinds 2461 field_labels = conLikeFieldLabels con_like 2462 2463 field_info = zipEqual "missingFields" 2464 field_labels 2465 field_strs 2466 2467 field_strs = conLikeImplBangs con_like 2468 2469 fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds 2470 2471{- 2472************************************************************************ 2473* * 2474\subsection{Errors and contexts} 2475* * 2476************************************************************************ 2477 2478Boring and alphabetical: 2479-} 2480 2481addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a 2482addExprErrCtxt expr = addErrCtxt (exprCtxt expr) 2483 2484exprCtxt :: LHsExpr GhcRn -> SDoc 2485exprCtxt expr 2486 = hang (text "In the expression:") 2 (ppr expr) 2487 2488fieldCtxt :: FieldLabelString -> SDoc 2489fieldCtxt field_name 2490 = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") 2491 2492addFunResCtxt :: Bool -- There is at least one argument 2493 -> HsExpr GhcRn -> TcType -> ExpRhoType 2494 -> TcM a -> TcM a 2495-- When we have a mis-match in the return type of a function 2496-- try to give a helpful message about too many/few arguments 2497-- 2498-- Used for naked variables too; but with has_args = False 2499addFunResCtxt has_args fun fun_res_ty env_ty 2500 = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) 2501 -- NB: use a landmark error context, so that an empty context 2502 -- doesn't suppress some more useful context 2503 where 2504 mk_msg 2505 = do { mb_env_ty <- readExpType_maybe env_ty 2506 -- by the time the message is rendered, the ExpType 2507 -- will be filled in (except if we're debugging) 2508 ; fun_res' <- zonkTcType fun_res_ty 2509 ; env' <- case mb_env_ty of 2510 Just env_ty -> zonkTcType env_ty 2511 Nothing -> 2512 do { dumping <- doptM Opt_D_dump_tc_trace 2513 ; MASSERT( dumping ) 2514 ; newFlexiTyVarTy liftedTypeKind } 2515 ; let -- See Note [Splitting nested sigma types in mismatched 2516 -- function types] 2517 (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' 2518 -- No need to call tcSplitNestedSigmaTys here, since env_ty is 2519 -- an ExpRhoTy, i.e., it's already deeply instantiated. 2520 (_, _, env_tau) = tcSplitSigmaTy env' 2521 (args_fun, res_fun) = tcSplitFunTys fun_tau 2522 (args_env, res_env) = tcSplitFunTys env_tau 2523 n_fun = length args_fun 2524 n_env = length args_env 2525 info | n_fun == n_env = Outputable.empty 2526 | n_fun > n_env 2527 , not_fun res_env 2528 = text "Probable cause:" <+> quotes (ppr fun) 2529 <+> text "is applied to too few arguments" 2530 2531 | has_args 2532 , not_fun res_fun 2533 = text "Possible cause:" <+> quotes (ppr fun) 2534 <+> text "is applied to too many arguments" 2535 2536 | otherwise 2537 = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! 2538 ; return info } 2539 where 2540 not_fun ty -- ty is definitely not an arrow type, 2541 -- and cannot conceivably become one 2542 = case tcSplitTyConApp_maybe ty of 2543 Just (tc, _) -> isAlgTyCon tc 2544 Nothing -> False 2545 2546{- 2547Note [Splitting nested sigma types in mismatched function types] 2548~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2549When one applies a function to too few arguments, GHC tries to determine this 2550fact if possible so that it may give a helpful error message. It accomplishes 2551this by checking if the type of the applied function has more argument types 2552than supplied arguments. 2553 2554Previously, GHC computed the number of argument types through tcSplitSigmaTy. 2555This is incorrect in the face of nested foralls, however! This caused Trac 2556#13311, for instance: 2557 2558 f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b 2559 2560If one uses `f` like so: 2561 2562 do { f; putChar 'a' } 2563 2564Then tcSplitSigmaTy will decompose the type of `f` into: 2565 2566 Tyvars: [a] 2567 Context: (Monoid a) 2568 Argument types: [] 2569 Return type: forall b. Monoid b => Maybe a -> Maybe b 2570 2571That is, it will conclude that there are *no* argument types, and since `f` 2572was given no arguments, it won't print a helpful error message. On the other 2573hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: 2574 2575 Tyvars: [a, b] 2576 Context: (Monoid a, Monoid b) 2577 Argument types: [Maybe a] 2578 Return type: Maybe b 2579 2580So now GHC recognizes that `f` has one more argument type than it was actually 2581provided. 2582-} 2583 2584badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc 2585badFieldTypes prs 2586 = hang (text "Record update for insufficiently polymorphic field" 2587 <> plural prs <> colon) 2588 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) 2589 2590badFieldsUpd 2591 :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] 2592 -- Field names that don't belong to a single datacon 2593 -> [ConLike] -- Data cons of the type which the first field name belongs to 2594 -> SDoc 2595badFieldsUpd rbinds data_cons 2596 = hang (text "No constructor has all these fields:") 2597 2 (pprQuotedList conflictingFields) 2598 -- See Note [Finding the conflicting fields] 2599 where 2600 -- A (preferably small) set of fields such that no constructor contains 2601 -- all of them. See Note [Finding the conflicting fields] 2602 conflictingFields = case nonMembers of 2603 -- nonMember belongs to a different type. 2604 (nonMember, _) : _ -> [aMember, nonMember] 2605 [] -> let 2606 -- All of rbinds belong to one type. In this case, repeatedly add 2607 -- a field to the set until no constructor contains the set. 2608 2609 -- Each field, together with a list indicating which constructors 2610 -- have all the fields so far. 2611 growingSets :: [(FieldLabelString, [Bool])] 2612 growingSets = scanl1 combine membership 2613 combine (_, setMem) (field, fldMem) 2614 = (field, zipWith (&&) setMem fldMem) 2615 in 2616 -- Fields that don't change the membership status of the set 2617 -- are redundant and can be dropped. 2618 map (fst . head) $ groupBy ((==) `on` snd) growingSets 2619 2620 aMember = ASSERT( not (null members) ) fst (head members) 2621 (members, nonMembers) = partition (or . snd) membership 2622 2623 -- For each field, which constructors contain the field? 2624 membership :: [(FieldLabelString, [Bool])] 2625 membership = sortMembership $ 2626 map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ 2627 map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds 2628 2629 fieldLabelSets :: [Set.Set FieldLabelString] 2630 fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons 2631 2632 -- Sort in order of increasing number of True, so that a smaller 2633 -- conflicting set can be found. 2634 sortMembership = 2635 map snd . 2636 sortBy (compare `on` fst) . 2637 map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) 2638 2639 countTrue = count id 2640 2641{- 2642Note [Finding the conflicting fields] 2643~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2644Suppose we have 2645 data A = A {a0, a1 :: Int} 2646 | B {b0, b1 :: Int} 2647and we see a record update 2648 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } 2649Then we'd like to find the smallest subset of fields that no 2650constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. 2651We don't really want to report that no constructor has all of 2652{a0,a1,b0,b1}, because when there are hundreds of fields it's 2653hard to see what was really wrong. 2654 2655We may need more than two fields, though; eg 2656 data T = A { x,y :: Int, v::Int } 2657 | B { y,z :: Int, v::Int } 2658 | C { z,x :: Int, v::Int } 2659with update 2660 r { x=e1, y=e2, z=e3 }, we 2661 2662Finding the smallest subset is hard, so the code here makes 2663a decent stab, no more. See #7989. 2664-} 2665 2666naughtyRecordSel :: RdrName -> SDoc 2667naughtyRecordSel sel_id 2668 = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> 2669 text "as a function due to escaped type variables" $$ 2670 text "Probable fix: use pattern-matching syntax instead" 2671 2672notSelector :: Name -> SDoc 2673notSelector field 2674 = hsep [quotes (ppr field), text "is not a record selector"] 2675 2676mixedSelectors :: [Id] -> [Id] -> SDoc 2677mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) 2678 = ptext 2679 (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ 2680 text "Record selectors defined by" 2681 <+> quotes (ppr (tyConName rep_dc)) 2682 <> text ":" 2683 <+> pprWithCommas ppr data_sels $$ 2684 text "Pattern synonym selectors defined by" 2685 <+> quotes (ppr (patSynName rep_ps)) 2686 <> text ":" 2687 <+> pprWithCommas ppr pat_syn_sels 2688 where 2689 RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id 2690 RecSelData rep_dc = recordSelectorTyCon dc_rep_id 2691mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists" 2692 2693 2694missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc 2695missingStrictFields con fields 2696 = header <> rest 2697 where 2698 rest | null fields = Outputable.empty -- Happens for non-record constructors 2699 -- with strict fields 2700 | otherwise = colon <+> pprWithCommas ppr fields 2701 2702 header = text "Constructor" <+> quotes (ppr con) <+> 2703 text "does not have the required strict field(s)" 2704 2705missingFields :: ConLike -> [FieldLabelString] -> SDoc 2706missingFields con fields 2707 = header <> rest 2708 where 2709 rest | null fields = Outputable.empty 2710 | otherwise = colon <+> pprWithCommas ppr fields 2711 header = text "Fields of" <+> quotes (ppr con) <+> 2712 text "not initialised" 2713 2714-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) 2715 2716noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc 2717noPossibleParents rbinds 2718 = hang (text "No type has all these fields:") 2719 2 (pprQuotedList fields) 2720 where 2721 fields = map (hsRecFieldLbl . unLoc) rbinds 2722 2723badOverloadedUpdate :: SDoc 2724badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" 2725 2726fieldNotInType :: RecSelParent -> RdrName -> SDoc 2727fieldNotInType p rdr 2728 = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr 2729 2730{- 2731************************************************************************ 2732* * 2733\subsection{Static Pointers} 2734* * 2735************************************************************************ 2736-} 2737 2738-- | A data type to describe why a variable is not closed. 2739data NotClosedReason = NotLetBoundReason 2740 | NotTypeClosed VarSet 2741 | NotClosed Name NotClosedReason 2742 2743-- | Checks if the given name is closed and emits an error if not. 2744-- 2745-- See Note [Not-closed error messages]. 2746checkClosedInStaticForm :: Name -> TcM () 2747checkClosedInStaticForm name = do 2748 type_env <- getLclTypeEnv 2749 case checkClosed type_env name of 2750 Nothing -> return () 2751 Just reason -> addErrTc $ explain name reason 2752 where 2753 -- See Note [Checking closedness]. 2754 checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason 2755 checkClosed type_env n = checkLoop type_env (unitNameSet n) n 2756 2757 checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason 2758 checkLoop type_env visited n = do 2759 -- The @visited@ set is an accumulating parameter that contains the set of 2760 -- visited nodes, so we avoid repeating cycles in the traversal. 2761 case lookupNameEnv type_env n of 2762 Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of 2763 ClosedLet -> Nothing 2764 NotLetBound -> Just NotLetBoundReason 2765 NonClosedLet fvs type_closed -> listToMaybe $ 2766 -- Look for a non-closed variable in fvs 2767 [ NotClosed n' reason 2768 | n' <- nameSetElemsStable fvs 2769 , not (elemNameSet n' visited) 2770 , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] 2771 ] ++ 2772 if type_closed then 2773 [] 2774 else 2775 -- We consider non-let-bound variables easier to figure out than 2776 -- non-closed types, so we report non-closed types to the user 2777 -- only if we cannot spot the former. 2778 [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] 2779 -- The binding is closed. 2780 _ -> Nothing 2781 2782 -- Converts a reason into a human-readable sentence. 2783 -- 2784 -- @explain name reason@ starts with 2785 -- 2786 -- "<name> is used in a static form but it is not closed because it" 2787 -- 2788 -- and then follows a list of causes. For each id in the path, the text 2789 -- 2790 -- "uses <id> which" 2791 -- 2792 -- is appended, yielding something like 2793 -- 2794 -- "uses <id> which uses <id1> which uses <id2> which" 2795 -- 2796 -- until the end of the path is reached, which is reported as either 2797 -- 2798 -- "is not let-bound" 2799 -- 2800 -- when the final node is not let-bound, or 2801 -- 2802 -- "has a non-closed type because it contains the type variables: 2803 -- v1, v2, v3" 2804 -- 2805 -- when the final node has a non-closed type. 2806 -- 2807 explain :: Name -> NotClosedReason -> SDoc 2808 explain name reason = 2809 quotes (ppr name) <+> text "is used in a static form but it is not closed" 2810 <+> text "because it" 2811 $$ 2812 sep (causes reason) 2813 2814 causes :: NotClosedReason -> [SDoc] 2815 causes NotLetBoundReason = [text "is not let-bound."] 2816 causes (NotTypeClosed vs) = 2817 [ text "has a non-closed type because it contains the" 2818 , text "type variables:" <+> 2819 pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) 2820 ] 2821 causes (NotClosed n reason) = 2822 let msg = text "uses" <+> quotes (ppr n) <+> text "which" 2823 in case reason of 2824 NotClosed _ _ -> msg : causes reason 2825 _ -> let (xs0, xs1) = splitAt 1 $ causes reason 2826 in fmap (msg <+>) xs0 ++ xs1 2827 2828-- Note [Not-closed error messages] 2829-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2830-- 2831-- When variables in a static form are not closed, we go through the trouble 2832-- of explaining why they aren't. 2833-- 2834-- Thus, the following program 2835-- 2836-- > {-# LANGUAGE StaticPointers #-} 2837-- > module M where 2838-- > 2839-- > f x = static g 2840-- > where 2841-- > g = h 2842-- > h = x 2843-- 2844-- produces the error 2845-- 2846-- 'g' is used in a static form but it is not closed because it 2847-- uses 'h' which uses 'x' which is not let-bound. 2848-- 2849-- And a program like 2850-- 2851-- > {-# LANGUAGE StaticPointers #-} 2852-- > module M where 2853-- > 2854-- > import Data.Typeable 2855-- > import GHC.StaticPtr 2856-- > 2857-- > f :: Typeable a => a -> StaticPtr TypeRep 2858-- > f x = const (static (g undefined)) (h x) 2859-- > where 2860-- > g = h 2861-- > h = typeOf 2862-- 2863-- produces the error 2864-- 2865-- 'g' is used in a static form but it is not closed because it 2866-- uses 'h' which has a non-closed type because it contains the 2867-- type variables: 'a' 2868-- 2869 2870-- Note [Checking closedness] 2871-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ 2872-- 2873-- @checkClosed@ checks if a binding is closed and returns a reason if it is 2874-- not. 2875-- 2876-- The bindings define a graph where the nodes are ids, and there is an edge 2877-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free 2878-- variables. 2879-- 2880-- When @n@ is not closed, it has to exist in the graph some node reachable 2881-- from @n@ that it is not a let-bound variable or that it has a non-closed 2882-- type. Thus, the "reason" is a path from @n@ to this offending node. 2883-- 2884-- When @n@ is not closed, we traverse the graph reachable from @n@ to build 2885-- the reason. 2886-- 2887