ghc/compiler/typecheck/TcExpr.lhs

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