ghc/compiler/typecheck/TcExpr.lhs

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