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