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