compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[TcExpr]{Typecheck an expression}
   6
   7 \begin{code}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  12 -- for details
  13
  14 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
  15                 tcInferRho, tcInferRhoNC,
  16                 tcSyntaxOp, tcCheckId,
  17                 addExprErrCtxt ) where
  18
  19 #include "HsVersions.h"
  20
  21 #ifdef GHCI     /* Only if bootstrapped */
  22 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcBracket )
  23 import qualified DsMeta
  24 #endif
  25
  26 import HsSyn
  27 import TcHsSyn
  28 import TcRnMonad
  29 import TcUnify
  30 import BasicTypes
  31 import Inst
  32 import TcBinds
  33 import TcEnv
  34 import TcArrows
  35 import TcMatches
  36 import TcHsType
  37 import TcPat
  38 import TcMType
  39 import TcType
  40 import Id
  41 import DataCon
  42 import Name
  43 import TyCon
  44 import Type
  45 import Coercion
  46 import Var
  47 import VarSet
  48 import VarEnv
  49 import TysWiredIn
  50 import TysPrim( intPrimTy )
  51 import PrimOp( tagToEnumKey )
  52 import PrelNames
  53 import Module
  54 import DynFlags
  55 import SrcLoc
  56 import Util
  57 import ListSetOps
  58 import Maybes
  59 import ErrUtils
  60 import Outputable
  61 import FastString
  62 import Control.Monad
  63 \end{code}
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsection{Main wrappers}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 \begin{code}
  72 tcPolyExpr, tcPolyExprNC
  73          :: LHsExpr Name        -- Expression to type check
  74          -> TcSigmaType         -- Expected type (could be a polytpye)
  75          -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
  76
  77 -- tcPolyExpr is a convenient place (frequent but not too frequent)
  78 -- place to add context information.
  79 -- The NC version does not do so, usually because the caller wants
  80 -- to do so himself.
  81
  82 tcPolyExpr expr res_ty
  83   = addExprErrCtxt expr $
  84     do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
  85
  86 tcPolyExprNC expr res_ty
  87   = do { traceTc "tcPolyExprNC" (ppr res_ty)
  88        ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
  89                             tcMonoExprNC expr rho
  90        ; return (mkLHsWrap gen_fn expr') }
  91
  92 ---------------
  93 tcMonoExpr, tcMonoExprNC
  94     :: LHsExpr Name      -- Expression to type check
  95     -> TcRhoType         -- Expected type (could be a type variable)
  96                          -- Definitely no foralls at the top
  97     -> TcM (LHsExpr TcId)
  98
  99 tcMonoExpr expr res_ty
 100   = addErrCtxt (exprCtxt expr) $
 101     tcMonoExprNC expr res_ty
 102
 103 tcMonoExprNC (L loc expr) res_ty
 104   = ASSERT( not (isSigmaTy res_ty) )
 105     setSrcSpan loc $
 106     do  { expr' <- tcExpr expr res_ty
 107         ; return (L loc expr') }
 108
 109 ---------------
 110 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 111 -- Infer a *rho*-type.  This is, in effect, a special case
 112 -- for ids and partial applications, so that if
 113 --     f :: Int -> (forall a. a -> a) -> Int
 114 -- then we can infer
 115 --     f 3 :: (forall a. a -> a) -> Int
 116 -- And that in turn is useful
 117 --  (a) for the function part of any application (see tcApp)
 118 --  (b) for the special rule for '$'
 119 tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
 120
 121 tcInferRhoNC (L loc expr)
 122   = setSrcSpan loc $
 123     do { (expr', rho) <- tcInfExpr expr
 124        ; return (L loc expr', rho) }
 125
 126 tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType)
 127 tcInfExpr (HsVar f)     = tcInferId f
 128 tcInfExpr (HsPar e)     = do { (e', ty) <- tcInferRhoNC e
 129                              ; return (HsPar e', ty) }
 130 tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2]
 131 tcInfExpr e             = tcInfer (tcExpr e)
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137         tcExpr: the main expression typechecker
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
 143 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty     -- Sanity check
 144                 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
 145
 146 tcExpr (HsVar name)  res_ty = tcCheckId name res_ty
 147
 148 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
 149
 150 tcExpr (HsLit lit)   res_ty = do { let lit_ty = hsLitType lit
 151                                  ; tcWrapResult (HsLit lit) lit_ty res_ty }
 152
 153 tcExpr (HsPar expr)  res_ty = do { expr' <- tcMonoExprNC expr res_ty
 154                                  ; return (HsPar expr') }
 155
 156 tcExpr (HsSCC lbl expr) res_ty
 157   = do { expr' <- tcMonoExpr expr res_ty
 158        ; return (HsSCC lbl expr') }
 159
 160 tcExpr (HsTickPragma info expr) res_ty
 161   = do { expr' <- tcMonoExpr expr res_ty
 162        ; return (HsTickPragma info expr') }
 163
 164 tcExpr (HsCoreAnn lbl expr) res_ty
 165   = do  { expr' <- tcMonoExpr expr res_ty
 166         ; return (HsCoreAnn lbl expr') }
 167
 168 tcExpr (HsOverLit lit) res_ty
 169   = do  { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
 170         ; return (HsOverLit lit') }
 171
 172 tcExpr (NegApp expr neg_expr) res_ty
 173   = do  { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
 174                                   (mkFunTy res_ty res_ty)
 175         ; expr' <- tcMonoExpr expr res_ty
 176         ; return (NegApp expr' neg_expr') }
 177
 178 tcExpr (HsIPVar ip) res_ty
 179   = do  { let origin = IPOccOrigin ip
 180                 -- Implicit parameters must have a *tau-type* not a
 181                 -- type scheme.  We enforce this by creating a fresh
 182                 -- type variable as its type.  (Because res_ty may not
 183                 -- be a tau-type.)
 184         ; ip_ty <- newFlexiTyVarTy argTypeKind  -- argTypeKind: it can't be an unboxed tuple
 185         ; ip_var <- emitWanted origin (mkIPPred ip ip_ty)
 186         ; tcWrapResult (HsIPVar (IPName ip_var)) ip_ty res_ty }
 187
 188 tcExpr (HsLam match) res_ty
 189   = do  { (co_fn, match') <- tcMatchLambda match res_ty
 190         ; return (mkHsWrap co_fn (HsLam match')) }
 191
 192 tcExpr (ExprWithTySig expr sig_ty) res_ty
 193  = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 194
 195       -- Remember to extend the lexical type-variable environment
 196       ; (gen_fn, expr')
 197             <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
 198                tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
 199                                 -- See Note [More instantiated than scoped] in TcBinds
 200                tcMonoExprNC expr res_ty
 201
 202       ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
 203
 204       ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
 205       ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty }
 206
 207 tcExpr (HsType ty) _
 208   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 209         -- This is the syntax for type applications that I was planning
 210         -- but there are difficulties (e.g. what order for type args)
 211         -- so it's not enabled yet.
 212         -- Can't eliminate it altogether from the parser, because the
 213         -- same parser parses *patterns*.
 214 \end{code}
 215
 216
 217 %************************************************************************
 218 %*                                                                      *
 219                 Infix operators and sections
 220 %*                                                                      *
 221 %************************************************************************
 222
 223 Note [Left sections]
 224 ~~~~~~~~~~~~~~~~~~~~
 225 Left sections, like (4 *), are equivalent to
 226         \ x -> (*) 4 x,
 227 or, if PostfixOperators is enabled, just
 228         (*) 4
 229 With PostfixOperators we don't actually require the function to take
 230 two arguments at all.  For example, (x `not`) means (not x); you get
 231 postfix operators!  Not Haskell 98, but it's less work and kind of
 232 useful.
 233
 234 Note [Typing rule for ($)]
 235 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 236 People write
 237    runST $ blah
 238 so much, where
 239    runST :: (forall s. ST s a) -> a
 240 that I have finally given in and written a special type-checking
 241 rule just for saturated appliations of ($).
 242   * Infer the type of the first argument
 243   * Decompose it; should be of form (arg2_ty -> res_ty),
 244        where arg2_ty might be a polytype
 245   * Use arg2_ty to typecheck arg2
 246
 247 Note [Typing rule for seq]
 248 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 249 We want to allow
 250        x `seq` (# p,q #)
 251 which suggests this type for seq:
 252    seq :: forall (a:*) (b:??). a -> b -> b,
 253 with (b:??) meaning that be can be instantiated with an unboxed tuple.
 254 But that's ill-kinded!  Function arguments can't be unboxed tuples.
 255 And indeed, you could not expect to do this with a partially-applied
 256 'seq'; it's only going to work when it's fully applied.  so it turns
 257 into
 258     case x of _ -> (# p,q #)
 259
 260 For a while I slid by by giving 'seq' an ill-kinded type, but then
 261 the simplifier eta-reduced an application of seq and Lint blew up
 262 with a kind error.  It seems more uniform to treat 'seq' as it it
 263 was a language construct.
 264
 265 See Note [seqId magic] in MkId, and
 266
 267
 268 \begin{code}
 269 tcExpr (OpApp arg1 op fix arg2) res_ty
 270   | (L loc (HsVar op_name)) <- op
 271   , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
 272   = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
 273        ; let arg2_ty = res_ty
 274        ; arg1' <- tcArg op (arg1, arg1_ty, 1)
 275        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
 276        ; op_id <- tcLookupId op_name
 277        ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
 278        ; return $ OpApp arg1' op' fix arg2' }
 279
 280   | (L loc (HsVar op_name)) <- op
 281   , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
 282   = do { traceTc "Application rule" (ppr op)
 283        ; (arg1', arg1_ty) <- tcInferRho arg1
 284        ; let doc = ptext (sLit "The first argument of ($) takes")
 285        ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
 286          -- arg2_ty maybe polymorphic; that's the point
 287        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
 288        ; co_res <- unifyType op_res_ty res_ty
 289        ; op_id <- tcLookupId op_name
 290        ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
 291        ; return $ mkHsWrapCo co_res $
 292          OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' }
 293
 294   | otherwise
 295   = do { traceTc "Non Application rule" (ppr op)
 296        ; (op', op_ty) <- tcInferFun op
 297        ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
 298        ; co_res <- unifyType op_res_ty res_ty
 299        ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
 300        ; return $ mkHsWrapCo co_res $
 301          OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
 302
 303 -- Right sections, equivalent to \ x -> x `op` expr, or
 304 --      \ x -> op x expr
 305
 306 tcExpr (SectionR op arg2) res_ty
 307   = do { (op', op_ty) <- tcInferFun op
 308        ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
 309        ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
 310        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
 311        ; return $ mkHsWrapCo co_res $
 312          SectionR (mkLHsWrapCo co_fn op') arg2' }
 313
 314 tcExpr (SectionL arg1 op) res_ty
 315   = do { (op', op_ty) <- tcInferFun op
 316        ; dflags <- getDOpts         -- Note [Left sections]
 317        ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
 318                          | otherwise                        = 2
 319
 320        ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
 321        ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
 322        ; arg1' <- tcArg op (arg1, arg1_ty, 1)
 323        ; return $ mkHsWrapCo co_res $
 324          SectionL arg1' (mkLHsWrapCo co_fn op') }
 325
 326 tcExpr (ExplicitTuple tup_args boxity) res_ty
 327   | all tupArgPresent tup_args
 328   = do { let tup_tc = tupleTyCon boxity (length tup_args)
 329        ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
 330        ; tup_args1 <- tcTupArgs tup_args arg_tys
 331        ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
 332
 333   | otherwise
 334   = -- The tup_args are a mixture of Present and Missing (for tuple sections)
 335     do { let kind = case boxity of { Boxed   -> liftedTypeKind
 336                                    ; Unboxed -> argTypeKind }
 337              arity = length tup_args
 338              tup_tc = tupleTyCon boxity arity
 339
 340        ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
 341        ; let actual_res_ty
 342                  = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
 343                             (mkTyConApp tup_tc arg_tys)
 344
 345        ; coi <- unifyType actual_res_ty res_ty
 346
 347        -- Handle tuple sections where
 348        ; tup_args1 <- tcTupArgs tup_args arg_tys
 349
 350        ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
 351
 352 tcExpr (ExplicitList _ exprs) res_ty
 353   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
 354         ; exprs' <- mapM (tc_elt elt_ty) exprs
 355         ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') }
 356   where
 357     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 358
 359 tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
 360   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
 361         ; exprs' <- mapM (tc_elt elt_ty) exprs
 362         ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
 363   where
 364     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 365 \end{code}
 366
 367 %************************************************************************
 368 %*                                                                      *
 369                 Let, case, if, do
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 \begin{code}
 374 tcExpr (HsLet binds expr) res_ty
 375   = do  { (binds', expr') <- tcLocalBinds binds $
 376                              tcMonoExpr expr res_ty
 377         ; return (HsLet binds' expr') }
 378
 379 tcExpr (HsCase scrut matches) exp_ty
 380   = do  {  -- We used to typecheck the case alternatives first.
 381            -- The case patterns tend to give good type info to use
 382            -- when typechecking the scrutinee.  For example
 383            --   case (map f) of
 384            --     (x:xs) -> ...
 385            -- will report that map is applied to too few arguments
 386            --
 387            -- But now, in the GADT world, we need to typecheck the scrutinee
 388            -- first, to get type info that may be refined in the case alternatives
 389           (scrut', scrut_ty) <- tcInferRho scrut
 390
 391         ; traceTc "HsCase" (ppr scrut_ty)
 392         ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
 393         ; return (HsCase scrut' matches') }
 394  where
 395     match_ctxt = MC { mc_what = CaseAlt,
 396                       mc_body = tcBody }
 397
 398 tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
 399   = do { pred' <- tcMonoExpr pred boolTy
 400        ; b1' <- tcMonoExpr b1 res_ty
 401        ; b2' <- tcMonoExpr b2 res_ty
 402        ; return (HsIf Nothing pred' b1' b2') }
 403
 404 tcExpr (HsIf (Just fun) pred b1 b2) res_ty   -- Note [Rebindable syntax for if]
 405   = do { pred_ty <- newFlexiTyVarTy openTypeKind
 406        ; b1_ty   <- newFlexiTyVarTy openTypeKind
 407        ; b2_ty   <- newFlexiTyVarTy openTypeKind
 408        ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
 409        ; fun'  <- tcSyntaxOp IfOrigin fun if_ty
 410        ; pred' <- tcMonoExpr pred pred_ty
 411        ; b1'   <- tcMonoExpr b1 b1_ty
 412        ; b2'   <- tcMonoExpr b2 b2_ty
 413        -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
 414        -- so maybe we should use the code for function applications
 415        -- (which would allow ifThenElse to be higher rank).
 416        -- But it's a little awkward, so I'm leaving it alone for now
 417        -- and it maintains uniformity with other rebindable syntax
 418        ; return (HsIf (Just fun') pred' b1' b2') }
 419
 420 tcExpr (HsDo do_or_lc stmts _) res_ty
 421   = tcDoStmts do_or_lc stmts res_ty
 422
 423 tcExpr (HsProc pat cmd) res_ty
 424   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
 425         ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
 426
 427 tcExpr e@(HsArrApp _ _ _ _ _) _
 428   = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
 429                       ptext (sLit "was found where an expression was expected")])
 430
 431 tcExpr e@(HsArrForm _ _ _) _
 432   = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
 433                       ptext (sLit "was found where an expression was expected")])
 434 \end{code}
 435
 436 Note [Rebindable syntax for if]
 437 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 438 The rebindable syntax for 'if' uses the most flexible possible type
 439 for conditionals:
 440   ifThenElse :: p -> b1 -> b2 -> res
 441 to support expressions like this:
 442
 443  ifThenElse :: Maybe a -> (a -> b) -> b -> b
 444  ifThenElse (Just a) f _ = f a  ifThenElse Nothing  _ e = e
 445
 446  example :: String
 447  example = if Just 2
 448               then \v -> show v
 449               else "No value"
 450
 451
 452 %************************************************************************
 453 %*                                                                      *
 454                 Record construction and update
 455 %*                                                                      *
 456 %************************************************************************
 457
 458 \begin{code}
 459 tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
 460   = do  { data_con <- tcLookupDataCon con_name
 461
 462         -- Check for missing fields
 463         ; checkMissingFields data_con rbinds
 464
 465         ; (con_expr, con_tau) <- tcInferId con_name
 466         ; let arity = dataConSourceArity data_con
 467               (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
 468               con_id = dataConWrapId data_con
 469
 470         ; co_res <- unifyType actual_res_ty res_ty
 471         ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
 472         ; return $ mkHsWrapCo co_res $
 473           RecordCon (L loc con_id) con_expr rbinds' }
 474 \end{code}
 475
 476 Note [Type of a record update]
 477 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 478 The main complication with RecordUpd is that we need to explicitly
 479 handle the *non-updated* fields.  Consider:
 480
 481         data T a b c = MkT1 { fa :: a, fb :: (b,c) }
 482                      | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
 483                      | MkT3 { fd :: a }
 484
 485         upd :: T a b c -> (b',c) -> T a b' c
 486         upd t x = t { fb = x}
 487
 488 The result type should be (T a b' c)
 489 not (T a b c),   because 'b' *is not* mentioned in a non-updated field
 490 not (T a b' c'), becuase 'c' *is*     mentioned in a non-updated field
 491 NB that it's not good enough to look at just one constructor; we must
 492 look at them all; cf Trac #3219
 493
 494 After all, upd should be equivalent to:
 495         upd t x = case t of
 496                         MkT1 p q -> MkT1 p x
 497                         MkT2 a b -> MkT2 p b
 498                         MkT3 d   -> error ...
 499
 500 So we need to give a completely fresh type to the result record,
 501 and then constrain it by the fields that are *not* updated ("p" above).
 502 We call these the "fixed" type variables, and compute them in getFixedTyVars.
 503
 504 Note that because MkT3 doesn't contain all the fields being updated,
 505 its RHS is simply an error, so it doesn't impose any type constraints.
 506 Hence the use of 'relevant_cont'.
 507
 508 Note [Implict type sharing]
 509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 510 We also take into account any "implicit" non-update fields.  For example
 511         data T a b where { MkT { f::a } :: T a a; ... }
 512 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
 513
 514 Then consider
 515         upd t x = t { f=x }
 516 We infer the type
 517         upd :: T a b -> a -> T a b
 518         upd (t::T a b) (x::a)
 519            = case t of { MkT (co:a~b) (_:a) -> MkT co x }
 520 We can't give it the more general type
 521         upd :: T a b -> c -> T c b
 522
 523 Note [Criteria for update]
 524 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 525 We want to allow update for existentials etc, provided the updated
 526 field isn't part of the existential. For example, this should be ok.
 527   data T a where { MkT { f1::a, f2::b->b } :: T a }
 528   f :: T a -> b -> T b
 529   f t b = t { f1=b }
 530
 531 The criterion we use is this:
 532
 533   The types of the updated fields
 534   mention only the universally-quantified type variables
 535   of the data constructor
 536
 537 NB: this is not (quite) the same as being a "naughty" record selector
 538 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
 539 in the case of GADTs. Consider
 540    data T a where { MkT :: { f :: a } :: T [a] }
 541 Then f is not "naughty" because it has a well-typed record selector.
 542 But we don't allow updates for 'f'.  (One could consider trying to
 543 allow this, but it makes my head hurt.  Badly.  And no one has asked
 544 for it.)
 545
 546 In principle one could go further, and allow
 547   g :: T a -> T a
 548   g t = t { f2 = \x -> x }
 549 because the expression is polymorphic...but that seems a bridge too far.
 550
 551 Note [Data family example]
 552 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 553     data instance T (a,b) = MkT { x::a, y::b }
 554   --->
 555     data :TP a b = MkT { a::a, y::b }
 556     coTP a b :: T (a,b) ~ :TP a b
 557
 558 Suppose r :: T (t1,t2), e :: t3
 559 Then  r { x=e } :: T (t3,t1)
 560   --->
 561       case r |> co1 of
 562         MkT x y -> MkT e y |> co2
 563       where co1 :: T (t1,t2) ~ :TP t1 t2
 564             co2 :: :TP t3 t2 ~ T (t3,t2)
 565 The wrapping with co2 is done by the constructor wrapper for MkT
 566
 567 Outgoing invariants
 568 ~~~~~~~~~~~~~~~~~~~
 569 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
 570
 571   * cons are the data constructors to be updated
 572
 573   * in_inst_tys, out_inst_tys have same length, and instantiate the
 574         *representation* tycon of the data cons.  In Note [Data
 575         family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
 576
 577 \begin{code}
 578 tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
 579   = ASSERT( notNull upd_fld_names )
 580     do  {
 581         -- STEP 0
 582         -- Check that the field names are really field names
 583         ; sel_ids <- mapM tcLookupField upd_fld_names
 584                         -- The renamer has already checked that
 585                         -- selectors are all in scope
 586         ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
 587                          | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
 588                            not (isRecordSelector sel_id),       -- Excludes class ops
 589                            let L loc fld_name = hsRecFieldId fld ]
 590         ; unless (null bad_guys) (sequence bad_guys >> failM)
 591
 592         -- STEP 1
 593         -- Figure out the tycon and data cons from the first field name
 594         ; let   -- It's OK to use the non-tc splitters here (for a selector)
 595               sel_id : _  = sel_ids
 596               (tycon, _)  = recordSelectorFieldLabel sel_id     -- We've failed already if
 597               data_cons   = tyConDataCons tycon                 -- it's not a field label
 598                 -- NB: for a data type family, the tycon is the instance tycon
 599
 600               relevant_cons   = filter is_relevant data_cons
 601               is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
 602                 -- A constructor is only relevant to this process if
 603                 -- it contains *all* the fields that are being updated
 604                 -- Other ones will cause a runtime error if they occur
 605
 606                 -- Take apart a representative constructor
 607               con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
 608               (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
 609               con1_flds = dataConFieldLabels con1
 610               con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
 611
 612         -- Step 2
 613         -- Check that at least one constructor has all the named fields
 614         -- i.e. has an empty set of bad fields returned by badFields
 615         ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
 616
 617         -- STEP 3    Note [Criteria for update]
 618         -- Check that each updated field is polymorphic; that is, its type
 619         -- mentions only the universally-quantified variables of the data con
 620         ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
 621               upd_flds1_w_tys = filter is_updated flds1_w_tys
 622               is_updated (fld,_) = fld `elem` upd_fld_names
 623
 624               bad_upd_flds = filter bad_fld upd_flds1_w_tys
 625               con1_tv_set = mkVarSet con1_tvs
 626               bad_fld (fld, ty) = fld `elem` upd_fld_names &&
 627                                       not (tyVarsOfType ty `subVarSet` con1_tv_set)
 628         ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
 629
 630         -- STEP 4  Note [Type of a record update]
 631         -- Figure out types for the scrutinee and result
 632         -- Both are of form (T a b c), with fresh type variables, but with
 633         -- common variables where the scrutinee and result must have the same type
 634         -- These are variables that appear in *any* arg of *any* of the
 635         -- relevant constructors *except* in the updated fields
 636         --
 637         ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
 638               is_fixed_tv tv = tv `elemVarSet` fixed_tvs
 639               mk_inst_ty tv result_inst_ty
 640                 | is_fixed_tv tv = return result_inst_ty            -- Same as result type
 641                 | otherwise      = newFlexiTyVarTy (tyVarKind tv)  -- Fresh type, of correct kind
 642
 643         ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
 644         ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
 645
 646         ; let rec_res_ty    = TcType.substTy result_inst_env con1_res_ty
 647               con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys
 648               scrut_subst   = zipTopTvSubst con1_tvs scrut_inst_tys
 649               scrut_ty      = TcType.substTy scrut_subst con1_res_ty
 650
 651         ; co_res <- unifyType rec_res_ty res_ty
 652
 653         -- STEP 5
 654         -- Typecheck the thing to be updated, and the bindings
 655         ; record_expr' <- tcMonoExpr record_expr scrut_ty
 656         ; rbinds'      <- tcRecordBinds con1 con1_arg_tys' rbinds
 657
 658         -- STEP 6: Deal with the stupid theta
 659         ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
 660         ; instStupidTheta RecordUpdOrigin theta'
 661
 662         -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
 663         ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
 664                        = WpCast $ mkAxInstCo co_con scrut_inst_tys
 665                        | otherwise
 666                        = idHsWrapper
 667         -- Phew!
 668         ; return $ mkHsWrapCo co_res $
 669           RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
 670                                    relevant_cons scrut_inst_tys result_inst_tys  }
 671   where
 672     upd_fld_names = hsRecFields rbinds
 673
 674     getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
 675     -- These tyvars must not change across the updates
 676     getFixedTyVars tvs1 cons
 677       = mkVarSet [tv1 | con <- cons
 678                       , let (tvs, theta, arg_tys, _) = dataConSig con
 679                             flds = dataConFieldLabels con
 680                             fixed_tvs = exactTyVarsOfTypes fixed_tys
 681                                     -- fixed_tys: See Note [Type of a record update]
 682                                         `unionVarSet` tyVarsOfTheta theta
 683                                     -- Universally-quantified tyvars that
 684                                     -- appear in any of the *implicit*
 685                                     -- arguments to the constructor are fixed
 686                                     -- See Note [Implict type sharing]
 687
 688                             fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
 689                                             , not (fld `elem` upd_fld_names)]
 690                       , (tv1,tv) <- tvs1 `zip` tvs      -- Discards existentials in tvs
 691                       , tv `elemVarSet` fixed_tvs ]
 692 \end{code}
 693
 694 %************************************************************************
 695 %*                                                                      *
 696         Arithmetic sequences                    e.g. [a,b..]
 697         and their parallel-array counterparts   e.g. [: a,b.. :]
 698
 699 %*                                                                      *
 700 %************************************************************************
 701
 702 \begin{code}
 703 tcExpr (ArithSeq _ seq@(From expr)) res_ty
 704   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
 705         ; expr' <- tcPolyExpr expr elt_ty
 706         ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
 707                               enumFromName elt_ty
 708         ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) }
 709
 710 tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
 711   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
 712         ; expr1' <- tcPolyExpr expr1 elt_ty
 713         ; expr2' <- tcPolyExpr expr2 elt_ty
 714         ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
 715                               enumFromThenName elt_ty
 716         ; return $ mkHsWrapCo coi
 717                     (ArithSeq enum_from_then (FromThen expr1' expr2')) }
 718
 719 tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
 720   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
 721         ; expr1' <- tcPolyExpr expr1 elt_ty
 722         ; expr2' <- tcPolyExpr expr2 elt_ty
 723         ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
 724                               enumFromToName elt_ty
 725         ; return $ mkHsWrapCo coi
 726                      (ArithSeq enum_from_to (FromTo expr1' expr2')) }
 727
 728 tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 729   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
 730         ; expr1' <- tcPolyExpr expr1 elt_ty
 731         ; expr2' <- tcPolyExpr expr2 elt_ty
 732         ; expr3' <- tcPolyExpr expr3 elt_ty
 733         ; eft <- newMethodFromName (ArithSeqOrigin seq)
 734                       enumFromThenToName elt_ty
 735         ; return $ mkHsWrapCo coi
 736                      (ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
 737
 738 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
 739   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
 740         ; expr1' <- tcPolyExpr expr1 elt_ty
 741         ; expr2' <- tcPolyExpr expr2 elt_ty
 742         ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
 743                                  (enumFromToPName basePackageId) elt_ty    -- !!!FIXME: chak
 744         ; return $ mkHsWrapCo coi
 745                      (PArrSeq enum_from_to (FromTo expr1' expr2')) }
 746
 747 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 748   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
 749         ; expr1' <- tcPolyExpr expr1 elt_ty
 750         ; expr2' <- tcPolyExpr expr2 elt_ty
 751         ; expr3' <- tcPolyExpr expr3 elt_ty
 752         ; eft <- newMethodFromName (PArrSeqOrigin seq)
 753                       (enumFromThenToPName basePackageId) elt_ty        -- !!!FIXME: chak
 754         ; return $ mkHsWrapCo coi
 755                      (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
 756
 757 tcExpr (PArrSeq _ _) _
 758   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 759     -- the parser shouldn't have generated it and the renamer shouldn't have
 760     -- let it through
 761 \end{code}
 762
 763
 764 %************************************************************************
 765 %*                                                                      *
 766                 Template Haskell
 767 %*                                                                      *
 768 %************************************************************************
 769
 770 \begin{code}
 771 #ifdef GHCI     /* Only if bootstrapped */
 772         -- Rename excludes these cases otherwise
 773 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 774 tcExpr (HsBracket brack)  res_ty = do   { e <- tcBracket brack res_ty
 775                                         ; return (unLoc e) }
 776 tcExpr e@(HsQuasiQuoteE _) _ =
 777     pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
 778 #endif /* GHCI */
 779 \end{code}
 780
 781
 782 %************************************************************************
 783 %*                                                                      *
 784                 Catch-all
 785 %*                                                                      *
 786 %************************************************************************
 787
 788 \begin{code}
 789 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 790 \end{code}
 791
 792
 793 %************************************************************************
 794 %*                                                                      *
 795                 Applications
 796 %*                                                                      *
 797 %************************************************************************
 798
 799 \begin{code}
 800 tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
 801       -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
 802
 803 tcApp (L _ (HsPar e)) args res_ty
 804   = tcApp e args res_ty
 805
 806 tcApp (L _ (HsApp e1 e2)) args res_ty
 807   = tcApp e1 (e2:args) res_ty   -- Accumulate the arguments
 808
 809 tcApp (L loc (HsVar fun)) args res_ty
 810   | fun `hasKey` tagToEnumKey
 811   , [arg] <- args
 812   = tcTagToEnum loc fun arg res_ty
 813
 814 tcApp fun args res_ty
 815   = do  {   -- Type-check the function
 816         ; (fun1, fun_tau) <- tcInferFun fun
 817
 818             -- Extract its argument types
 819         ; (co_fun, expected_arg_tys, actual_res_ty)
 820               <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
 821
 822         -- Typecheck the result, thereby propagating
 823         -- info (if any) from result into the argument types
 824         -- Both actual_res_ty and res_ty are deeply skolemised
 825         ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
 826                     unifyType actual_res_ty res_ty
 827
 828         -- Typecheck the arguments
 829         ; args1 <- tcArgs fun args expected_arg_tys
 830
 831         -- Assemble the result
 832         ; let fun2 = mkLHsWrapCo co_fun fun1
 833               app  = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1)
 834
 835         ; return (unLoc app) }
 836
 837
 838 mk_app_msg :: LHsExpr Name -> SDoc
 839 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
 840                      , ptext (sLit "is applied to")]
 841
 842 ----------------
 843 tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
 844            -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args
 845
 846 tcInferApp (L _ (HsPar e))     args = tcInferApp e args
 847 tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args)
 848 tcInferApp fun args
 849   = -- Very like the tcApp version, except that there is
 850     -- no expected result type passed in
 851     do  { (fun1, fun_tau) <- tcInferFun fun
 852         ; (co_fun, expected_arg_tys, actual_res_ty)
 853               <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
 854         ; args1 <- tcArgs fun args expected_arg_tys
 855         ; let fun2 = mkLHsWrapCo co_fun fun1
 856               app  = foldl mkHsApp fun2 args1
 857         ; return (unLoc app, actual_res_ty) }
 858
 859 ----------------
 860 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 861 -- Infer and instantiate the type of a function
 862 tcInferFun (L loc (HsVar name))
 863   = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
 864                -- Don't wrap a context around a plain Id
 865        ; return (L loc fun, ty) }
 866
 867 tcInferFun fun
 868   = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
 869
 870          -- Zonk the function type carefully, to expose any polymorphism
 871          -- E.g. (( \(x::forall a. a->a). blah ) e)
 872          -- We can see the rank-2 type of the lambda in time to genrealise e
 873        ; fun_ty' <- zonkTcTypeCarefully fun_ty
 874
 875        ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
 876        ; return (mkLHsWrap wrap fun, rho) }
 877
 878 ----------------
 879 tcArgs :: LHsExpr Name                          -- The function (for error messages)
 880        -> [LHsExpr Name] -> [TcSigmaType]       -- Actual arguments and expected arg types
 881        -> TcM [LHsExpr TcId]                    -- Resulting args
 882
 883 tcArgs fun args expected_arg_tys
 884   = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
 885
 886 ----------------
 887 tcArg :: LHsExpr Name                           -- The function (for error messages)
 888        -> (LHsExpr Name, TcSigmaType, Int)      -- Actual argument and expected arg type
 889        -> TcM (LHsExpr TcId)                    -- Resulting argument
 890 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
 891                                          (tcPolyExprNC arg ty)
 892
 893 ----------------
 894 tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId]
 895 tcTupArgs args tys
 896   = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
 897   where
 898     go (Missing {},   arg_ty) = return (Missing arg_ty)
 899     go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
 900                                    ; return (Present expr') }
 901
 902 ----------------
 903 unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
 904               -> TcM (Coercion, [TcSigmaType], TcRhoType)
 905 -- A wrapper for matchExpectedFunTys
 906 unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
 907   where
 908     herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
 909
 910 ---------------------------
 911 tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 912 -- Typecheck a syntax operator, checking that it has the specified type
 913 -- The operator is always a variable at this stage (i.e. renamer output)
 914 -- This version assumes res_ty is a monotype
 915 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
 916                                        ; tcWrapResult expr rho res_ty }
 917 tcSyntaxOp _ other         _      = pprPanic "tcSyntaxOp" (ppr other)
 918 \end{code}
 919
 920
 921 Note [Push result type in]
 922 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 923 Unify with expected result before type-checking the args so that the
 924 info from res_ty percolates to args.  This is when we might detect a
 925 too-few args situation.  (One can think of cases when the opposite
 926 order would give a better error message.)
 927 experimenting with putting this first.
 928
 929 Here's an example where it actually makes a real difference
 930
 931    class C t a b | t a -> b
 932    instance C Char a Bool
 933
 934    data P t a = forall b. (C t a b) => MkP b
 935    data Q t   = MkQ (forall a. P t a)
 936
 937    f1, f2 :: Q Char;
 938    f1 = MkQ (MkP True)
 939    f2 = MkQ (MkP True :: forall a. P Char a)
 940
 941 With the change, f1 will type-check, because the 'Char' info from
 942 the signature is propagated into MkQ's argument. With the check
 943 in the other order, the extra signature in f2 is reqd.
 944
 945
 946 %************************************************************************
 947 %*                                                                      *
 948                  tcInferId
 949 %*                                                                      *
 950 %************************************************************************
 951
 952 \begin{code}
 953 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
 954 tcCheckId name res_ty = do { (expr, rho) <- tcInferId name
 955                            ; tcWrapResult expr rho res_ty }
 956
 957 ------------------------
 958 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
 959 -- Infer type, and deeply instantiate
 960 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
 961
 962 ------------------------
 963 tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
 964 -- Look up an occurrence of an Id, and instantiate it (deeply)
 965
 966 tcInferIdWithOrig orig id_name
 967   = do { id <- lookup_id
 968        ; (id_expr, id_rho) <- instantiateOuter orig id
 969        ; (wrap, rho) <- deeplyInstantiate orig id_rho
 970        ; return (mkHsWrap wrap id_expr, rho) }
 971   where
 972     lookup_id :: TcM TcId
 973     lookup_id
 974        = do { thing <- tcLookup id_name
 975             ; case thing of
 976                  ATcId { tct_id = id, tct_level = lvl }
 977                    -> do { check_naughty id        -- Note [Local record selectors]
 978                          ; checkThLocalId id lvl
 979                          ; return id }
 980
 981                  AGlobal (AnId id)
 982                    -> do { check_naughty id; return id }
 983                         -- A global cannot possibly be ill-staged
 984                         -- nor does it need the 'lifting' treatment
 985                         -- hence no checkTh stuff here
 986
 987                  AGlobal (ADataCon con) -> return (dataConWrapId con)
 988
 989                  other -> failWithTc (bad_lookup other) }
 990
 991     bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected")
 992
 993     check_naughty id
 994       | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
 995       | otherwise                  = return ()
 996
 997 ------------------------
 998 instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType)
 999 -- Do just the first level of instantiation of an Id
1000 --   a) Deal with method sharing
1001 --   b) Deal with stupid checks
1002 -- Only look at the *outer level* of quantification
1003 -- See Note [Multiple instantiation]
1004
1005 instantiateOuter orig id
1006   | null tvs && null theta
1007   = return (HsVar id, tau)
1008
1009   | otherwise
1010   = do { (_, tys, subst) <- tcInstTyVars tvs
1011        ; doStupidChecks id tys
1012        ; let theta' = substTheta subst theta
1013        ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
1014        ; wrap <- instCall orig tys theta'
1015        ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) }
1016   where
1017     (tvs, theta, tau) = tcSplitSigmaTy (idType id)
1018 \end{code}
1019
1020 Note [Multiple instantiation]
1021 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1022 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
1023 For example, consider
1024         f :: forall a. Eq a => forall b. Ord b => a -> b
1025 At a call to f, at say [Int, Bool], it's tempting to translate the call to
1026
1027         f_m1
1028   where
1029         f_m1 :: forall b. Ord b => Int -> b
1030         f_m1 = f Int dEqInt
1031
1032         f_m2 :: Int -> Bool
1033         f_m2 = f_m1 Bool dOrdBool
1034
1035 But notice that f_m2 has f_m1 as its meth_id.  Now the danger is that if we do
1036 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
1037         f_m1 = f_mx
1038 But it's entirely possible that f_m2 will continue to float out, because it
1039 mentions no type variables.  Result, f_m1 isn't in scope.
1040
1041 Here's a concrete example that does this (test tc200):
1042
1043     class C a where
1044       f :: Eq b => b -> a -> Int
1045       baz :: Eq a => Int -> a -> Int
1046
1047     instance C Int where
1048       baz = f
1049
1050 Current solution: only do the "method sharing" thing for the first type/dict
1051 application, not for the iterated ones.  A horribly subtle point.
1052
1053 Note [No method sharing]
1054 ~~~~~~~~~~~~~~~~~~~~~~~~
1055 The -fno-method-sharing flag controls what happens so far as the LIE
1056 is concerned.  The default case is that for an overloaded function we
1057 generate a "method" Id, and add the Method Inst to the LIE.  So you get
1058 something like
1059         f :: Num a => a -> a
1060         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
1061 If you specify -fno-method-sharing, the dictionary application
1062 isn't shared, so we get
1063         f :: Num a => a -> a
1064         f = /\a (d:Num a) (x:a) -> (+) a d x x
1065 This gets a bit less sharing, but
1066         a) it's better for RULEs involving overloaded functions
1067         b) perhaps fewer separated lambdas
1068
1069 \begin{code}
1070 doStupidChecks :: TcId
1071                -> [TcType]
1072                -> TcM ()
1073 -- Check two tiresome and ad-hoc cases
1074 -- (a) the "stupid theta" for a data con; add the constraints
1075 --     from the "stupid theta" of a data constructor (sigh)
1076
1077 doStupidChecks fun_id tys
1078   | Just con <- isDataConId_maybe fun_id   -- (a)
1079   = addDataConStupidTheta con tys
1080
1081   | fun_id `hasKey` tagToEnumKey           -- (b)
1082   = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
1083
1084   | otherwise
1085   = return () -- The common case
1086 \end{code}
1087
1088 Note [tagToEnum#]
1089 ~~~~~~~~~~~~~~~~~
1090 Nasty check to ensure that tagToEnum# is applied to a type that is an
1091 enumeration TyCon.  Unification may refine the type later, but this
1092 check won't see that, alas.  It's crude, because it relies on our
1093 knowing *now* that the type is ok, which in turn relies on the
1094 eager-unification part of the type checker pushing enough information
1095 here.  In theory the Right Thing to do is to have a new form of
1096 constraint but I definitely cannot face that!  And it works ok as-is.
1097
1098 Here's are two cases that should fail
1099         f :: forall a. a
1100         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
1101
1102         g :: Int
1103         g = tagToEnum# 0        -- Int is not an enumeration
1104
1105 When data type families are involved it's a bit more complicated.
1106      data family F a
1107      data instance F [Int] = A | B | C
1108 Then we want to generate something like
1109      tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1110 Usually that coercion is hidden inside the wrappers for
1111 constructors of F [Int] but here we have to do it explicitly.
1112
1113 It's all grotesquely complicated.
1114
1115 \begin{code}
1116 tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
1117 -- tagToEnum# :: forall a. Int# -> a
1118 -- See Note [tagToEnum#]   Urgh!
1119 tcTagToEnum loc fun_name arg res_ty
1120   = do  { fun <- tcLookupId fun_name
1121         ; ty' <- zonkTcType res_ty
1122
1123         -- Check that the type is algebraic
1124         ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1125               Just (tc, tc_args) = mb_tc_app
1126         ; checkTc (isJust mb_tc_app)
1127                   (tagToEnumError ty' doc1)
1128
1129         -- Look through any type family
1130         ; (coi, rep_tc, rep_args) <- get_rep_ty ty' tc tc_args
1131
1132         ; checkTc (isEnumerationTyCon rep_tc)
1133                   (tagToEnumError ty' doc2)
1134
1135         ; arg' <- tcMonoExpr arg intPrimTy
1136         ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
1137               rep_ty = mkTyConApp rep_tc rep_args
1138
1139         ; return (mkHsWrapCo coi $ HsApp fun' arg') }
1140   where
1141     doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
1142                 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
1143     doc2 = ptext (sLit "Result type must be an enumeration type")
1144     doc3 = ptext (sLit "No family instance for this type")
1145
1146     get_rep_ty :: TcType -> TyCon -> [TcType]
1147                -> TcM (Coercion, TyCon, [TcType])
1148         -- Converts a family type (eg F [a]) to its rep type (eg FList a)
1149         -- and returns a coercion between the two
1150     get_rep_ty ty tc tc_args
1151       | not (isFamilyTyCon tc)
1152       = return (mkReflCo ty, tc, tc_args)
1153       | otherwise
1154       = do { mb_fam <- tcLookupFamInst tc tc_args
1155            ; case mb_fam of
1156                Nothing -> failWithTc (tagToEnumError ty doc3)
1157                Just (rep_tc, rep_args)
1158                    -> return ( mkSymCo (mkAxInstCo co_tc rep_args)
1159                              , rep_tc, rep_args )
1160                  where
1161                    co_tc = expectJust "tcTagToEnum" $
1162                            tyConFamilyCoercion_maybe rep_tc }
1163
1164 tagToEnumError :: TcType -> SDoc -> SDoc
1165 tagToEnumError ty what
1166   = hang (ptext (sLit "Bad call to tagToEnum#")
1167            <+> ptext (sLit "at type") <+> ppr ty)
1168          2 what
1169 \end{code}
1170
1171
1172 %************************************************************************
1173 %*                                                                      *
1174                  Template Haskell checks
1175 %*                                                                      *
1176 %************************************************************************
1177
1178 \begin{code}
1179 checkThLocalId :: Id -> ThLevel -> TcM ()
1180 #ifndef GHCI  /* GHCI and TH is off */
1181 --------------------------------------
1182 -- Check for cross-stage lifting
1183 checkThLocalId _id _bind_lvl
1184   = return ()
1185
1186 #else         /* GHCI and TH is on */
1187 checkThLocalId id bind_lvl
1188   = do  { use_stage <- getStage -- TH case
1189         ; let use_lvl = thLevel use_stage
1190         ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
1191         ; traceTc "thLocalId" (ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
1192         ; when (use_lvl > bind_lvl) $
1193           checkCrossStageLifting id bind_lvl use_stage }
1194
1195 --------------------------------------
1196 checkCrossStageLifting :: Id -> ThLevel -> ThStage -> TcM ()
1197 -- We are inside brackets, and (use_lvl > bind_lvl)
1198 -- Now we must check whether there's a cross-stage lift to do
1199 -- Examples   \x -> [| x |]
1200 --            [| map |]
1201
1202 checkCrossStageLifting _ _ Comp   = return ()
1203 checkCrossStageLifting _ _ Splice = return ()
1204
1205 checkCrossStageLifting id _ (Brack _ ps_var lie_var)
1206   | thTopLevelId id
1207   =     -- Top-level identifiers in this module,
1208         -- (which have External Names)
1209         -- are just like the imported case:
1210         -- no need for the 'lifting' treatment
1211         -- E.g.  this is fine:
1212         --   f x = x
1213         --   g y = [| f 3 |]
1214         -- But we do need to put f into the keep-alive
1215         -- set, because after desugaring the code will
1216         -- only mention f's *name*, not f itself.
1217     keepAliveTc id
1218
1219   | otherwise   -- bind_lvl = outerLevel presumably,
1220                 -- but the Id is not bound at top level
1221   =     -- Nested identifiers, such as 'x' in
1222         -- E.g. \x -> [| h x |]
1223         -- We must behave as if the reference to x was
1224         --      h $(lift x)
1225         -- We use 'x' itself as the splice proxy, used by
1226         -- the desugarer to stitch it all back together.
1227         -- If 'x' occurs many times we may get many identical
1228         -- bindings of the same splice proxy, but that doesn't
1229         -- matter, although it's a mite untidy.
1230     do  { let id_ty = idType id
1231         ; checkTc (isTauTy id_ty) (polySpliceErr id)
1232                -- If x is polymorphic, its occurrence sites might
1233                -- have different instantiations, so we can't use plain
1234                -- 'x' as the splice proxy name.  I don't know how to
1235                -- solve this, and it's probably unimportant, so I'm
1236                -- just going to flag an error for now
1237
1238         ; lift <- if isStringTy id_ty then
1239                      do { sid <- tcLookupId DsMeta.liftStringName
1240                                      -- See Note [Lifting strings]
1241                         ; return (HsVar sid) }
1242                   else
1243                      setConstraintVar lie_var   $ do
1244                           -- Put the 'lift' constraint into the right LIE
1245                      newMethodFromName (OccurrenceOf (idName id))
1246                                        DsMeta.liftName id_ty
1247
1248                    -- Update the pending splices
1249         ; ps <- readMutVar ps_var
1250         ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps)
1251
1252         ; return () }
1253 #endif /* GHCI */
1254 \end{code}
1255
1256 Note [Lifting strings]
1257 ~~~~~~~~~~~~~~~~~~~~~~
1258 If we see $(... [| s |] ...) where s::String, we don't want to
1259 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1260 So this conditional short-circuits the lifting mechanism to generate
1261 (liftString "xy") in that case.  I didn't want to use overlapping instances
1262 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1263 errors in a polymorphic situation.
1264
1265 If this check fails (which isn't impossible) we get another chance; see
1266 Note [Converting strings] in Convert.lhs
1267
1268 Local record selectors
1269 ~~~~~~~~~~~~~~~~~~~~~~
1270 Record selectors for TyCons in this module are ordinary local bindings,
1271 which show up as ATcIds rather than AGlobals.  So we need to check for
1272 naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
1273
1274
1275 %************************************************************************
1276 %*                                                                      *
1277 \subsection{Record bindings}
1278 %*                                                                      *
1279 %************************************************************************
1280
1281 Game plan for record bindings
1282 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1283 1. Find the TyCon for the bindings, from the first field label.
1284
1285 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1286
1287 For each binding field = value
1288
1289 3. Instantiate the field type (from the field label) using the type
1290    envt from step 2.
1291
1292 4  Type check the value using tcArg, passing the field type as
1293    the expected argument type.
1294
1295 This extends OK when the field types are universally quantified.
1296
1297
1298 \begin{code}
1299 tcRecordBinds
1300         :: DataCon
1301         -> [TcType]     -- Expected type for each field
1302         -> HsRecordBinds Name
1303         -> TcM (HsRecordBinds TcId)
1304
1305 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1306   = do  { mb_binds <- mapM do_bind rbinds
1307         ; return (HsRecFields (catMaybes mb_binds) dd) }
1308   where
1309     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1310     do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1311       | Just field_ty <- assocMaybe flds_w_tys field_lbl
1312       = addErrCtxt (fieldCtxt field_lbl)        $
1313         do { rhs' <- tcPolyExprNC rhs field_ty
1314            ; let field_id = mkUserLocal (nameOccName field_lbl)
1315                                         (nameUnique field_lbl)
1316                                         field_ty loc
1317                 -- Yuk: the field_id has the *unique* of the selector Id
1318                 --          (so we can find it easily)
1319                 --      but is a LocalId with the appropriate type of the RHS
1320                 --          (so the desugarer knows the type of local binder to make)
1321            ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
1322       | otherwise
1323       = do { addErrTc (badFieldCon data_con field_lbl)
1324            ; return Nothing }
1325
1326 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1327 checkMissingFields data_con rbinds
1328   | null field_labels   -- Not declared as a record;
1329                         -- But C{} is still valid if no strict fields
1330   = if any isBanged field_strs then
1331         -- Illegal if any arg is strict
1332         addErrTc (missingStrictFields data_con [])
1333     else
1334         return ()
1335
1336   | otherwise = do              -- A record
1337     unless (null missing_s_fields)
1338            (addErrTc (missingStrictFields data_con missing_s_fields))
1339
1340     warn <- doptM Opt_WarnMissingFields
1341     unless (not (warn && notNull missing_ns_fields))
1342            (warnTc True (missingFields data_con missing_ns_fields))
1343
1344   where
1345     missing_s_fields
1346         = [ fl | (fl, str) <- field_info,
1347                  isBanged str,
1348                  not (fl `elem` field_names_used)
1349           ]
1350     missing_ns_fields
1351         = [ fl | (fl, str) <- field_info,
1352                  not (isBanged str),
1353                  not (fl `elem` field_names_used)
1354           ]
1355
1356     field_names_used = hsRecFields rbinds
1357     field_labels     = dataConFieldLabels data_con
1358
1359     field_info = zipEqual "missingFields"
1360                           field_labels
1361                           field_strs
1362
1363     field_strs = dataConStrictMarks data_con
1364 \end{code}
1365
1366 %************************************************************************
1367 %*                                                                      *
1368 \subsection{Errors and contexts}
1369 %*                                                                      *
1370 %************************************************************************
1371
1372 Boring and alphabetical:
1373 \begin{code}
1374 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
1375 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
1376
1377 exprCtxt :: LHsExpr Name -> SDoc
1378 exprCtxt expr
1379   = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
1380
1381 fieldCtxt :: Name -> SDoc
1382 fieldCtxt field_name
1383   = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1384
1385 funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
1386 funAppCtxt fun arg arg_no
1387   = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1388                     quotes (ppr fun) <> text ", namely"])
1389        2 (quotes (ppr arg))
1390
1391 funResCtxt :: LHsExpr Name -> TcType -> TcType
1392            -> TidyEnv -> TcM (TidyEnv, Message)
1393 -- When we have a mis-match in the return type of a function
1394 -- try to give a helpful message about too many/few arguments
1395 funResCtxt fun fun_res_ty res_ty env0
1396   = do { fun_res' <- zonkTcType fun_res_ty
1397        ; res'     <- zonkTcType res_ty
1398        ; let n_fun = length (fst (tcSplitFunTys fun_res'))
1399              n_res = length (fst (tcSplitFunTys res'))
1400              what  | n_fun > n_res = ptext (sLit "few")
1401                    | otherwise     = ptext (sLit "many")
1402              extra | n_fun == n_res = empty
1403                    | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
1404                                  <+> ptext (sLit "is applied to too") <+> what
1405                                  <+> ptext (sLit "arguments")
1406              msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
1407        ; return (env0, msg $$ extra) }
1408
1409 badFieldTypes :: [(Name,TcType)] -> SDoc
1410 badFieldTypes prs
1411   = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1412                          <> plural prs <> colon)
1413        2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1414
1415 badFieldsUpd :: HsRecFields Name a -> SDoc
1416 badFieldsUpd rbinds
1417   = hang (ptext (sLit "No constructor has all these fields:"))
1418        2 (pprQuotedList (hsRecFields rbinds))
1419
1420 naughtyRecordSel :: TcId -> SDoc
1421 naughtyRecordSel sel_id
1422   = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1423     ptext (sLit "as a function due to escaped type variables") $$
1424     ptext (sLit "Probable fix: use pattern-matching syntax instead")
1425
1426 notSelector :: Name -> SDoc
1427 notSelector field
1428   = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1429
1430 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1431 missingStrictFields con fields
1432   = header <> rest
1433   where
1434     rest | null fields = empty  -- Happens for non-record constructors
1435                                 -- with strict fields
1436          | otherwise   = colon <+> pprWithCommas ppr fields
1437
1438     header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1439              ptext (sLit "does not have the required strict field(s)")
1440
1441 missingFields :: DataCon -> [FieldLabel] -> SDoc
1442 missingFields con fields
1443   = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1444         <+> pprWithCommas ppr fields
1445
1446 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1447
1448 #ifdef GHCI
1449 polySpliceErr :: Id -> SDoc
1450 polySpliceErr id
1451   = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
1452 #endif
1453 \end{code}