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 module TcExpr ( tcPolyExpr, tcPolyExprNC,
   9                 tcMonoExpr, tcInferRho, tcSyntaxOp ) where
  10
  11 #include "HsVersions.h"
  12
  13 #ifdef GHCI     /* Only if bootstrapped */
  14 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcBracket )
  15 import qualified DsMeta
  16 #endif
  17
  18 import HsSyn
  19 import TcHsSyn
  20 import TcRnMonad
  21 import TcUnify
  22 import BasicTypes
  23 import Inst
  24 import TcBinds
  25 import TcEnv
  26 import TcArrows
  27 import TcMatches
  28 import TcHsType
  29 import TcPat
  30 import TcMType
  31 import TcType
  32 import TcIface  ( checkWiredInTyCon )
  33 import Id
  34 import DataCon
  35 import Name
  36 import TyCon
  37 import Type
  38 import Var
  39 import VarSet
  40 import TysWiredIn
  41 import PrelNames
  42 import PrimOp
  43 import DynFlags
  44 import StaticFlags
  45 import HscTypes
  46 import SrcLoc
  47 import Util
  48 import ListSetOps
  49 import Maybes
  50 import Outputable
  51 import FastString
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{Main wrappers}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 tcPolyExpr, tcPolyExprNC
  62          :: LHsExpr Name                -- Expession to type check
  63          -> BoxySigmaType               -- Expected type (could be a polytpye)
  64          -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
  65
  66 -- tcPolyExpr is a convenient place (frequent but not too frequent) place
  67 -- to add context information.
  68 -- The NC version does not do so, usually because the caller wants
  69 -- to do so himself.
  70
  71 tcPolyExpr expr res_ty
  72   = addErrCtxt (exprCtxt (unLoc expr)) $
  73     tcPolyExprNC expr res_ty
  74
  75 tcPolyExprNC expr res_ty
  76   | isSigmaTy res_ty
  77   = do  { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
  78                 -- Note the recursive call to tcPolyExpr, because the
  79                 -- type may have multiple layers of for-alls
  80                 -- E.g. forall a. Eq a => forall b. Ord b => ....
  81         ; return (mkLHsWrap gen_fn expr') }
  82
  83   | otherwise
  84   = tcMonoExpr expr res_ty
  85
  86 ---------------
  87 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
  88 tcPolyExprs [] [] = returnM []
  89 tcPolyExprs (expr:exprs) (ty:tys)
  90  = do   { expr'  <- tcPolyExpr  expr  ty
  91         ; exprs' <- tcPolyExprs exprs tys
  92         ; returnM (expr':exprs') }
  93 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
  94
  95 ---------------
  96 tcMonoExpr :: LHsExpr Name      -- Expression to type check
  97            -> BoxyRhoType       -- Expected type (could be a type variable)
  98                                 -- Definitely no foralls at the top
  99                                 -- Can contain boxes, which will be filled in
 100            -> TcM (LHsExpr TcId)
 101
 102 tcMonoExpr (L loc expr) res_ty
 103   = ASSERT( not (isSigmaTy res_ty) )
 104     setSrcSpan loc $
 105     do  { expr' <- tcExpr expr res_ty
 106         ; return (L loc expr') }
 107
 108 ---------------
 109 tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 110 tcInferRho expr = tcInfer (tcMonoExpr expr)
 111 \end{code}
 112
 113
 114
 115 %************************************************************************
 116 %*                                                                      *
 117         tcExpr: the main expression typechecker
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
 123 tcExpr (HsVar name)     res_ty = tcId (OccurrenceOf name) name res_ty
 124
 125 tcExpr (HsLit lit)      res_ty = do { boxyUnify (hsLitType lit) res_ty
 126                                     ; return (HsLit lit) }
 127
 128 tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExpr expr res_ty
 129                                     ; return (HsPar expr') }
 130
 131 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
 132                                     ; returnM (HsSCC lbl expr') }
 133 tcExpr (HsTickPragma info expr) res_ty
 134                                = do { expr' <- tcMonoExpr expr res_ty
 135                                     ; returnM (HsTickPragma info expr') }
 136
 137 tcExpr (HsCoreAnn lbl expr) res_ty       -- hdaume: core annotation
 138   = do  { expr' <- tcMonoExpr expr res_ty
 139         ; return (HsCoreAnn lbl expr') }
 140
 141 tcExpr (HsOverLit lit) res_ty
 142   = do  { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
 143         ; return (HsOverLit lit') }
 144
 145 tcExpr (NegApp expr neg_expr) res_ty
 146   = do  { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
 147                                   (mkFunTy res_ty res_ty)
 148         ; expr' <- tcMonoExpr expr res_ty
 149         ; return (NegApp expr' neg_expr') }
 150
 151 tcExpr (HsIPVar ip) res_ty
 152   = do  {       -- Implicit parameters must have a *tau-type* not a
 153                 -- type scheme.  We enforce this by creating a fresh
 154                 -- type variable as its type.  (Because res_ty may not
 155                 -- be a tau-type.)
 156           ip_ty <- newFlexiTyVarTy argTypeKind  -- argTypeKind: it can't be an unboxed tuple
 157         ; co_fn <- tcSubExp ip_ty res_ty
 158         ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
 159         ; extendLIE inst
 160         ; return (mkHsWrap co_fn (HsIPVar ip')) }
 161
 162 tcExpr (HsApp e1 e2) res_ty
 163   = go e1 [e2]
 164   where
 165     go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
 166     go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
 167     go lfun@(L loc fun) args
 168         = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
 169                                 tcApp fun (length args) (tcArgs lfun args) res_ty
 170              ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
 171
 172 tcExpr (HsLam match) res_ty
 173   = do  { (co_fn, match') <- tcMatchLambda match res_ty
 174         ; return (mkHsWrap co_fn (HsLam match')) }
 175
 176 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
 177  = do   { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 178
 179         -- Remember to extend the lexical type-variable environment
 180         ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
 181                              tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
 182                              tcPolyExprNC expr res_ty)
 183
 184         ; co_fn <- tcSubExp sig_tc_ty res_ty
 185         ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
 186
 187 tcExpr (HsType ty) res_ty
 188   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 189         -- This is the syntax for type applications that I was planning
 190         -- but there are difficulties (e.g. what order for type args)
 191         -- so it's not enabled yet.
 192         -- Can't eliminate it altogether from the parser, because the
 193         -- same parser parses *patterns*.
 194 \end{code}
 195
 196
 197 %************************************************************************
 198 %*                                                                      *
 199                 Infix operators and sections
 200 %*                                                                      *
 201 %************************************************************************
 202
 203 \begin{code}
 204 tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
 205   = do  { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
 206         ; return (OpApp arg1' (L loc op') fix arg2') }
 207
 208 -- Left sections, equivalent to
 209 --      \ x -> e op x,
 210 -- or
 211 --      \ x -> op e x,
 212 -- or just
 213 --      op e
 214 --
 215 -- We treat it as similar to the latter, so we don't
 216 -- actually require the function to take two arguments
 217 -- at all.  For example, (x `not`) means (not x);
 218 -- you get postfix operators!  Not really Haskell 98
 219 -- I suppose, but it's less work and kind of useful.
 220
 221 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 222   = do  { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
 223         ; return (SectionL arg1' (L loc op')) }
 224
 225 -- Right sections, equivalent to \ x -> x `op` expr, or
 226 --      \ x -> op x expr
 227
 228 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
 229   = do  { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
 230                                    tcApp op 2 (tc_args arg1_ty') res_ty'
 231         ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
 232   where
 233     doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
 234                 <+> ptext SLIT("takes one argument")
 235     tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty]
 236         = do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty)
 237              ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty
 238              ; qtys' <- mapM refineBox qtys     -- c.f. tcArgs
 239              ; return (qtys', arg2') }
 240     tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
 241 \end{code}
 242
 243 \begin{code}
 244 tcExpr (HsLet binds expr) res_ty
 245   = do  { (binds', expr') <- tcLocalBinds binds $
 246                              tcMonoExpr expr res_ty
 247         ; return (HsLet binds' expr') }
 248
 249 tcExpr (HsCase scrut matches) exp_ty
 250   = do  {  -- We used to typecheck the case alternatives first.
 251            -- The case patterns tend to give good type info to use
 252            -- when typechecking the scrutinee.  For example
 253            --   case (map f) of
 254            --     (x:xs) -> ...
 255            -- will report that map is applied to too few arguments
 256            --
 257            -- But now, in the GADT world, we need to typecheck the scrutinee
 258            -- first, to get type info that may be refined in the case alternatives
 259           (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
 260                                            (tcInferRho scrut)
 261
 262         ; traceTc (text "HsCase" <+> ppr scrut_ty)
 263         ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
 264         ; return (HsCase scrut' matches') }
 265  where
 266     match_ctxt = MC { mc_what = CaseAlt,
 267                       mc_body = tcBody }
 268
 269 tcExpr (HsIf pred b1 b2) res_ty
 270   = do  { pred' <- addErrCtxt (predCtxt pred) $
 271                    tcMonoExpr pred boolTy
 272         ; b1' <- tcMonoExpr b1 res_ty
 273         ; b2' <- tcMonoExpr b2 res_ty
 274         ; return (HsIf pred' b1' b2') }
 275
 276 tcExpr (HsDo do_or_lc stmts body _) res_ty
 277   = tcDoStmts do_or_lc stmts body res_ty
 278
 279 tcExpr in_expr@(ExplicitList _ exprs) res_ty    -- Non-empty list
 280   = do  { elt_ty <- boxySplitListTy res_ty
 281         ; exprs' <- mappM (tc_elt elt_ty) exprs
 282         ; return (ExplicitList elt_ty exprs') }
 283   where
 284     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 285
 286 tcExpr in_expr@(ExplicitPArr _ exprs) res_ty    -- maybe empty
 287   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 288         ; exprs' <- mappM (tc_elt elt_ty) exprs
 289         ; ifM (null exprs) (zapToMonotype elt_ty)
 290                 -- If there are no expressions in the comprehension
 291                 -- we must still fill in the box
 292                 -- (Not needed for [] and () becuase they happen
 293                 --  to parse as data constructors.)
 294         ; return (ExplicitPArr elt_ty exprs') }
 295   where
 296     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 297
 298 -- For tuples, take care to preserve rigidity
 299 -- E.g.         case (x,y) of ....
 300 --         The scrutinee should have a rigid type if x,y do
 301 -- The general scheme is the same as in tcIdApp
 302 tcExpr (ExplicitTuple exprs boxity) res_ty
 303   = do  { tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
 304         ; let tup_tc     = tupleTyCon boxity (length exprs)
 305               tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
 306         ; checkWiredInTyCon tup_tc      -- Ensure instances are available
 307         ; arg_tys  <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
 308         ; exprs'   <- tcPolyExprs exprs arg_tys
 309         ; arg_tys' <- mapM refineBox arg_tys
 310         ; co_fn    <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty
 311         ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
 312
 313 tcExpr (HsProc pat cmd) res_ty
 314   = do  { (pat', cmd') <- tcProc pat cmd res_ty
 315         ; return (HsProc pat' cmd') }
 316
 317 tcExpr e@(HsArrApp _ _ _ _ _) _
 318   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 319                       ptext SLIT("was found where an expression was expected")])
 320
 321 tcExpr e@(HsArrForm _ _ _) _
 322   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 323                       ptext SLIT("was found where an expression was expected")])
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328                 Record construction and update
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 \begin{code}
 333 tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
 334   = do  { data_con <- tcLookupDataCon con_name
 335
 336         -- Check for missing fields
 337         ; checkMissingFields data_con rbinds
 338
 339         ; let arity = dataConSourceArity data_con
 340               check_fields qtvs qtys arg_tys
 341                   = do  { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
 342                         ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
 343                         ; qtys' <- mapM refineBoxToTau qtys
 344                         ; return (qtys', rbinds') }
 345                 -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
 346                 -- filled, which is the invariant expected by tcIdApp
 347                 -- How could this not be the case?  Consider a record construction
 348                 -- that does not mention all the fields.
 349
 350         ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
 351
 352         ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
 353
 354 -- The main complication with RecordUpd is that we need to explicitly
 355 -- handle the *non-updated* fields.  Consider:
 356 --
 357 --      data T a b = MkT1 { fa :: a, fb :: b }
 358 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 359 --                 | MkT3 { fd :: a }
 360 --
 361 --      upd :: T a b -> c -> T a c
 362 --      upd t x = t { fb = x}
 363 --
 364 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 365 -- because upd should be equivalent to:
 366 --
 367 --      upd t x = case t of
 368 --                      MkT1 p q -> MkT1 p x
 369 --                      MkT2 a b -> MkT2 p b
 370 --                      MkT3 d   -> error ...
 371 --
 372 -- So we need to give a completely fresh type to the result record,
 373 -- and then constrain it by the fields that are *not* updated ("p" above).
 374 --
 375 -- Note that because MkT3 doesn't contain all the fields being updated,
 376 -- its RHS is simply an error, so it doesn't impose any type constraints
 377 --
 378 -- All this is done in STEP 4 below.
 379 --
 380 -- Note about GADTs
 381 -- ~~~~~~~~~~~~~~~~
 382 -- For record update we require that every constructor involved in the
 383 -- update (i.e. that has all the specified fields) is "vanilla".  I
 384 -- don't know how to do the update otherwise.
 385
 386
 387 tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
 388   =     -- STEP 0
 389         -- Check that the field names are really field names
 390     let
 391         field_names = hsRecFields rbinds
 392     in
 393     ASSERT( notNull field_names )
 394     mappM tcLookupField field_names     `thenM` \ sel_ids ->
 395         -- The renamer has already checked that they
 396         -- are all in scope
 397     let
 398         bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
 399                    | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
 400                      not (isRecordSelector sel_id),     -- Excludes class ops
 401                      let L loc field_name = hsRecFieldId fld
 402                    ]
 403     in
 404     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)  `thenM_`
 405
 406         -- STEP 1
 407         -- Figure out the tycon and data cons from the first field name
 408     let
 409                 -- It's OK to use the non-tc splitters here (for a selector)
 410         sel_id : _      = sel_ids
 411         (tycon, _)      = recordSelectorFieldLabel sel_id       -- We've failed already if
 412         data_cons       = tyConDataCons tycon                   -- it's not a field label
 413                 -- NB: for a data type family, the tycon is the instance tycon
 414
 415         relevant_cons   = filter is_relevant data_cons
 416         is_relevant con = all (`elem` dataConFieldLabels con) field_names
 417     in
 418
 419         -- STEP 2
 420         -- Check that at least one constructor has all the named fields
 421         -- i.e. has an empty set of bad fields returned by badFields
 422     checkTc (not (null relevant_cons))
 423             (badFieldsUpd rbinds)       `thenM_`
 424
 425         -- Check that all relevant data cons are vanilla.  Doing record updates on
 426         -- GADTs and/or existentials is more than my tiny brain can cope with today
 427     checkTc (all isVanillaDataCon relevant_cons)
 428             (nonVanillaUpd tycon)       `thenM_`
 429
 430         -- STEP 4
 431         -- Use the un-updated fields to find a vector of booleans saying
 432         -- which type arguments must be the same in updatee and result.
 433         --
 434         -- WARNING: this code assumes that all data_cons in a common tycon
 435         -- have FieldLabels abstracted over the same tyvars.
 436     let
 437                 -- A constructor is only relevant to this process if
 438                 -- it contains *all* the fields that are being updated
 439         con1 = ASSERT( not (null relevant_cons) ) head relevant_cons    -- A representative constructor
 440         (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1
 441         con1_flds     = dataConFieldLabels con1
 442         common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
 443                                                , not (fld `elem` field_names) ]
 444
 445         is_common_tv tv = tv `elemVarSet` common_tyvars
 446
 447         mk_inst_ty tv result_inst_ty
 448           | is_common_tv tv = returnM result_inst_ty            -- Same as result type
 449           | otherwise       = newFlexiTyVarTy (tyVarKind tv)    -- Fresh type, of correct kind
 450     in
 451     ASSERT( null theta )        -- Vanilla datacon
 452     tcInstTyVars con1_tyvars                            `thenM` \ (_, result_inst_tys, result_inst_env) ->
 453     zipWithM mk_inst_ty con1_tyvars result_inst_tys     `thenM` \ scrut_inst_tys ->
 454
 455         -- STEP 3: Typecheck the update bindings.
 456         -- Do this after checking for bad fields in case
 457         -- there's a field that doesn't match the constructor.
 458     let
 459         result_ty     = substTy result_inst_env con1_res_ty
 460         con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
 461     in
 462     tcSubExp result_ty res_ty                   `thenM` \ co_fn ->
 463     tcRecordBinds con1 con1_arg_tys' rbinds     `thenM` \ rbinds' ->
 464
 465         -- STEP 5: Typecheck the expression to be updated
 466     let
 467         scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys
 468         scrut_ty = substTy scrut_inst_env con1_res_ty
 469         -- This is one place where the isVanilla check is important
 470         -- So that inst_tys matches the con1_tyvars
 471     in
 472     tcMonoExpr record_expr scrut_ty             `thenM` \ record_expr' ->
 473
 474         -- STEP 6: Figure out the LIE we need.
 475         -- We have to generate some dictionaries for the data type context,
 476         -- since we are going to do pattern matching over the data cons.
 477         --
 478         -- What dictionaries do we need?  The dataConStupidTheta tells us.
 479     let
 480         theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
 481     in
 482     instStupidTheta RecordUpdOrigin theta'      `thenM_`
 483
 484         -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
 485     let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
 486                  = WpCo $ mkTyConApp co_con scrut_inst_tys
 487                  | otherwise
 488                  = idHsWrapper
 489     in
 490         -- Phew!
 491     returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
 492                                        relevant_cons scrut_inst_tys result_inst_tys))
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498         Arithmetic sequences                    e.g. [a,b..]
 499         and their parallel-array counterparts   e.g. [: a,b.. :]
 500
 501 %*                                                                      *
 502 %************************************************************************
 503
 504 \begin{code}
 505 tcExpr (ArithSeq _ seq@(From expr)) res_ty
 506   = do  { elt_ty <- boxySplitListTy res_ty
 507         ; expr' <- tcPolyExpr expr elt_ty
 508         ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
 509                               elt_ty enumFromName
 510         ; return (ArithSeq (HsVar enum_from) (From expr')) }
 511
 512 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
 513   = do  { elt_ty <- boxySplitListTy res_ty
 514         ; expr1' <- tcPolyExpr expr1 elt_ty
 515         ; expr2' <- tcPolyExpr expr2 elt_ty
 516         ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
 517                               elt_ty enumFromThenName
 518         ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
 519
 520
 521 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
 522   = do  { elt_ty <- boxySplitListTy res_ty
 523         ; expr1' <- tcPolyExpr expr1 elt_ty
 524         ; expr2' <- tcPolyExpr expr2 elt_ty
 525         ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
 526                               elt_ty enumFromToName
 527         ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
 528
 529 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 530   = do  { elt_ty <- boxySplitListTy res_ty
 531         ; expr1' <- tcPolyExpr expr1 elt_ty
 532         ; expr2' <- tcPolyExpr expr2 elt_ty
 533         ; expr3' <- tcPolyExpr expr3 elt_ty
 534         ; eft <- newMethodFromName (ArithSeqOrigin seq)
 535                       elt_ty enumFromThenToName
 536         ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
 537
 538 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
 539   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 540         ; expr1' <- tcPolyExpr expr1 elt_ty
 541         ; expr2' <- tcPolyExpr expr2 elt_ty
 542         ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
 543                                       elt_ty enumFromToPName
 544         ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
 545
 546 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 547   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 548         ; expr1' <- tcPolyExpr expr1 elt_ty
 549         ; expr2' <- tcPolyExpr expr2 elt_ty
 550         ; expr3' <- tcPolyExpr expr3 elt_ty
 551         ; eft <- newMethodFromName (PArrSeqOrigin seq)
 552                       elt_ty enumFromThenToPName
 553         ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
 554
 555 tcExpr (PArrSeq _ _) _
 556   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 557     -- the parser shouldn't have generated it and the renamer shouldn't have
 558     -- let it through
 559 \end{code}
 560
 561
 562 %************************************************************************
 563 %*                                                                      *
 564                 Template Haskell
 565 %*                                                                      *
 566 %************************************************************************
 567
 568 \begin{code}
 569 #ifdef GHCI     /* Only if bootstrapped */
 570         -- Rename excludes these cases otherwise
 571 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 572 tcExpr (HsBracket brack)  res_ty = do   { e <- tcBracket brack res_ty
 573                                         ; return (unLoc e) }
 574 #endif /* GHCI */
 575 \end{code}
 576
 577
 578 %************************************************************************
 579 %*                                                                      *
 580                 Catch-all
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 \begin{code}
 585 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 586 \end{code}
 587
 588
 589 %************************************************************************
 590 %*                                                                      *
 591                 Applications
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 \begin{code}
 596 ---------------------------
 597 tcApp :: HsExpr Name                            -- Function
 598       -> Arity                                  -- Number of args reqd
 599       -> ArgChecker results
 600       -> BoxyRhoType                            -- Result type
 601       -> TcM (HsExpr TcId, results)
 602
 603 -- (tcFun fun n_args arg_checker res_ty)
 604 -- The argument type checker, arg_checker, will be passed exactly n_args types
 605
 606 tcApp (HsVar fun_name) n_args arg_checker res_ty
 607   = tcIdApp fun_name n_args arg_checker res_ty
 608
 609 tcApp fun n_args arg_checker res_ty     -- The vanilla case (rula APP)
 610   = do  { arg_boxes  <- newBoxyTyVars (replicate n_args argTypeKind)
 611         ; fun'       <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
 612         ; arg_tys'   <- mapM readFilledBox arg_boxes
 613         ; (_, args') <- arg_checker [] [] arg_tys'      -- Yuk
 614         ; return (fun', args') }
 615
 616 ---------------------------
 617 tcIdApp :: Name                                 -- Function
 618         -> Arity                                -- Number of args reqd
 619         -> ArgChecker results   -- The arg-checker guarantees to fill all boxes in the arg types
 620         -> BoxyRhoType                          -- Result type
 621         -> TcM (HsExpr TcId, results)
 622
 623 -- Call         (f e1 ... en) :: res_ty
 624 -- Type         f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
 625 --                      (where k <= n; fres has the rest)
 626 -- NB:  if k < n then the function doesn't have enough args, and
 627 --      presumably fres is a type variable that we are going to
 628 --      instantiate with a function type
 629 --
 630 -- Then         fres <= bx_(k+1) -> ... -> bx_n -> res_ty
 631
 632 tcIdApp fun_name n_args arg_checker res_ty
 633   = do  { let orig = OccurrenceOf fun_name
 634         ; (fun, fun_ty) <- lookupFun orig fun_name
 635
 636         -- Split up the function type
 637         ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
 638               (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
 639
 640               qtvs = concatMap fst tv_theta_prs         -- Quantified tyvars
 641               arg_qtvs = exactTyVarsOfTypes fun_arg_tys
 642               res_qtvs = exactTyVarsOfType fun_res_ty
 643                 -- NB: exactTyVarsOfType.  See Note [Silly type synonyms in smart-app]
 644               tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
 645               k              = length fun_arg_tys       -- k <= n_args
 646               n_missing_args = n_args - k               -- Always >= 0
 647
 648         -- Match the result type of the function with the
 649         -- result type of the context, to get an inital substitution
 650         ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
 651         ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
 652               res_ty'        = mkFunTys extra_arg_tys' res_ty
 653         ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
 654
 655         -- Typecheck the arguments!
 656         -- Doing so will fill arg_qtvs and extra_arg_tys'
 657         ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
 658
 659         -- Strip boxes from the qtvs that have been filled in by the arg checking
 660         ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
 661
 662         -- Result subsumption
 663         -- This fills in res_qtvs
 664         ; let res_subst = zipOpenTvSubst qtvs qtys''
 665               fun_res_ty'' = substTy res_subst fun_res_ty
 666               res_ty'' = mkFunTys extra_arg_tys'' res_ty
 667         ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty''
 668
 669         -- And pack up the results
 670         -- By applying the coercion just to the *function* we can make
 671         -- tcFun work nicely for OpApp and Sections too
 672         ; fun' <- instFun orig fun res_subst tv_theta_prs
 673         ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
 674         ; return (mkHsWrap co_fn' fun', args') }
 675 \end{code}
 676
 677 Note [Silly type synonyms in smart-app]
 678 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 679 When we call sripBoxyType, all of the boxes should be filled
 680 in.  But we need to be careful about type synonyms:
 681         type T a = Int
 682         f :: T a -> Int
 683         ...(f x)...
 684 In the call (f x) we'll typecheck x, expecting it to have type
 685 (T box).  Usually that would fill in the box, but in this case not;
 686 because 'a' is discarded by the silly type synonym T.  So we must
 687 use exactTyVarsOfType to figure out which type variables are free
 688 in the argument type.
 689
 690 \begin{code}
 691 -- tcId is a specialisation of tcIdApp when there are no arguments
 692 -- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
 693 --                ; return res }
 694
 695 tcId :: InstOrigin
 696      -> Name                                    -- Function
 697      -> BoxyRhoType                             -- Result type
 698      -> TcM (HsExpr TcId)
 699 tcId orig fun_name res_ty
 700   = do  { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
 701         ; (fun, fun_ty) <- lookupFun orig fun_name
 702
 703         -- Split up the function type
 704         ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
 705               qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
 706               tau_qtvs = exactTyVarsOfType fun_tau      -- Mentioned in the tau part
 707         ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
 708
 709         -- Do the subsumption check wrt the result type
 710         ; let res_subst = zipTopTvSubst qtvs qtv_tys
 711               fun_tau'  = substTy res_subst fun_tau
 712
 713         ; co_fn <- tcFunResTy fun_name fun_tau' res_ty
 714
 715         -- And pack up the results
 716         ; fun' <- instFun orig fun res_subst tv_theta_prs
 717         ; return (mkHsWrap co_fn fun') }
 718
 719 --      Note [Push result type in]
 720 --
 721 -- Unify with expected result before (was: after) type-checking the args
 722 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
 723 -- This is when we might detect a too-few args situation.
 724 -- (One can think of cases when the opposite order would give
 725 -- a better error message.)
 726 -- [March 2003: I'm experimenting with putting this first.  Here's an
 727 --              example where it actually makes a real difference
 728 --    class C t a b | t a -> b
 729 --    instance C Char a Bool
 730 --
 731 --    data P t a = forall b. (C t a b) => MkP b
 732 --    data Q t   = MkQ (forall a. P t a)
 733
 734 --    f1, f2 :: Q Char;
 735 --    f1 = MkQ (MkP True)
 736 --    f2 = MkQ (MkP True :: forall a. P Char a)
 737 --
 738 -- With the change, f1 will type-check, because the 'Char' info from
 739 -- the signature is propagated into MkQ's argument. With the check
 740 -- in the other order, the extra signature in f2 is reqd.]
 741
 742 ---------------------------
 743 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 744 -- Typecheck a syntax operator, checking that it has the specified type
 745 -- The operator is always a variable at this stage (i.e. renamer output)
 746 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
 747 tcSyntaxOp orig other      ty = pprPanic "tcSyntaxOp" (ppr other)
 748
 749 ---------------------------
 750 instFun :: InstOrigin
 751         -> HsExpr TcId
 752         -> TvSubst                -- The instantiating substitution
 753         -> [([TyVar], ThetaType)] -- Stuff to instantiate
 754         -> TcM (HsExpr TcId)
 755
 756 instFun orig fun subst []
 757   = return fun          -- Common short cut
 758
 759 instFun orig fun subst tv_theta_prs
 760   = do  { let ty_theta_prs' = map subst_pr tv_theta_prs
 761
 762                 -- Make two ad-hoc checks
 763         ; doStupidChecks fun ty_theta_prs'
 764
 765                 -- Now do normal instantiation
 766         ; go True fun ty_theta_prs' }
 767   where
 768     subst_pr (tvs, theta)
 769         = (substTyVars subst tvs, substTheta subst theta)
 770
 771     go _ fun [] = return fun
 772
 773     go True (HsVar fun_id) ((tys,theta) : prs)
 774         | want_method_inst theta
 775         = do { meth_id <- newMethodWithGivenTy orig fun_id tys
 776              ; go False (HsVar meth_id) prs }
 777                 -- Go round with 'False' to prevent further use
 778                 -- of newMethod: see Note [Multiple instantiation]
 779
 780     go _ fun ((tys, theta) : prs)
 781         = do { co_fn <- instCall orig tys theta
 782              ; go False (HsWrap co_fn fun) prs }
 783
 784         -- See Note [No method sharing]
 785     want_method_inst theta =  not (null theta)  -- Overloaded
 786                            && not opt_NoMethodSharing
 787 \end{code}
 788
 789 Note [Multiple instantiation]
 790 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 791 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
 792 For example, consider
 793         f :: forall a. Eq a => forall b. Ord b => a -> b
 794 At a call to f, at say [Int, Bool], it's tempting to translate the call to
 795
 796         f_m1
 797   where
 798         f_m1 :: forall b. Ord b => Int -> b
 799         f_m1 = f Int dEqInt
 800
 801         f_m2 :: Int -> Bool
 802         f_m2 = f_m1 Bool dOrdBool
 803
 804 But notice that f_m2 has f_m1 as its meth_id.  Now the danger is that if we do
 805 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
 806         f_m1 = f_mx
 807 But it's entirely possible that f_m2 will continue to float out, because it
 808 mentions no type variables.  Result, f_m1 isn't in scope.
 809
 810 Here's a concrete example that does this (test tc200):
 811
 812     class C a where
 813       f :: Eq b => b -> a -> Int
 814       baz :: Eq a => Int -> a -> Int
 815
 816     instance C Int where
 817       baz = f
 818
 819 Current solution: only do the "method sharing" thing for the first type/dict
 820 application, not for the iterated ones.  A horribly subtle point.
 821
 822 Note [No method sharing]
 823 ~~~~~~~~~~~~~~~~~~~~~~~~
 824 The -fno-method-sharing flag controls what happens so far as the LIE
 825 is concerned.  The default case is that for an overloaded function we
 826 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 827 something like
 828         f :: Num a => a -> a
 829         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 830 If you specify -fno-method-sharing, the dictionary application
 831 isn't shared, so we get
 832         f :: Num a => a -> a
 833         f = /\a (d:Num a) (x:a) -> (+) a d x x
 834 This gets a bit less sharing, but
 835         a) it's better for RULEs involving overloaded functions
 836         b) perhaps fewer separated lambdas
 837
 838 Note [Left to right]
 839 ~~~~~~~~~~~~~~~~~~~~
 840 tcArgs implements a left-to-right order, which goes beyond what is described in the
 841 impredicative type inference paper.  In particular, it allows
 842         runST $ foo
 843 where runST :: (forall s. ST s a) -> a
 844 When typechecking the application of ($)::(a->b) -> a -> b, we first check that
 845 runST has type (a->b), thereby filling in a=forall s. ST s a.  Then we un-box this type
 846 before checking foo.  The left-to-right order really helps here.
 847
 848 \begin{code}
 849 tcArgs :: LHsExpr Name                          -- The function (for error messages)
 850        -> [LHsExpr Name]                        -- Actual args
 851        -> ArgChecker [LHsExpr TcId]
 852
 853 type ArgChecker results
 854    = [TyVar] -> [TcSigmaType]           -- Current instantiation
 855    -> [TcSigmaType]                     -- Expected arg types (**before** applying the instantiation)
 856    -> TcM ([TcSigmaType], results)      -- Resulting instaniation and args
 857
 858 tcArgs fun args qtvs qtys arg_tys
 859   = go 1 qtys args arg_tys
 860   where
 861     go n qtys [] [] = return (qtys, [])
 862     go n qtys (arg:args) (arg_ty:arg_tys)
 863         = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
 864              ; qtys' <- mapM refineBox qtys     -- Exploit new info
 865              ; (qtys'', args') <- go (n+1) qtys' args arg_tys
 866              ; return (qtys'', arg':args') }
 867     go n qtys args arg_tys = panic "tcArgs"
 868
 869 tcArg :: LHsExpr Name                           -- The function
 870       -> Int                                    --   and arg number (for error messages)
 871       -> LHsExpr Name
 872       -> [TyVar] -> [TcSigmaType]               -- Instantiate the arg type like this
 873       -> BoxySigmaType
 874       -> TcM (LHsExpr TcId)                     -- Resulting argument
 875 tcArg fun arg_no arg qtvs qtys ty
 876   = addErrCtxt (funAppCtxt fun arg arg_no) $
 877     tcPolyExprNC arg (substTyWith qtvs qtys ty)
 878 \end{code}
 879
 880
 881 Note [tagToEnum#]
 882 ~~~~~~~~~~~~~~~~~
 883 Nasty check to ensure that tagToEnum# is applied to a type that is an
 884 enumeration TyCon.  Unification may refine the type later, but this
 885 check won't see that, alas.  It's crude but it works.
 886
 887 Here's are two cases that should fail
 888         f :: forall a. a
 889         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
 890
 891         g :: Int
 892         g = tagToEnum# 0        -- Int is not an enumeration
 893
 894
 895 \begin{code}
 896 doStupidChecks :: HsExpr TcId
 897                -> [([TcType], ThetaType)]
 898                -> TcM ()
 899 -- Check two tiresome and ad-hoc cases
 900 -- (a) the "stupid theta" for a data con; add the constraints
 901 --     from the "stupid theta" of a data constructor (sigh)
 902 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
 903
 904 doStupidChecks (HsVar fun_id) ((tys,_):_)
 905   | Just con <- isDataConId_maybe fun_id   -- (a)
 906   = addDataConStupidTheta con tys
 907
 908   | fun_id `hasKey` tagToEnumKey           -- (b)
 909   = do  { tys' <- zonkTcTypes tys
 910         ; checkTc (ok tys') (tagToEnumError tys')
 911         }
 912   where
 913     ok []       = False
 914     ok (ty:tys) = case tcSplitTyConApp_maybe ty of
 915                         Just (tc,_) -> isEnumerationTyCon tc
 916                         Nothing     -> False
 917
 918 doStupidChecks fun tv_theta_prs
 919   = return () -- The common case
 920
 921
 922 tagToEnumError tys
 923   = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
 924          2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
 925                   ptext SLIT("e.g. (tagToEnum# x) :: Bool")])
 926   where
 927     at_type | null tys = empty  -- Probably never happens
 928             | otherwise = ptext SLIT("at type") <+> ppr (head tys)
 929 \end{code}
 930
 931 %************************************************************************
 932 %*                                                                      *
 933 \subsection{@tcId@ typechecks an identifier occurrence}
 934 %*                                                                      *
 935 %************************************************************************
 936
 937 \begin{code}
 938 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
 939 lookupFun orig id_name
 940   = do  { thing <- tcLookup id_name
 941         ; case thing of
 942             AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
 943                                    where
 944                                       wrap_id = dataConWrapId con
 945
 946             AGlobal (AnId id)
 947                 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
 948                 | otherwise                  -> return (HsVar id, idType id)
 949                 -- A global cannot possibly be ill-staged
 950                 -- nor does it need the 'lifting' treatment
 951
 952             ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
 953                 -> do { thLocalId orig id ty lvl
 954                       ; case mb_co of
 955                           Nothing -> return (HsVar id, ty)      -- Wobbly, or no free vars
 956                           Just co -> return (mkHsWrap co (HsVar id), ty) }
 957
 958             other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
 959     }
 960
 961 #ifndef GHCI  /* GHCI and TH is off */
 962 --------------------------------------
 963 -- thLocalId : Check for cross-stage lifting
 964 thLocalId orig id id_ty th_bind_lvl
 965   = return ()
 966
 967 #else         /* GHCI and TH is on */
 968 thLocalId orig id id_ty th_bind_lvl
 969   = do  { use_stage <- getStage -- TH case
 970         ; case use_stage of
 971             Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
 972                   -> thBrackId orig id ps_var lie_var
 973             other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
 974                         ; return id }
 975         }
 976
 977 --------------------------------------
 978 thBrackId orig id ps_var lie_var
 979   | isExternalName id_name
 980   =     -- Top-level identifiers in this module,
 981         -- (which have External Names)
 982         -- are just like the imported case:
 983         -- no need for the 'lifting' treatment
 984         -- E.g.  this is fine:
 985         --   f x = x
 986         --   g y = [| f 3 |]
 987         -- But we do need to put f into the keep-alive
 988         -- set, because after desugaring the code will
 989         -- only mention f's *name*, not f itself.
 990     do  { keepAliveTc id_name; return id }
 991
 992   | otherwise
 993   =     -- Nested identifiers, such as 'x' in
 994         -- E.g. \x -> [| h x |]
 995         -- We must behave as if the reference to x was
 996         --      h $(lift x)
 997         -- We use 'x' itself as the splice proxy, used by
 998         -- the desugarer to stitch it all back together.
 999         -- If 'x' occurs many times we may get many identical
1000         -- bindings of the same splice proxy, but that doesn't
1001         -- matter, although it's a mite untidy.
1002     do  { let id_ty = idType id
1003         ; checkTc (isTauTy id_ty) (polySpliceErr id)
1004                -- If x is polymorphic, its occurrence sites might
1005                -- have different instantiations, so we can't use plain
1006                -- 'x' as the splice proxy name.  I don't know how to
1007                -- solve this, and it's probably unimportant, so I'm
1008                -- just going to flag an error for now
1009
1010         ; id_ty' <- zapToMonotype id_ty
1011                 -- The id_ty might have an OpenTypeKind, but we
1012                 -- can't instantiate the Lift class at that kind,
1013                 -- so we zap it to a LiftedTypeKind monotype
1014                 -- C.f. the call in TcPat.newLitInst
1015
1016         ; setLIEVar lie_var     $ do
1017         { lift <- newMethodFromName orig id_ty' DsMeta.liftName
1018                    -- Put the 'lift' constraint into the right LIE
1019
1020                    -- Update the pending splices
1021         ; ps <- readMutVar ps_var
1022         ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
1023
1024         ; return id } }
1025  where
1026    id_name = idName id
1027 #endif /* GHCI */
1028 \end{code}
1029
1030
1031 %************************************************************************
1032 %*                                                                      *
1033 \subsection{Record bindings}
1034 %*                                                                      *
1035 %************************************************************************
1036
1037 Game plan for record bindings
1038 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1039 1. Find the TyCon for the bindings, from the first field label.
1040
1041 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1042
1043 For each binding field = value
1044
1045 3. Instantiate the field type (from the field label) using the type
1046    envt from step 2.
1047
1048 4  Type check the value using tcArg, passing the field type as
1049    the expected argument type.
1050
1051 This extends OK when the field types are universally quantified.
1052
1053
1054 \begin{code}
1055 tcRecordBinds
1056         :: DataCon
1057         -> [TcType]     -- Expected type for each field
1058         -> HsRecordBinds Name
1059         -> TcM (HsRecordBinds TcId)
1060
1061 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1062   = do  { mb_binds <- mappM do_bind rbinds
1063         ; return (HsRecFields (catMaybes mb_binds) dd) }
1064   where
1065     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1066     do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1067       | Just field_ty <- assocMaybe flds_w_tys field_lbl
1068       = addErrCtxt (fieldCtxt field_lbl)        $
1069         do { rhs'   <- tcPolyExprNC rhs field_ty
1070            ; sel_id <- tcLookupField field_lbl
1071            ; ASSERT( isRecordSelector sel_id )
1072              return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) }
1073       | otherwise
1074       = do { addErrTc (badFieldCon data_con field_lbl)
1075            ; return Nothing }
1076
1077 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1078 checkMissingFields data_con rbinds
1079   | null field_labels   -- Not declared as a record;
1080                         -- But C{} is still valid if no strict fields
1081   = if any isMarkedStrict field_strs then
1082         -- Illegal if any arg is strict
1083         addErrTc (missingStrictFields data_con [])
1084     else
1085         returnM ()
1086
1087   | otherwise           -- A record
1088   = checkM (null missing_s_fields)
1089            (addErrTc (missingStrictFields data_con missing_s_fields))   `thenM_`
1090
1091     doptM Opt_WarnMissingFields         `thenM` \ warn ->
1092     checkM (not (warn && notNull missing_ns_fields))
1093            (warnTc True (missingFields data_con missing_ns_fields))
1094
1095   where
1096     missing_s_fields
1097         = [ fl | (fl, str) <- field_info,
1098                  isMarkedStrict str,
1099                  not (fl `elem` field_names_used)
1100           ]
1101     missing_ns_fields
1102         = [ fl | (fl, str) <- field_info,
1103                  not (isMarkedStrict str),
1104                  not (fl `elem` field_names_used)
1105           ]
1106
1107     field_names_used = hsRecFields rbinds
1108     field_labels     = dataConFieldLabels data_con
1109
1110     field_info = zipEqual "missingFields"
1111                           field_labels
1112                           field_strs
1113
1114     field_strs = dataConStrictMarks data_con
1115 \end{code}
1116
1117 %************************************************************************
1118 %*                                                                      *
1119 \subsection{Errors and contexts}
1120 %*                                                                      *
1121 %************************************************************************
1122
1123 Boring and alphabetical:
1124 \begin{code}
1125 caseScrutCtxt expr
1126   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1127
1128 exprCtxt expr
1129   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
1130
1131 fieldCtxt field_name
1132   = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
1133
1134 funAppCtxt fun arg arg_no
1135   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1136                     quotes (ppr fun) <> text ", namely"])
1137          4 (quotes (ppr arg))
1138
1139 predCtxt expr
1140   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1141
1142 nonVanillaUpd tycon
1143   = vcat [ptext SLIT("Record update for the non-Haskell-98 data type")
1144                 <+> quotes (pprSourceTyCon tycon)
1145                 <+> ptext SLIT("is not (yet) supported"),
1146           ptext SLIT("Use pattern-matching instead")]
1147 badFieldsUpd rbinds
1148   = hang (ptext SLIT("No constructor has all these fields:"))
1149          4 (pprQuotedList (hsRecFields rbinds))
1150
1151 naughtyRecordSel sel_id
1152   = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
1153     ptext SLIT("as a function due to escaped type variables") $$
1154     ptext SLIT("Probably fix: use pattern-matching syntax instead")
1155
1156 notSelector field
1157   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1158
1159 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1160 missingStrictFields con fields
1161   = header <> rest
1162   where
1163     rest | null fields = empty  -- Happens for non-record constructors
1164                                 -- with strict fields
1165          | otherwise   = colon <+> pprWithCommas ppr fields
1166
1167     header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
1168              ptext SLIT("does not have the required strict field(s)")
1169
1170 missingFields :: DataCon -> [FieldLabel] -> SDoc
1171 missingFields con fields
1172   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
1173         <+> pprWithCommas ppr fields
1174
1175 -- callCtxt fun args = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
1176
1177 #ifdef GHCI
1178 polySpliceErr :: Id -> SDoc
1179 polySpliceErr id
1180   = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
1181 #endif
1182 \end{code}