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 ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 #ifdef GHCI     /* Only if bootstrapped */
  12 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcBracket )
  13 import Id               ( Id )
  14 import TcType           ( isTauTy )
  15 import TcEnv            ( checkWellStaged )
  16 import HsSyn            ( nlHsApp )
  17 import qualified DsMeta
  18 #endif
  19
  20 import HsSyn            ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields,
  21                           HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar )
  22 import TcHsSyn          ( hsLitType, mkHsDictApp, mkHsTyApp, (<$>) )
  23 import TcRnMonad
  24 import TcUnify          ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
  25                           unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy )
  26 import BasicTypes       ( isMarkedStrict )
  27 import Inst             ( InstOrigin(..),
  28                           newOverloadedLit, newMethodFromName, newIPDict,
  29                           newDicts, newMethodWithGivenTy,
  30                           instToId, tcInstCall, tcInstDataCon
  31                         )
  32 import TcBinds          ( tcBindsAndThen )
  33 import TcEnv            ( tcLookup, tcLookupId, checkProcLevel,
  34                           tcLookupDataCon, tcLookupGlobalId
  35                         )
  36 import TcArrows         ( tcProc )
  37 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
  38 import TcHsType         ( tcHsSigType, UserTypeCtxt(..) )
  39 import TcPat            ( badFieldCon )
  40 import TcMType          ( tcInstTyVars, tcInstType, newTyVarTy, zonkTcType )
  41 import TcType           ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
  42                           tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
  43                           isSigmaTy, mkFunTy, mkFunTys,
  44                           mkTyConApp, tyVarsOfTypes, isLinearPred,
  45                           tcSplitSigmaTy, tidyOpenType
  46                         )
  47 import Kind             ( openTypeKind, liftedTypeKind, argTypeKind )
  48
  49 import FieldLabel       ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
  50 import Id               ( idType, recordSelectorFieldLabel, isRecordSelector )
  51 import DataCon          ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
  52 import Name             ( Name )
  53 import TyCon            ( TyCon, tyConTyVars, tyConTheta, tyConDataCons )
  54 import Subst            ( mkTopTyVarSubst, substTheta, substTy )
  55 import VarSet           ( emptyVarSet, elemVarSet )
  56 import TysWiredIn       ( boolTy )
  57 import PrelNames        ( enumFromName, enumFromThenName,
  58                           enumFromToName, enumFromThenToName,
  59                           enumFromToPName, enumFromThenToPName
  60                         )
  61 import ListSetOps       ( minusList )
  62 import CmdLineOpts
  63 import HscTypes         ( TyThing(..) )
  64 import SrcLoc           ( Located(..), unLoc, getLoc )
  65 import Util
  66 import Outputable
  67 import FastString
  68
  69 #ifdef DEBUG
  70 import TyCon            ( isAlgTyCon )
  71 #endif
  72 \end{code}
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection{Main wrappers}
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 \begin{code}
  81 -- tcCheckSigma does type *checking*; it's passed the expected type of the result
  82 tcCheckSigma :: LHsExpr Name            -- Expession to type check
  83              -> TcSigmaType             -- Expected type (could be a polytpye)
  84              -> TcM (LHsExpr TcId)      -- Generalised expr with expected type
  85
  86 tcCheckSigma expr expected_ty
  87   = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_`
  88     tc_expr' expr expected_ty
  89
  90 tc_expr' expr sigma_ty
  91   | isSigmaTy sigma_ty
  92   = tcGen sigma_ty emptyVarSet (
  93         \ rho_ty -> tcCheckRho expr rho_ty
  94     )                           `thenM` \ (gen_fn, expr') ->
  95     returnM (L (getLoc expr') (gen_fn <$> unLoc expr'))
  96
  97 tc_expr' expr rho_ty    -- Monomorphic case
  98   = tcCheckRho expr rho_ty
  99 \end{code}
 100
 101 Typecheck expression which in most cases will be an Id.
 102 The expression can return a higher-ranked type, such as
 103         (forall a. a->a) -> Int
 104 so we must create a hole to pass in as the expected tyvar.
 105
 106 \begin{code}
 107 tcCheckRho :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
 108 tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty)
 109
 110 tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 111 tcInferRho (L loc (HsVar name)) = addSrcSpan loc $
 112                                   do { (e,ty) <- tcId name; return (L loc e, ty)}
 113 tcInferRho expr                 = newHole                       `thenM` \ hole ->
 114                                   tcMonoExpr expr (Infer hole)  `thenM` \ expr' ->
 115                                   readMutVar hole               `thenM` \ rho_ty ->
 116                                   returnM (expr', rho_ty)
 117 \end{code}
 118
 119
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsection{The TAUT rules for variables}TcExpr
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 \begin{code}
 128 tcMonoExpr :: LHsExpr Name              -- Expession to type check
 129            -> Expected TcRhoType        -- Expected type (could be a type variable)
 130                                         -- Definitely no foralls at the top
 131                                         -- Can be a 'hole'.
 132            -> TcM (LHsExpr TcId)
 133
 134 tcMonoExpr (L loc expr) res_ty
 135   = addSrcSpan loc (do { expr' <- tc_expr expr res_ty
 136                        ; return (L loc expr') })
 137
 138 tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId)
 139 tc_expr (HsVar name) res_ty
 140   = tcId name                   `thenM` \ (expr', id_ty) ->
 141     tcSubExp res_ty id_ty       `thenM` \ co_fn ->
 142     returnM (co_fn <$> expr')
 143
 144 tc_expr (HsIPVar ip) res_ty
 145   =     -- Implicit parameters must have a *tau-type* not a
 146         -- type scheme.  We enforce this by creating a fresh
 147         -- type variable as its type.  (Because res_ty may not
 148         -- be a tau-type.)
 149     newTyVarTy argTypeKind              `thenM` \ ip_ty ->
 150         -- argTypeKind: it can't be an unboxed tuple
 151     newIPDict (IPOccOrigin ip) ip ip_ty `thenM` \ (ip', inst) ->
 152     extendLIE inst                      `thenM_`
 153     tcSubExp res_ty ip_ty               `thenM` \ co_fn ->
 154     returnM (co_fn <$> HsIPVar ip')
 155 \end{code}
 156
 157
 158 %************************************************************************
 159 %*                                                                      *
 160 \subsection{Expressions type signatures}
 161 %*                                                                      *
 162 %************************************************************************
 163
 164 \begin{code}
 165 tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty
 166  = addErrCtxt (exprCtxt in_expr)                        $
 167    tcHsSigType ExprSigCtxt poly_ty                      `thenM` \ sig_tc_ty ->
 168    tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty    `thenM` \ (co_fn, expr') ->
 169    returnM (co_fn <$> unLoc expr')
 170         -- ToDo: nasty unLoc
 171
 172 tc_expr (HsType ty) res_ty
 173   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 174         -- This is the syntax for type applications that I was planning
 175         -- but there are difficulties (e.g. what order for type args)
 176         -- so it's not enabled yet.
 177         -- Can't eliminate it altogether from the parser, because the
 178         -- same parser parses *patterns*.
 179 \end{code}
 180
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsection{Other expression forms}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 \begin{code}
 189 tc_expr (HsPar expr)    res_ty  = tcMonoExpr expr res_ty        `thenM` \ expr' ->
 190                                   returnM (HsPar expr')
 191 tc_expr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty        `thenM` \ expr' ->
 192                                   returnM (HsSCC lbl expr')
 193 tc_expr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->  -- hdaume: core annotation
 194                                          returnM (HsCoreAnn lbl expr')
 195
 196 tc_expr (HsLit lit) res_ty  = tcLit lit res_ty
 197
 198 tc_expr (HsOverLit lit) res_ty
 199   = zapExpectedType res_ty liftedTypeKind               `thenM` \ res_ty' ->
 200     newOverloadedLit (LiteralOrigin lit) lit res_ty'    `thenM` \ lit_expr ->
 201     returnM (unLoc lit_expr)    -- ToDo: nasty unLoc
 202
 203 tc_expr (NegApp expr neg_name) res_ty
 204   = tc_expr (HsApp (nlHsVar neg_name) expr) res_ty
 205         -- ToDo: use tcSyntaxName
 206
 207 tc_expr (HsLam match) res_ty
 208   = tcMatchLambda match res_ty          `thenM` \ match' ->
 209     returnM (HsLam match')
 210
 211 tc_expr (HsApp e1 e2) res_ty
 212   = tcApp e1 [e2] res_ty
 213 \end{code}
 214
 215 Note that the operators in sections are expected to be binary, and
 216 a type error will occur if they aren't.
 217
 218 \begin{code}
 219 -- Left sections, equivalent to
 220 --      \ x -> e op x,
 221 -- or
 222 --      \ x -> op e x,
 223 -- or just
 224 --      op e
 225
 226 tc_expr in_expr@(SectionL arg1 op) res_ty
 227   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 228     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 229     tcArg op (arg1, arg1_ty, 1)                 `thenM` \ arg1' ->
 230     addErrCtxt (exprCtxt in_expr)               $
 231     tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn ->
 232     returnM (co_fn <$> SectionL arg1' op')
 233
 234 -- Right sections, equivalent to \ x -> x op expr, or
 235 --      \ x -> op x expr
 236
 237 tc_expr in_expr@(SectionR op arg2) res_ty
 238   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 239     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 240     tcArg op (arg2, arg2_ty, 2)                 `thenM` \ arg2' ->
 241     addErrCtxt (exprCtxt in_expr)               $
 242     tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn ->
 243     returnM (co_fn <$> SectionR op' arg2')
 244
 245 -- equivalent to (op e1) e2:
 246
 247 tc_expr in_expr@(OpApp arg1 op fix arg2) res_ty
 248   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 249     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 250     tcArg op (arg1, arg1_ty, 1)                 `thenM` \ arg1' ->
 251     tcArg op (arg2, arg2_ty, 2)                 `thenM` \ arg2' ->
 252     addErrCtxt (exprCtxt in_expr)               $
 253     tcSubExp res_ty op_res_ty                   `thenM` \ co_fn ->
 254     returnM (OpApp arg1' op' fix arg2')
 255 \end{code}
 256
 257 \begin{code}
 258 tc_expr (HsLet binds (L loc expr)) res_ty
 259   = tcBindsAndThen
 260         glue
 261         binds                   -- Bindings to check
 262         (tc_expr expr res_ty)
 263   where
 264     glue bind expr = HsLet [bind] (L loc expr)
 265
 266 tc_expr in_expr@(HsCase scrut matches) res_ty
 267   = addErrCtxt (caseCtxt in_expr)       $
 268
 269         -- Typecheck the case alternatives first.
 270         -- The case patterns tend to give good type info to use
 271         -- when typechecking the scrutinee.  For example
 272         --      case (map f) of
 273         --        (x:xs) -> ...
 274         -- will report that map is applied to too few arguments
 275
 276     tcMatchesCase match_ctxt matches res_ty     `thenM`    \ (scrut_ty, matches') ->
 277
 278     addErrCtxt (caseScrutCtxt scrut)    (
 279       tcCheckRho scrut scrut_ty
 280     )                                   `thenM`    \ scrut' ->
 281
 282     returnM (HsCase scrut' matches')
 283   where
 284     match_ctxt = MC { mc_what = CaseAlt,
 285                       mc_body = tcMonoExpr }
 286
 287 tc_expr (HsIf pred b1 b2) res_ty
 288   = addErrCtxt (predCtxt pred) (
 289     tcCheckRho pred boolTy      )       `thenM`    \ pred' ->
 290
 291     zapExpectedType res_ty openTypeKind `thenM`    \ res_ty' ->
 292         -- C.f. the call to zapToType in TcMatches.tcMatches
 293
 294     tcCheckRho b1 res_ty'               `thenM`    \ b1' ->
 295     tcCheckRho b2 res_ty'               `thenM`    \ b2' ->
 296     returnM (HsIf pred' b1' b2')
 297
 298 tc_expr (HsDo do_or_lc stmts method_names _) res_ty
 299   = zapExpectedType res_ty liftedTypeKind               `thenM` \ res_ty' ->
 300         -- All comprehensions yield a monotype of kind *
 301     tcDoStmts do_or_lc stmts method_names res_ty'       `thenM` \ (stmts', methods') ->
 302     returnM (HsDo do_or_lc stmts' methods' res_ty')
 303
 304 tc_expr in_expr@(ExplicitList _ exprs) res_ty   -- Non-empty list
 305   = zapToListTy res_ty                `thenM` \ elt_ty ->
 306     mappM (tc_elt elt_ty) exprs       `thenM` \ exprs' ->
 307     returnM (ExplicitList elt_ty exprs')
 308   where
 309     tc_elt elt_ty expr
 310       = addErrCtxt (listCtxt expr) $
 311         tcCheckRho expr elt_ty
 312
 313 tc_expr in_expr@(ExplicitPArr _ exprs) res_ty   -- maybe empty
 314   = zapToPArrTy res_ty                `thenM` \ elt_ty ->
 315     mappM (tc_elt elt_ty) exprs       `thenM` \ exprs' ->
 316     returnM (ExplicitPArr elt_ty exprs')
 317   where
 318     tc_elt elt_ty expr
 319       = addErrCtxt (parrCtxt expr) $
 320         tcCheckRho expr elt_ty
 321
 322 tc_expr (ExplicitTuple exprs boxity) res_ty
 323   = zapToTupleTy boxity (length exprs) res_ty   `thenM` \ arg_tys ->
 324     tcCheckRhos exprs arg_tys                   `thenM` \ exprs' ->
 325     returnM (ExplicitTuple exprs' boxity)
 326
 327 tc_expr (HsProc pat cmd) res_ty
 328   = tcProc pat cmd res_ty                       `thenM` \ (pat', cmd') ->
 329     returnM (HsProc pat' cmd')
 330
 331 tc_expr e@(HsArrApp _ _ _ _ _) _
 332   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 333                       ptext SLIT("was found where an expression was expected")])
 334
 335 tc_expr e@(HsArrForm _ _ _) _
 336   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 337                       ptext SLIT("was found where an expression was expected")])
 338 \end{code}
 339
 340 %************************************************************************
 341 %*                                                                      *
 342                 Record construction and update
 343 %*                                                                      *
 344 %************************************************************************
 345
 346 \begin{code}
 347 tc_expr expr@(RecordCon con@(L _ con_name) rbinds) res_ty
 348   = addErrCtxt (recordConCtxt expr)             $
 349     addLocM tcId con                    `thenM` \ (con_expr, con_tau) ->
 350     let
 351         (_, record_ty)   = tcSplitFunTys con_tau
 352         (tycon, ty_args) = tcSplitTyConApp record_ty
 353     in
 354     ASSERT( isAlgTyCon tycon )
 355     zapExpectedTo res_ty record_ty      `thenM_`
 356
 357         -- Check that the record bindings match the constructor
 358         -- con_name is syntactically constrained to be a data constructor
 359     tcLookupDataCon con_name            `thenM` \ data_con ->
 360     let
 361         bad_fields = badFields rbinds data_con
 362     in
 363     if notNull bad_fields then
 364         mappM (addErrTc . badFieldCon data_con) bad_fields      `thenM_`
 365         failM   -- Fail now, because tcRecordBinds will crash on a bad field
 366     else
 367
 368         -- Typecheck the record bindings
 369     tcRecordBinds tycon ty_args rbinds          `thenM` \ rbinds' ->
 370
 371         -- Check for missing fields
 372     checkMissingFields data_con rbinds          `thenM_`
 373
 374     getSrcSpanM                                 `thenM` \ loc ->
 375     returnM (RecordConOut data_con (L loc con_expr) rbinds')
 376
 377 -- The main complication with RecordUpd is that we need to explicitly
 378 -- handle the *non-updated* fields.  Consider:
 379 --
 380 --      data T a b = MkT1 { fa :: a, fb :: b }
 381 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 382 --                 | MkT3 { fd :: a }
 383 --
 384 --      upd :: T a b -> c -> T a c
 385 --      upd t x = t { fb = x}
 386 --
 387 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 388 -- because upd should be equivalent to:
 389 --
 390 --      upd t x = case t of
 391 --                      MkT1 p q -> MkT1 p x
 392 --                      MkT2 a b -> MkT2 p b
 393 --                      MkT3 d   -> error ...
 394 --
 395 -- So we need to give a completely fresh type to the result record,
 396 -- and then constrain it by the fields that are *not* updated ("p" above).
 397 --
 398 -- Note that because MkT3 doesn't contain all the fields being updated,
 399 -- its RHS is simply an error, so it doesn't impose any type constraints
 400 --
 401 -- All this is done in STEP 4 below.
 402
 403 tc_expr expr@(RecordUpd record_expr rbinds) res_ty
 404   = addErrCtxt (recordUpdCtxt   expr)           $
 405
 406         -- STEP 0
 407         -- Check that the field names are really field names
 408     ASSERT( notNull rbinds )
 409     let
 410         field_names = map fst rbinds
 411     in
 412     mappM (tcLookupGlobalId.unLoc) field_names  `thenM` \ sel_ids ->
 413         -- The renamer has already checked that they
 414         -- are all in scope
 415     let
 416         bad_guys = [ addSrcSpan loc $ addErrTc (notSelector field_name)
 417                    | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
 418                      not (isRecordSelector sel_id)      -- Excludes class ops
 419                    ]
 420     in
 421     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)  `thenM_`
 422
 423         -- STEP 1
 424         -- Figure out the tycon and data cons from the first field name
 425     let
 426                 -- It's OK to use the non-tc splitters here (for a selector)
 427         sel_id : _   = sel_ids
 428         field_lbl    = recordSelectorFieldLabel sel_id  -- We've failed already if
 429         tycon        = fieldLabelTyCon field_lbl        -- it's not a field label
 430         data_cons    = tyConDataCons tycon
 431         tycon_tyvars = tyConTyVars tycon                -- The data cons use the same type vars
 432     in
 433     tcInstTyVars VanillaTv tycon_tyvars         `thenM` \ (_, result_inst_tys, inst_env) ->
 434
 435         -- STEP 2
 436         -- Check that at least one constructor has all the named fields
 437         -- i.e. has an empty set of bad fields returned by badFields
 438     checkTc (any (null . badFields rbinds) data_cons)
 439             (badFieldsUpd rbinds)               `thenM_`
 440
 441         -- STEP 3
 442         -- Typecheck the update bindings.
 443         -- (Do this after checking for bad fields in case there's a field that
 444         --  doesn't match the constructor.)
 445     let
 446         result_record_ty = mkTyConApp tycon result_inst_tys
 447     in
 448     zapExpectedTo res_ty result_record_ty       `thenM_`
 449     tcRecordBinds tycon result_inst_tys rbinds  `thenM` \ rbinds' ->
 450
 451         -- STEP 4
 452         -- Use the un-updated fields to find a vector of booleans saying
 453         -- which type arguments must be the same in updatee and result.
 454         --
 455         -- WARNING: this code assumes that all data_cons in a common tycon
 456         -- have FieldLabels abstracted over the same tyvars.
 457     let
 458         upd_field_lbls      = map recordSelectorFieldLabel (recBindFields rbinds')
 459         con_field_lbls_s    = map dataConFieldLabels data_cons
 460
 461                 -- A constructor is only relevant to this process if
 462                 -- it contains all the fields that are being updated
 463         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 464         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 465
 466         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 467         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 468
 469         mk_inst_ty tyvar result_inst_ty
 470           | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty   -- Same as result type
 471           | otherwise                        = newTyVarTy liftedTypeKind        -- Fresh type
 472     in
 473     zipWithM mk_inst_ty tycon_tyvars result_inst_tys    `thenM` \ inst_tys ->
 474
 475         -- STEP 5
 476         -- Typecheck the expression to be updated
 477     let
 478         record_ty = mkTyConApp tycon inst_tys
 479     in
 480     tcCheckRho record_expr record_ty            `thenM` \ record_expr' ->
 481
 482         -- STEP 6
 483         -- Figure out the LIE we need.  We have to generate some
 484         -- dictionaries for the data type context, since we are going to
 485         -- do pattern matching over the data cons.
 486         --
 487         -- What dictionaries do we need?
 488         -- We just take the context of the type constructor
 489     let
 490         theta' = substTheta inst_env (tyConTheta tycon)
 491     in
 492     newDicts RecordUpdOrigin theta'     `thenM` \ dicts ->
 493     extendLIEs dicts                    `thenM_`
 494
 495         -- Phew!
 496     returnM (RecordUpdOut record_expr' record_ty result_record_ty rbinds')
 497 \end{code}
 498
 499
 500 %************************************************************************
 501 %*                                                                      *
 502         Arithmetic sequences                    e.g. [a,b..]
 503         and their parallel-array counterparts   e.g. [: a,b.. :]
 504
 505 %*                                                                      *
 506 %************************************************************************
 507
 508 \begin{code}
 509 tc_expr (ArithSeqIn seq@(From expr)) res_ty
 510   = zapToListTy res_ty                          `thenM` \ elt_ty ->
 511     tcCheckRho expr elt_ty                      `thenM` \ expr' ->
 512
 513     newMethodFromName (ArithSeqOrigin seq)
 514                       elt_ty enumFromName       `thenM` \ enum_from ->
 515
 516     returnM (ArithSeqOut (nlHsVar enum_from) (From expr'))
 517
 518 tc_expr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 519   = addErrCtxt (arithSeqCtxt in_expr) $
 520     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 521     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 522     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 523     newMethodFromName (ArithSeqOrigin seq)
 524                       elt_ty enumFromThenName           `thenM` \ enum_from_then ->
 525
 526     returnM (ArithSeqOut (nlHsVar enum_from_then) (FromThen expr1' expr2'))
 527
 528
 529 tc_expr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 530   = addErrCtxt (arithSeqCtxt in_expr) $
 531     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 532     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 533     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 534     newMethodFromName (ArithSeqOrigin seq)
 535                       elt_ty enumFromToName             `thenM` \ enum_from_to ->
 536
 537     returnM (ArithSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2'))
 538
 539 tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 540   = addErrCtxt  (arithSeqCtxt in_expr) $
 541     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 542     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 543     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 544     tcCheckRho expr3 elt_ty                             `thenM`    \ expr3' ->
 545     newMethodFromName (ArithSeqOrigin seq)
 546                       elt_ty enumFromThenToName         `thenM` \ eft ->
 547
 548     returnM (ArithSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3'))
 549
 550 tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
 551   = addErrCtxt (parrSeqCtxt in_expr) $
 552     zapToPArrTy  res_ty                                 `thenM`    \ elt_ty ->
 553     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 554     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 555     newMethodFromName (PArrSeqOrigin seq)
 556                       elt_ty enumFromToPName            `thenM` \ enum_from_to ->
 557
 558     returnM (PArrSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2'))
 559
 560 tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 561   = addErrCtxt  (parrSeqCtxt in_expr) $
 562     zapToPArrTy  res_ty                                 `thenM`    \ elt_ty ->
 563     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 564     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 565     tcCheckRho expr3 elt_ty                             `thenM`    \ expr3' ->
 566     newMethodFromName (PArrSeqOrigin seq)
 567                       elt_ty enumFromThenToPName        `thenM` \ eft ->
 568
 569     returnM (PArrSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3'))
 570
 571 tc_expr (PArrSeqIn _) _
 572   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 573     -- the parser shouldn't have generated it and the renamer shouldn't have
 574     -- let it through
 575 \end{code}
 576
 577
 578 %************************************************************************
 579 %*                                                                      *
 580                 Template Haskell
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 \begin{code}
 585 #ifdef GHCI     /* Only if bootstrapped */
 586         -- Rename excludes these cases otherwise
 587 tc_expr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 588 tc_expr (HsBracket brack)  res_ty = do  { e <- tcBracket brack res_ty
 589                                         ; return (unLoc e) }
 590 #endif /* GHCI */
 591 \end{code}
 592
 593
 594 %************************************************************************
 595 %*                                                                      *
 596                 Catch-all
 597 %*                                                                      *
 598 %************************************************************************
 599
 600 \begin{code}
 601 tc_expr other _ = pprPanic "tcMonoExpr" (ppr other)
 602 \end{code}
 603
 604
 605 %************************************************************************
 606 %*                                                                      *
 607 \subsection{@tcApp@ typchecks an application}
 608 %*                                                                      *
 609 %************************************************************************
 610
 611 \begin{code}
 612
 613 tcApp :: LHsExpr Name -> [LHsExpr Name]         -- Function and args
 614       -> Expected TcRhoType                     -- Expected result type of application
 615       -> TcM (HsExpr TcId)                              -- Translated fun and args
 616
 617 tcApp (L _ (HsApp e1 e2)) args res_ty
 618   = tcApp e1 (e2:args) res_ty           -- Accumulate the arguments
 619
 620 tcApp fun args res_ty
 621   =     -- First type-check the function
 622     tcInferRho fun                              `thenM` \ (fun', fun_ty) ->
 623
 624     addErrCtxt (wrongArgsCtxt "too many" fun args) (
 625         traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty))      `thenM_`
 626         split_fun_ty fun_ty (length args)
 627     )                                           `thenM` \ (expected_arg_tys, actual_result_ty) ->
 628
 629         -- Unify with expected result before (was: after) type-checking the args
 630         -- so that the info from res_ty (was: args) percolates to args (was actual_result_ty).
 631         -- This is when we might detect a too-few args situation.
 632         -- (One can think of cases when the opposite order would give
 633         -- a better error message.)
 634         -- [March 2003: I'm experimenting with putting this first.  Here's an
 635         --              example where it actually makes a real difference
 636         --    class C t a b | t a -> b
 637         --    instance C Char a Bool
 638         --
 639         --    data P t a = forall b. (C t a b) => MkP b
 640         --    data Q t   = MkQ (forall a. P t a)
 641
 642         --    f1, f2 :: Q Char;
 643         --    f1 = MkQ (MkP True)
 644         --    f2 = MkQ (MkP True :: forall a. P Char a)
 645         --
 646         -- With the change, f1 will type-check, because the 'Char' info from
 647         -- the signature is propagated into MkQ's argument. With the check
 648         -- in the other order, the extra signature in f2 is reqd.]
 649
 650     addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
 651                 (tcSubExp res_ty actual_result_ty)      `thenM` \ co_fn ->
 652
 653         -- Now typecheck the args
 654     mappM (tcArg fun)
 655           (zip3 args expected_arg_tys [1..])    `thenM` \ args' ->
 656
 657     returnM (co_fn <$> unLoc (foldl mkHsApp fun' args'))
 658
 659
 660 -- If an error happens we try to figure out whether the
 661 -- function has been given too many or too few arguments,
 662 -- and say so.
 663 -- The ~(Check...) is because in the Infer case the tcSubExp
 664 -- definitely won't fail, so we can be certain we're in the Check branch
 665 checkArgsCtxt fun args (Infer _) actual_res_ty tidy_env
 666   = return (tidy_env, ptext SLIT("Urk infer"))
 667
 668 checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env
 669   = zonkTcType expected_res_ty    `thenM` \ exp_ty' ->
 670     zonkTcType actual_res_ty      `thenM` \ act_ty' ->
 671     let
 672       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 673       (env2, act_ty'') = tidyOpenType env1     act_ty'
 674       (exp_args, _)    = tcSplitFunTys exp_ty''
 675       (act_args, _)    = tcSplitFunTys act_ty''
 676
 677       len_act_args     = length act_args
 678       len_exp_args     = length exp_args
 679
 680       message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
 681               | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
 682               | otherwise                   = appCtxt fun args
 683     in
 684     returnM (env2, message)
 685
 686
 687 split_fun_ty :: TcRhoType       -- The type of the function
 688              -> Int             -- Number of arguments
 689              -> TcM ([TcType],  -- Function argument types
 690                      TcType)    -- Function result types
 691
 692 split_fun_ty fun_ty 0
 693   = returnM ([], fun_ty)
 694
 695 split_fun_ty fun_ty n
 696   =     -- Expect the function to have type A->B
 697     unifyFunTy fun_ty           `thenM` \ (arg_ty, res_ty) ->
 698     split_fun_ty res_ty (n-1)   `thenM` \ (arg_tys, final_res_ty) ->
 699     returnM (arg_ty:arg_tys, final_res_ty)
 700 \end{code}
 701
 702 \begin{code}
 703 tcArg :: LHsExpr Name                           -- The function (for error messages)
 704       -> (LHsExpr Name, TcSigmaType, Int)       -- Actual argument and expected arg type
 705       -> TcM (LHsExpr TcId)                     -- Resulting argument
 706
 707 tcArg the_fun (arg, expected_arg_ty, arg_no)
 708   = addErrCtxt (funAppCtxt the_fun arg arg_no) $
 709     tcCheckSigma arg expected_arg_ty
 710 \end{code}
 711
 712
 713 %************************************************************************
 714 %*                                                                      *
 715 \subsection{@tcId@ typchecks an identifier occurrence}
 716 %*                                                                      *
 717 %************************************************************************
 718
 719 tcId instantiates an occurrence of an Id.
 720 The instantiate_it loop runs round instantiating the Id.
 721 It has to be a loop because we are now prepared to entertain
 722 types like
 723         f:: forall a. Eq a => forall b. Baz b => tau
 724 We want to instantiate this to
 725         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 726
 727 The -fno-method-sharing flag controls what happens so far as the LIE
 728 is concerned.  The default case is that for an overloaded function we
 729 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 730 something like
 731         f :: Num a => a -> a
 732         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 733 If you specify -fno-method-sharing, the dictionary application
 734 isn't shared, so we get
 735         f :: Num a => a -> a
 736         f = /\a (d:Num a) (x:a) -> (+) a d x x
 737 This gets a bit less sharing, but
 738         a) it's better for RULEs involving overloaded functions
 739         b) perhaps fewer separated lambdas
 740
 741 \begin{code}
 742 tcId :: Name -> TcM (HsExpr TcId, TcRhoType)
 743 tcId name       -- Look up the Id and instantiate its type
 744   =     -- First check whether it's a DataCon
 745         -- Reason: we must not forget to chuck in the
 746         --         constraints from their "silly context"
 747     tcLookup name               `thenM` \ thing ->
 748     case thing of {
 749         AGlobal (ADataCon data_con)  -> inst_data_con data_con
 750     ;   AGlobal (AnId id)            -> loop (HsVar id) (idType id)
 751                 -- A global cannot possibly be ill-staged
 752                 -- nor does it need the 'lifting' treatment
 753
 754     ;   ATcId id th_level proc_level -> tc_local_id id th_level proc_level
 755     ;   other                        -> pprPanic "tcId" (ppr name $$ ppr thing)
 756     }
 757   where
 758
 759 #ifndef GHCI
 760     tc_local_id id th_bind_lvl proc_lvl                 -- Non-TH case
 761         = checkProcLevel id proc_lvl    `thenM_`
 762           loop (HsVar id) (idType id)
 763
 764 #else /* GHCI and TH is on */
 765     tc_local_id id th_bind_lvl proc_lvl                 -- TH case
 766         = checkProcLevel id proc_lvl    `thenM_`
 767
 768         -- Check for cross-stage lifting
 769           getStage                              `thenM` \ use_stage ->
 770           case use_stage of
 771               Brack use_lvl ps_var lie_var
 772                 | use_lvl > th_bind_lvl
 773                 ->      -- E.g. \x -> [| h x |]
 774                 -- We must behave as if the reference to x was
 775
 776                 --      h $(lift x)
 777                 -- We use 'x' itself as the splice proxy, used by
 778                 -- the desugarer to stitch it all back together.
 779                 -- If 'x' occurs many times we may get many identical
 780                 -- bindings of the same splice proxy, but that doesn't
 781                 -- matter, although it's a mite untidy.
 782                 let
 783                     id_ty = idType id
 784                 in
 785                 checkTc (isTauTy id_ty) (polySpliceErr id)      `thenM_`
 786                     -- If x is polymorphic, its occurrence sites might
 787                     -- have different instantiations, so we can't use plain
 788                     -- 'x' as the splice proxy name.  I don't know how to
 789                     -- solve this, and it's probably unimportant, so I'm
 790                     -- just going to flag an error for now
 791
 792                 setLIEVar lie_var       (
 793                 newMethodFromName orig id_ty DsMeta.liftName    `thenM` \ lift ->
 794                         -- Put the 'lift' constraint into the right LIE
 795
 796                 -- Update the pending splices
 797                 readMutVar ps_var                       `thenM` \ ps ->
 798                 writeMutVar ps_var ((name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)   `thenM_`
 799
 800                 returnM (HsVar id, id_ty))
 801
 802               other ->
 803                 checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
 804                 loop (HsVar id) (idType id)
 805 #endif /* GHCI */
 806
 807     loop (HsVar fun_id) fun_ty
 808         | want_method_inst fun_ty
 809         = tcInstType VanillaTv fun_ty           `thenM` \ (tyvars, theta, tau) ->
 810           newMethodWithGivenTy orig fun_id
 811                 (mkTyVarTys tyvars) theta tau   `thenM` \ meth_id ->
 812           loop (HsVar meth_id) tau
 813
 814     loop fun fun_ty
 815         | isSigmaTy fun_ty
 816         = tcInstCall orig fun_ty        `thenM` \ (inst_fn, tau) ->
 817           loop (inst_fn <$> fun) tau
 818
 819         | otherwise
 820         = returnM (fun, fun_ty)
 821
 822         --      Hack Alert (want_method_inst)!
 823         -- If   f :: (%x :: T) => Int -> Int
 824         -- Then if we have two separate calls, (f 3, f 4), we cannot
 825         -- make a method constraint that then gets shared, thus:
 826         --      let m = f %x in (m 3, m 4)
 827         -- because that loses the linearity of the constraint.
 828         -- The simplest thing to do is never to construct a method constraint
 829         -- in the first place that has a linear implicit parameter in it.
 830     want_method_inst fun_ty
 831         | opt_NoMethodSharing = False
 832         | otherwise           = case tcSplitSigmaTy fun_ty of
 833                                   (_,[],_)    -> False  -- Not overloaded
 834                                   (_,theta,_) -> not (any isLinearPred theta)
 835
 836
 837         -- We treat data constructors differently, because we have to generate
 838         -- constraints for their silly theta, which no longer appears in
 839         -- the type of dataConWrapId (see note on "stupid context" in DataCon.lhs
 840         -- It's dual to TcPat.tcConstructor
 841     inst_data_con data_con
 842       = tcInstDataCon orig VanillaTv data_con   `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
 843         extendLIEs ex_dicts                     `thenM_`
 844         getSrcSpanM                             `thenM` \ loc ->
 845         returnM (unLoc (mkHsDictApp (mkHsTyApp (L loc (HsVar (dataConWrapId data_con))) ty_args)
 846                              (map instToId ex_dicts)),
 847                  mkFunTys arg_tys result_ty)
 848         -- ToDo: nasty loc/unloc stuff here
 849
 850     orig = OccurrenceOf name
 851 \end{code}
 852
 853 %************************************************************************
 854 %*                                                                      *
 855 \subsection{Record bindings}
 856 %*                                                                      *
 857 %************************************************************************
 858
 859 Game plan for record bindings
 860 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 861 1. Find the TyCon for the bindings, from the first field label.
 862
 863 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 864
 865 For each binding field = value
 866
 867 3. Instantiate the field type (from the field label) using the type
 868    envt from step 2.
 869
 870 4  Type check the value using tcArg, passing the field type as
 871    the expected argument type.
 872
 873 This extends OK when the field types are universally quantified.
 874
 875
 876 \begin{code}
 877 tcRecordBinds
 878         :: TyCon                -- Type constructor for the record
 879         -> [TcType]             -- Args of this type constructor
 880         -> HsRecordBinds Name
 881         -> TcM (HsRecordBinds TcId)
 882
 883 tcRecordBinds tycon ty_args rbinds
 884   = mappM do_bind rbinds
 885   where
 886     tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
 887
 888     do_bind (L loc field_lbl_name, rhs)
 889       = addErrCtxt (fieldCtxt field_lbl_name)   $
 890         tcLookupId field_lbl_name               `thenM` \ sel_id ->
 891         let
 892             field_lbl = recordSelectorFieldLabel sel_id
 893             field_ty  = substTy tenv (fieldLabelType field_lbl)
 894         in
 895         ASSERT( isRecordSelector sel_id )
 896                 -- This lookup and assertion will surely succeed, because
 897                 -- we check that the fields are indeed record selectors
 898                 -- before calling tcRecordBinds
 899         ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
 900                 -- The caller of tcRecordBinds has already checked
 901                 -- that all the fields come from the same type
 902
 903         tcCheckSigma rhs field_ty               `thenM` \ rhs' ->
 904
 905         returnM (L loc sel_id, rhs')
 906
 907 badFields rbinds data_con
 908   = filter (not . (`elem` field_names)) (recBindFields rbinds)
 909   where
 910     field_names = map fieldLabelName (dataConFieldLabels data_con)
 911
 912 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
 913 checkMissingFields data_con rbinds
 914   | null field_labels   -- Not declared as a record;
 915                         -- But C{} is still valid if no strict fields
 916   = if any isMarkedStrict field_strs then
 917         -- Illegal if any arg is strict
 918         addErrTc (missingStrictFields data_con [])
 919     else
 920         returnM ()
 921
 922   | otherwise           -- A record
 923   = checkM (null missing_s_fields)
 924            (addErrTc (missingStrictFields data_con missing_s_fields))   `thenM_`
 925
 926     doptM Opt_WarnMissingFields         `thenM` \ warn ->
 927     checkM (not (warn && notNull missing_ns_fields))
 928            (warnTc True (missingFields data_con missing_ns_fields))
 929
 930   where
 931     missing_s_fields
 932         = [ fl | (fl, str) <- field_info,
 933                  isMarkedStrict str,
 934                  not (fieldLabelName fl `elem` field_names_used)
 935           ]
 936     missing_ns_fields
 937         = [ fl | (fl, str) <- field_info,
 938                  not (isMarkedStrict str),
 939                  not (fieldLabelName fl `elem` field_names_used)
 940           ]
 941
 942     field_names_used = recBindFields rbinds
 943     field_labels     = dataConFieldLabels data_con
 944
 945     field_info = zipEqual "missingFields"
 946                           field_labels
 947                           field_strs
 948
 949     field_strs = dataConStrictMarks data_con
 950 \end{code}
 951
 952 %************************************************************************
 953 %*                                                                      *
 954 \subsection{@tcCheckRhos@ typechecks a {\em list} of expressions}
 955 %*                                                                      *
 956 %************************************************************************
 957
 958 \begin{code}
 959 tcCheckRhos :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
 960
 961 tcCheckRhos [] [] = returnM []
 962 tcCheckRhos (expr:exprs) (ty:tys)
 963  = tcCheckRho  expr  ty         `thenM` \ expr' ->
 964    tcCheckRhos exprs tys        `thenM` \ exprs' ->
 965    returnM (expr':exprs')
 966 \end{code}
 967
 968
 969 %************************************************************************
 970 %*                                                                      *
 971 \subsection{Literals}
 972 %*                                                                      *
 973 %************************************************************************
 974
 975 Overloaded literals.
 976
 977 \begin{code}
 978 tcLit :: HsLit -> Expected TcRhoType -> TcM (HsExpr TcId)
 979 tcLit lit res_ty
 980   = zapExpectedTo res_ty (hsLitType lit)                `thenM_`
 981     returnM (HsLit lit)
 982 \end{code}
 983
 984
 985 %************************************************************************
 986 %*                                                                      *
 987 \subsection{Errors and contexts}
 988 %*                                                                      *
 989 %************************************************************************
 990
 991 Boring and alphabetical:
 992 \begin{code}
 993 arithSeqCtxt expr
 994   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 995
 996 parrSeqCtxt expr
 997   = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
 998
 999 caseCtxt expr
1000   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
1001
1002 caseScrutCtxt expr
1003   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1004
1005 exprCtxt expr
1006   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
1007
1008 fieldCtxt field_name
1009   = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
1010
1011 funAppCtxt fun arg arg_no
1012   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1013                     quotes (ppr fun) <> text ", namely"])
1014          4 (quotes (ppr arg))
1015
1016 listCtxt expr
1017   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1018
1019 parrCtxt expr
1020   = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr)
1021
1022 predCtxt expr
1023   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1024
1025 appCtxt fun args
1026   = ptext SLIT("In the application") <+> quotes (ppr the_app)
1027   where
1028     the_app = foldl mkHsApp fun args    -- Used in error messages
1029
1030 badFieldsUpd rbinds
1031   = hang (ptext SLIT("No constructor has all these fields:"))
1032          4 (pprQuotedList (recBindFields rbinds))
1033
1034 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1035 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1036
1037 notSelector field
1038   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1039
1040 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1041 missingStrictFields con fields
1042   = header <> rest
1043   where
1044     rest | null fields = empty  -- Happens for non-record constructors
1045                                 -- with strict fields
1046          | otherwise   = colon <+> pprWithCommas ppr fields
1047
1048     header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
1049              ptext SLIT("does not have the required strict field(s)")
1050
1051 missingFields :: DataCon -> [FieldLabel] -> SDoc
1052 missingFields con fields
1053   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
1054         <+> pprWithCommas ppr fields
1055
1056 wrongArgsCtxt too_many_or_few fun args
1057   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1058                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
1059                     <+> ptext SLIT("arguments in the call"))
1060          4 (parens (ppr the_app))
1061   where
1062     the_app = foldl mkHsApp fun args    -- Used in error messages
1063
1064 #ifdef GHCI
1065 polySpliceErr :: Id -> SDoc
1066 polySpliceErr id
1067   = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
1068 #endif
1069 \end{code}