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