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