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