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