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