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