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 ( tcPolyExpr, tcPolyExprNC,
   8                 tcMonoExpr, tcInferRho, tcSyntaxOp ) where
   9
  10 #include "HsVersions.h"
  11
  12 #ifdef GHCI     /* Only if bootstrapped */
  13 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcBracket )
  14 import HsSyn            ( nlHsVar )
  15 import Id               ( Id, idName )
  16 import Name             ( isExternalName )
  17 import TcType           ( isTauTy )
  18 import TcEnv            ( checkWellStaged )
  19 import HsSyn            ( nlHsApp )
  20 import qualified DsMeta
  21 #endif
  22
  23 import HsSyn            ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
  24                           HsMatchContext(..), HsRecordBinds, mkHsWrap, hsExplicitTvs,
  25                           mkHsApp, mkLHsWrap )
  26 import TcHsSyn          ( hsLitType )
  27 import TcRnMonad
  28 import TcUnify          ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
  29                           boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
  30                           unBox )
  31 import BasicTypes       ( Arity, isMarkedStrict )
  32 import Inst             ( newMethodFromName, newIPDict, instCall,
  33                           newMethodWithGivenTy, instStupidTheta )
  34 import TcBinds          ( tcLocalBinds )
  35 import TcEnv            ( tcLookup, tcLookupDataCon, tcLookupField, tcExtendTyVarEnv2 )
  36 import TcArrows         ( tcProc )
  37 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
  38                           TcMatchCtxt(..) )
  39 import TcHsType         ( tcHsSigType, UserTypeCtxt(..) )
  40 import TcPat            ( tcOverloadedLit, addDataConStupidTheta, badFieldCon )
  41 import TcMType          ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
  42                           readFilledBox, zonkTcTypes )
  43 import TcType           ( TcType, TcSigmaType, TcRhoType, TvSubst,
  44                           BoxySigmaType, BoxyRhoType, ThetaType,
  45                           mkTyVarTys, mkFunTys,
  46                           tcMultiSplitSigmaTy, tcSplitFunTysN,
  47                           tcSplitTyConApp_maybe,
  48                           isSigmaTy, mkFunTy, mkTyConApp,
  49                           exactTyVarsOfType, exactTyVarsOfTypes,
  50                           zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
  51                         )
  52 import {- Kind parts of -}
  53        Type             ( argTypeKind )
  54
  55 import Id               ( idType, recordSelectorFieldLabel,
  56                           isRecordSelector, isNaughtyRecordSelector,
  57                           isDataConId_maybe )
  58 import DataCon          ( DataCon, dataConFieldLabels, dataConStrictMarks,
  59                           dataConSourceArity,
  60                           dataConWrapId, isVanillaDataCon, dataConUnivTyVars,
  61                           dataConOrigArgTys )
  62 import Name             ( Name )
  63 import TyCon            ( FieldLabel, tyConStupidTheta, tyConDataCons,
  64                           isEnumerationTyCon )
  65 import Type             ( substTheta, substTy )
  66 import Var              ( TyVar, tyVarKind )
  67 import VarSet           ( emptyVarSet, elemVarSet, unionVarSet )
  68 import TysWiredIn       ( boolTy, parrTyCon, tupleTyCon )
  69 import PrelNames        ( enumFromName, enumFromThenName,
  70                           enumFromToName, enumFromThenToName,
  71                           enumFromToPName, enumFromThenToPName, negateName,
  72                           hasKey
  73                         )
  74 import PrimOp           ( tagToEnumKey )
  75
  76 import DynFlags
  77 import StaticFlags      ( opt_NoMethodSharing )
  78 import HscTypes         ( TyThing(..) )
  79 import SrcLoc           ( Located(..), unLoc )
  80 import Util
  81 import ListSetOps       ( assocMaybe )
  82 import Maybes           ( catMaybes )
  83 import Outputable
  84 import FastString
  85
  86 #ifdef DEBUG
  87 import TyCon            ( tyConArity )
  88 #endif
  89 \end{code}
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection{Main wrappers}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 \begin{code}
  98 tcPolyExpr, tcPolyExprNC
  99          :: LHsExpr Name                -- Expession to type check
 100          -> BoxySigmaType               -- Expected type (could be a polytpye)
 101          -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
 102
 103 -- tcPolyExpr is a convenient place (frequent but not too frequent) place
 104 -- to add context information.
 105 -- The NC version does not do so, usually because the caller wants
 106 -- to do so himself.
 107
 108 tcPolyExpr expr res_ty
 109   = addErrCtxt (exprCtxt (unLoc expr)) $
 110     tcPolyExprNC expr res_ty
 111
 112 tcPolyExprNC expr res_ty
 113   | isSigmaTy res_ty
 114   = do  { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
 115                 -- Note the recursive call to tcPolyExpr, because the
 116                 -- type may have multiple layers of for-alls
 117         ; return (mkLHsWrap gen_fn expr') }
 118
 119   | otherwise
 120   = tcMonoExpr expr res_ty
 121
 122 ---------------
 123 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
 124 tcPolyExprs [] [] = returnM []
 125 tcPolyExprs (expr:exprs) (ty:tys)
 126  = do   { expr'  <- tcPolyExpr  expr  ty
 127         ; exprs' <- tcPolyExprs exprs tys
 128         ; returnM (expr':exprs') }
 129 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
 130
 131 ---------------
 132 tcMonoExpr :: LHsExpr Name      -- Expression to type check
 133            -> BoxyRhoType       -- Expected type (could be a type variable)
 134                                 -- Definitely no foralls at the top
 135                                 -- Can contain boxes, which will be filled in
 136            -> TcM (LHsExpr TcId)
 137
 138 tcMonoExpr (L loc expr) res_ty
 139   = ASSERT( not (isSigmaTy res_ty) )
 140     setSrcSpan loc $
 141     do  { expr' <- tcExpr expr res_ty
 142         ; return (L loc expr') }
 143
 144 ---------------
 145 tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 146 tcInferRho expr = tcInfer (tcMonoExpr expr)
 147 \end{code}
 148
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153         tcExpr: the main expression typechecker
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 \begin{code}
 158 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
 159 tcExpr (HsVar name)     res_ty = tcId (OccurrenceOf name) name res_ty
 160
 161 tcExpr (HsLit lit)      res_ty = do { boxyUnify (hsLitType lit) res_ty
 162                                     ; return (HsLit lit) }
 163
 164 tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExpr expr res_ty
 165                                     ; return (HsPar expr') }
 166
 167 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
 168                                     ; returnM (HsSCC lbl expr') }
 169
 170 tcExpr (HsCoreAnn lbl expr) res_ty       -- hdaume: core annotation
 171   = do  { expr' <- tcMonoExpr expr res_ty
 172         ; return (HsCoreAnn lbl expr') }
 173
 174 tcExpr (HsOverLit lit) res_ty
 175   = do  { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
 176         ; return (HsOverLit lit') }
 177
 178 tcExpr (NegApp expr neg_expr) res_ty
 179   = do  { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
 180                                   (mkFunTy res_ty res_ty)
 181         ; expr' <- tcMonoExpr expr res_ty
 182         ; return (NegApp expr' neg_expr') }
 183
 184 tcExpr (HsIPVar ip) res_ty
 185   = do  {       -- Implicit parameters must have a *tau-type* not a
 186                 -- type scheme.  We enforce this by creating a fresh
 187                 -- type variable as its type.  (Because res_ty may not
 188                 -- be a tau-type.)
 189           ip_ty <- newFlexiTyVarTy argTypeKind  -- argTypeKind: it can't be an unboxed tuple
 190         ; co_fn <- tcSubExp ip_ty res_ty
 191         ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
 192         ; extendLIE inst
 193         ; return (mkHsWrap co_fn (HsIPVar ip')) }
 194
 195 tcExpr (HsApp e1 e2) res_ty
 196   = go e1 [e2]
 197   where
 198     go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
 199     go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
 200     go lfun@(L loc fun) args
 201         = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
 202                                 tcApp fun (length args) (tcArgs lfun args) res_ty
 203              ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
 204
 205 tcExpr (HsLam match) res_ty
 206   = do  { (co_fn, match') <- tcMatchLambda match res_ty
 207         ; return (mkHsWrap co_fn (HsLam match')) }
 208
 209 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
 210  = do   { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 211
 212         -- Remember to extend the lexical type-variable environment
 213         ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
 214                              tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
 215                              tcPolyExprNC expr res_ty)
 216
 217         ; co_fn <- tcSubExp sig_tc_ty res_ty
 218         ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
 219
 220 tcExpr (HsType ty) res_ty
 221   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 222         -- This is the syntax for type applications that I was planning
 223         -- but there are difficulties (e.g. what order for type args)
 224         -- so it's not enabled yet.
 225         -- Can't eliminate it altogether from the parser, because the
 226         -- same parser parses *patterns*.
 227 \end{code}
 228
 229
 230 %************************************************************************
 231 %*                                                                      *
 232                 Infix operators and sections
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 \begin{code}
 237 tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
 238   = do  { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
 239         ; return (OpApp arg1' (L loc op') fix arg2') }
 240
 241 -- Left sections, equivalent to
 242 --      \ x -> e op x,
 243 -- or
 244 --      \ x -> op e x,
 245 -- or just
 246 --      op e
 247 --
 248 -- We treat it as similar to the latter, so we don't
 249 -- actually require the function to take two arguments
 250 -- at all.  For example, (x `not`) means (not x);
 251 -- you get postfix operators!  Not really Haskell 98
 252 -- I suppose, but it's less work and kind of useful.
 253
 254 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 255   = do  { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
 256         ; return (SectionL arg1' (L loc op')) }
 257
 258 -- Right sections, equivalent to \ x -> x `op` expr, or
 259 --      \ x -> op x expr
 260
 261 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
 262   = do  { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
 263                                    tcApp op 2 (tc_args arg1_ty') res_ty'
 264         ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
 265   where
 266     doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
 267                 <+> ptext SLIT("takes one argument")
 268     tc_args arg1_ty' [arg1_ty, arg2_ty]
 269         = do { boxyUnify arg1_ty' arg1_ty
 270              ; tcArg lop (arg2, arg2_ty, 2) }
 271     tc_args arg1_ty' other = panic "tcExpr SectionR"
 272 \end{code}
 273
 274 \begin{code}
 275 tcExpr (HsLet binds expr) res_ty
 276   = do  { (binds', expr') <- tcLocalBinds binds $
 277                              tcMonoExpr expr res_ty
 278         ; return (HsLet binds' expr') }
 279
 280 tcExpr (HsCase scrut matches) exp_ty
 281   = do  {  -- We used to typecheck the case alternatives first.
 282            -- The case patterns tend to give good type info to use
 283            -- when typechecking the scrutinee.  For example
 284            --   case (map f) of
 285            --     (x:xs) -> ...
 286            -- will report that map is applied to too few arguments
 287            --
 288            -- But now, in the GADT world, we need to typecheck the scrutinee
 289            -- first, to get type info that may be refined in the case alternatives
 290           (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
 291                                            (tcInferRho scrut)
 292
 293         ; traceTc (text "HsCase" <+> ppr scrut_ty)
 294         ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
 295         ; return (HsCase scrut' matches') }
 296  where
 297     match_ctxt = MC { mc_what = CaseAlt,
 298                       mc_body = tcBody }
 299
 300 tcExpr (HsIf pred b1 b2) res_ty
 301   = do  { pred' <- addErrCtxt (predCtxt pred) $
 302                    tcMonoExpr pred boolTy
 303         ; b1' <- tcMonoExpr b1 res_ty
 304         ; b2' <- tcMonoExpr b2 res_ty
 305         ; return (HsIf pred' b1' b2') }
 306
 307 tcExpr (HsDo do_or_lc stmts body _) res_ty
 308   = tcDoStmts do_or_lc stmts body res_ty
 309
 310 tcExpr in_expr@(ExplicitList _ exprs) res_ty    -- Non-empty list
 311   = do  { elt_ty <- boxySplitListTy res_ty
 312         ; exprs' <- mappM (tc_elt elt_ty) exprs
 313         ; return (ExplicitList elt_ty exprs') }
 314   where
 315     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 316
 317 tcExpr in_expr@(ExplicitPArr _ exprs) res_ty    -- maybe empty
 318   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 319         ; exprs' <- mappM (tc_elt elt_ty) exprs
 320         ; ifM (null exprs) (zapToMonotype elt_ty)
 321                 -- If there are no expressions in the comprehension
 322                 -- we must still fill in the box
 323                 -- (Not needed for [] and () becuase they happen
 324                 --  to parse as data constructors.)
 325         ; return (ExplicitPArr elt_ty exprs') }
 326   where
 327     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 328
 329 tcExpr (ExplicitTuple exprs boxity) res_ty
 330   = do  { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
 331         ; exprs' <-  tcPolyExprs exprs arg_tys
 332         ; return (ExplicitTuple exprs' boxity) }
 333
 334 tcExpr (HsProc pat cmd) res_ty
 335   = do  { (pat', cmd') <- tcProc pat cmd res_ty
 336         ; return (HsProc pat' cmd') }
 337
 338 tcExpr e@(HsArrApp _ _ _ _ _) _
 339   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 340                       ptext SLIT("was found where an expression was expected")])
 341
 342 tcExpr e@(HsArrForm _ _ _) _
 343   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 344                       ptext SLIT("was found where an expression was expected")])
 345 \end{code}
 346
 347 %************************************************************************
 348 %*                                                                      *
 349                 Record construction and update
 350 %*                                                                      *
 351 %************************************************************************
 352
 353 \begin{code}
 354 tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
 355   = do  { data_con <- tcLookupDataCon con_name
 356
 357         -- Check for missing fields
 358         ; checkMissingFields data_con rbinds
 359
 360         ; let arity = dataConSourceArity data_con
 361               check_fields arg_tys
 362                   = do  { rbinds' <- tcRecordBinds data_con arg_tys rbinds
 363                         ; mapM unBox arg_tys
 364                         ; return rbinds' }
 365                 -- The unBox ensures that all the boxes in arg_tys are indeed
 366                 -- filled, which is the invariant expected by tcIdApp
 367
 368         ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
 369
 370         ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
 371
 372 -- The main complication with RecordUpd is that we need to explicitly
 373 -- handle the *non-updated* fields.  Consider:
 374 --
 375 --      data T a b = MkT1 { fa :: a, fb :: b }
 376 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 377 --                 | MkT3 { fd :: a }
 378 --
 379 --      upd :: T a b -> c -> T a c
 380 --      upd t x = t { fb = x}
 381 --
 382 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 383 -- because upd should be equivalent to:
 384 --
 385 --      upd t x = case t of
 386 --                      MkT1 p q -> MkT1 p x
 387 --                      MkT2 a b -> MkT2 p b
 388 --                      MkT3 d   -> error ...
 389 --
 390 -- So we need to give a completely fresh type to the result record,
 391 -- and then constrain it by the fields that are *not* updated ("p" above).
 392 --
 393 -- Note that because MkT3 doesn't contain all the fields being updated,
 394 -- its RHS is simply an error, so it doesn't impose any type constraints
 395 --
 396 -- All this is done in STEP 4 below.
 397 --
 398 -- Note about GADTs
 399 -- ~~~~~~~~~~~~~~~~
 400 -- For record update we require that every constructor involved in the
 401 -- update (i.e. that has all the specified fields) is "vanilla".  I
 402 -- don't know how to do the update otherwise.
 403
 404
 405 tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 406   =     -- STEP 0
 407         -- Check that the field names are really field names
 408     ASSERT( notNull rbinds )
 409     let
 410         field_names = map fst rbinds
 411     in
 412     mappM (tcLookupField . unLoc) field_names   `thenM` \ sel_ids ->
 413         -- The renamer has already checked that they
 414         -- are all in scope
 415     let
 416         bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
 417                    | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
 418                      not (isRecordSelector sel_id)      -- Excludes class ops
 419                    ]
 420     in
 421     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)  `thenM_`
 422
 423         -- STEP 1
 424         -- Figure out the tycon and data cons from the first field name
 425     let
 426                 -- It's OK to use the non-tc splitters here (for a selector)
 427         upd_field_lbls  = recBindFields rbinds
 428         sel_id : _      = sel_ids
 429         (tycon, _)      = recordSelectorFieldLabel sel_id       -- We've failed already if
 430         data_cons       = tyConDataCons tycon           -- it's not a field label
 431         relevant_cons   = filter is_relevant data_cons
 432         is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
 433     in
 434
 435         -- STEP 2
 436         -- Check that at least one constructor has all the named fields
 437         -- i.e. has an empty set of bad fields returned by badFields
 438     checkTc (not (null relevant_cons))
 439             (badFieldsUpd rbinds)       `thenM_`
 440
 441         -- Check that all relevant data cons are vanilla.  Doing record updates on
 442         -- GADTs and/or existentials is more than my tiny brain can cope with today
 443     checkTc (all isVanillaDataCon relevant_cons)
 444             (nonVanillaUpd tycon)       `thenM_`
 445
 446         -- STEP 4
 447         -- Use the un-updated fields to find a vector of booleans saying
 448         -- which type arguments must be the same in updatee and result.
 449         --
 450         -- WARNING: this code assumes that all data_cons in a common tycon
 451         -- have FieldLabels abstracted over the same tyvars.
 452     let
 453                 -- A constructor is only relevant to this process if
 454                 -- it contains *all* the fields that are being updated
 455         con1            = head relevant_cons    -- A representative constructor
 456         con1_tyvars     = dataConUnivTyVars con1
 457         con1_flds       = dataConFieldLabels con1
 458         con1_arg_tys    = dataConOrigArgTys con1
 459         common_tyvars   = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
 460                                                  , not (fld `elem` upd_field_lbls) ]
 461
 462         is_common_tv tv = tv `elemVarSet` common_tyvars
 463
 464         mk_inst_ty tv result_inst_ty
 465           | is_common_tv tv = returnM result_inst_ty            -- Same as result type
 466           | otherwise       = newFlexiTyVarTy (tyVarKind tv)    -- Fresh type, of correct kind
 467     in
 468     tcInstTyVars con1_tyvars                            `thenM` \ (_, result_inst_tys, inst_env) ->
 469     zipWithM mk_inst_ty con1_tyvars result_inst_tys     `thenM` \ inst_tys ->
 470
 471         -- STEP 3
 472         -- Typecheck the update bindings.
 473         -- (Do this after checking for bad fields in case there's a field that
 474         --  doesn't match the constructor.)
 475     let
 476         result_record_ty = mkTyConApp tycon result_inst_tys
 477         con1_arg_tys'    = map (substTy inst_env) con1_arg_tys
 478     in
 479     tcSubExp result_record_ty res_ty            `thenM` \ co_fn ->
 480     tcRecordBinds con1 con1_arg_tys' rbinds     `thenM` \ rbinds' ->
 481
 482         -- STEP 5
 483         -- Typecheck the expression to be updated
 484     let
 485         record_ty = ASSERT( length inst_tys == tyConArity tycon )
 486                     mkTyConApp tycon inst_tys
 487         -- This is one place where the isVanilla check is important
 488         -- So that inst_tys matches the tycon
 489     in
 490     tcMonoExpr record_expr record_ty            `thenM` \ record_expr' ->
 491
 492         -- STEP 6
 493         -- Figure out the LIE we need.  We have to generate some
 494         -- dictionaries for the data type context, since we are going to
 495         -- do pattern matching over the data cons.
 496         --
 497         -- What dictionaries do we need?  The tyConStupidTheta tells us.
 498     let
 499         theta' = substTheta inst_env (tyConStupidTheta tycon)
 500     in
 501     instStupidTheta RecordUpdOrigin theta'      `thenM_`
 502
 503         -- Phew!
 504     returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
 505 \end{code}
 506
 507
 508 %************************************************************************
 509 %*                                                                      *
 510         Arithmetic sequences                    e.g. [a,b..]
 511         and their parallel-array counterparts   e.g. [: a,b.. :]
 512
 513 %*                                                                      *
 514 %************************************************************************
 515
 516 \begin{code}
 517 tcExpr (ArithSeq _ seq@(From expr)) res_ty
 518   = do  { elt_ty <- boxySplitListTy res_ty
 519         ; expr' <- tcPolyExpr expr elt_ty
 520         ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
 521                               elt_ty enumFromName
 522         ; return (ArithSeq (HsVar enum_from) (From expr')) }
 523
 524 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
 525   = do  { elt_ty <- boxySplitListTy res_ty
 526         ; expr1' <- tcPolyExpr expr1 elt_ty
 527         ; expr2' <- tcPolyExpr expr2 elt_ty
 528         ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
 529                               elt_ty enumFromThenName
 530         ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
 531
 532
 533 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
 534   = do  { elt_ty <- boxySplitListTy res_ty
 535         ; expr1' <- tcPolyExpr expr1 elt_ty
 536         ; expr2' <- tcPolyExpr expr2 elt_ty
 537         ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
 538                               elt_ty enumFromToName
 539         ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
 540
 541 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 542   = do  { elt_ty <- boxySplitListTy res_ty
 543         ; expr1' <- tcPolyExpr expr1 elt_ty
 544         ; expr2' <- tcPolyExpr expr2 elt_ty
 545         ; expr3' <- tcPolyExpr expr3 elt_ty
 546         ; eft <- newMethodFromName (ArithSeqOrigin seq)
 547                       elt_ty enumFromThenToName
 548         ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
 549
 550 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
 551   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 552         ; expr1' <- tcPolyExpr expr1 elt_ty
 553         ; expr2' <- tcPolyExpr expr2 elt_ty
 554         ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
 555                                       elt_ty enumFromToPName
 556         ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
 557
 558 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 559   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 560         ; expr1' <- tcPolyExpr expr1 elt_ty
 561         ; expr2' <- tcPolyExpr expr2 elt_ty
 562         ; expr3' <- tcPolyExpr expr3 elt_ty
 563         ; eft <- newMethodFromName (PArrSeqOrigin seq)
 564                       elt_ty enumFromThenToPName
 565         ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
 566
 567 tcExpr (PArrSeq _ _) _
 568   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 569     -- the parser shouldn't have generated it and the renamer shouldn't have
 570     -- let it through
 571 \end{code}
 572
 573
 574 %************************************************************************
 575 %*                                                                      *
 576                 Template Haskell
 577 %*                                                                      *
 578 %************************************************************************
 579
 580 \begin{code}
 581 #ifdef GHCI     /* Only if bootstrapped */
 582         -- Rename excludes these cases otherwise
 583 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 584 tcExpr (HsBracket brack)  res_ty = do   { e <- tcBracket brack res_ty
 585                                         ; return (unLoc e) }
 586 #endif /* GHCI */
 587 \end{code}
 588
 589
 590 %************************************************************************
 591 %*                                                                      *
 592                 Catch-all
 593 %*                                                                      *
 594 %************************************************************************
 595
 596 \begin{code}
 597 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 598 \end{code}
 599
 600
 601 %************************************************************************
 602 %*                                                                      *
 603                 Applications
 604 %*                                                                      *
 605 %************************************************************************
 606
 607 \begin{code}
 608 ---------------------------
 609 tcApp :: HsExpr Name                            -- Function
 610       -> Arity                                  -- Number of args reqd
 611       -> ([BoxySigmaType] -> TcM arg_results)   -- Argument type-checker
 612       -> BoxyRhoType                            -- Result type
 613       -> TcM (HsExpr TcId, arg_results)
 614
 615 -- (tcFun fun n_args arg_checker res_ty)
 616 -- The argument type checker, arg_checker, will be passed exactly n_args types
 617
 618 tcApp (HsVar fun_name) n_args arg_checker res_ty
 619   = tcIdApp fun_name n_args arg_checker res_ty
 620
 621 tcApp fun n_args arg_checker res_ty     -- The vanilla case (rula APP)
 622   = do  { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
 623         ; fun'      <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
 624         ; arg_tys'  <- mapM readFilledBox arg_boxes
 625         ; args'     <- arg_checker arg_tys'
 626         ; return (fun', args') }
 627
 628 ---------------------------
 629 tcIdApp :: Name                                 -- Function
 630         -> Arity                                -- Number of args reqd
 631         -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
 632                 -- The arg-checker guarantees to fill all boxes in the arg types
 633         -> BoxyRhoType                          -- Result type
 634         -> TcM (HsExpr TcId, arg_results)
 635
 636 -- Call         (f e1 ... en) :: res_ty
 637 -- Type         f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
 638 --                      (where k <= n; fres has the rest)
 639 -- NB:  if k < n then the function doesn't have enough args, and
 640 --      presumably fres is a type variable that we are going to
 641 --      instantiate with a function type
 642 --
 643 -- Then         fres <= bx_(k+1) -> ... -> bx_n -> res_ty
 644
 645 tcIdApp fun_name n_args arg_checker res_ty
 646   = do  { let orig = OccurrenceOf fun_name
 647         ; (fun, fun_ty) <- lookupFun orig fun_name
 648
 649         -- Split up the function type
 650         ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
 651               (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
 652
 653               qtvs = concatMap fst tv_theta_prs         -- Quantified tyvars
 654               arg_qtvs = exactTyVarsOfTypes fun_arg_tys
 655               res_qtvs = exactTyVarsOfType fun_res_ty
 656                 -- NB: exactTyVarsOfType.  See Note [Silly type synonyms in smart-app]
 657               tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
 658               k              = length fun_arg_tys       -- k <= n_args
 659               n_missing_args = n_args - k               -- Always >= 0
 660
 661         -- Match the result type of the function with the
 662         -- result type of the context, to get an inital substitution
 663         ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
 664         ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
 665               res_ty'        = mkFunTys extra_arg_tys' res_ty
 666         ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
 667         ; let arg_subst    = zipOpenTvSubst qtvs qtys'
 668               fun_arg_tys' = substTys arg_subst fun_arg_tys
 669
 670         -- Typecheck the arguments!
 671         -- Doing so will fill arg_qtvs and extra_arg_tys'
 672         ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
 673
 674         -- Strip boxes from the qtvs that have been filled in by the arg checking
 675         -- AND any variables that are mentioned in neither arg nor result
 676         -- the latter are mentioned only in constraints; stripBoxyType will
 677         -- fill them with a monotype
 678         ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
 679                              | otherwise                 = return qty'
 680         ; qtys'' <- zipWithM strip qtvs qtys'
 681         ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
 682
 683         -- Result subsumption
 684         ; let res_subst = zipOpenTvSubst qtvs qtys''
 685               fun_res_ty'' = substTy res_subst fun_res_ty
 686               res_ty'' = mkFunTys extra_arg_tys'' res_ty
 687         ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty''
 688
 689         -- And pack up the results
 690         -- By applying the coercion just to the *function* we can make
 691         -- tcFun work nicely for OpApp and Sections too
 692         ; fun' <- instFun orig fun res_subst tv_theta_prs
 693         ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
 694         ; return (mkHsWrap co_fn' fun', args') }
 695 \end{code}
 696
 697 Note [Silly type synonyms in smart-app]
 698 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 699 When we call sripBoxyType, all of the boxes should be filled
 700 in.  But we need to be careful about type synonyms:
 701         type T a = Int
 702         f :: T a -> Int
 703         ...(f x)...
 704 In the call (f x) we'll typecheck x, expecting it to have type
 705 (T box).  Usually that would fill in the box, but in this case not;
 706 because 'a' is discarded by the silly type synonym T.  So we must
 707 use exactTyVarsOfType to figure out which type variables are free
 708 in the argument type.
 709
 710 \begin{code}
 711 -- tcId is a specialisation of tcIdApp when there are no arguments
 712 -- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
 713 --                ; return res }
 714
 715 tcId :: InstOrigin
 716      -> Name                                    -- Function
 717      -> BoxyRhoType                             -- Result type
 718      -> TcM (HsExpr TcId)
 719 tcId orig fun_name res_ty
 720   = do  { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
 721         ; (fun, fun_ty) <- lookupFun orig fun_name
 722
 723         -- Split up the function type
 724         ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
 725               qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
 726               tau_qtvs = exactTyVarsOfType fun_tau      -- Mentioned in the tau part
 727         ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
 728
 729         -- Do the subsumption check wrt the result type
 730         ; let res_subst = zipTopTvSubst qtvs qtv_tys
 731               fun_tau'  = substTy res_subst fun_tau
 732
 733         ; co_fn <- tcFunResTy fun_name fun_tau' res_ty
 734
 735         -- And pack up the results
 736         ; fun' <- instFun orig fun res_subst tv_theta_prs
 737         ; return (mkHsWrap co_fn fun') }
 738
 739 --      Note [Push result type in]
 740 --
 741 -- Unify with expected result before (was: after) type-checking the args
 742 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
 743 -- This is when we might detect a too-few args situation.
 744 -- (One can think of cases when the opposite order would give
 745 -- a better error message.)
 746 -- [March 2003: I'm experimenting with putting this first.  Here's an
 747 --              example where it actually makes a real difference
 748 --    class C t a b | t a -> b
 749 --    instance C Char a Bool
 750 --
 751 --    data P t a = forall b. (C t a b) => MkP b
 752 --    data Q t   = MkQ (forall a. P t a)
 753
 754 --    f1, f2 :: Q Char;
 755 --    f1 = MkQ (MkP True)
 756 --    f2 = MkQ (MkP True :: forall a. P Char a)
 757 --
 758 -- With the change, f1 will type-check, because the 'Char' info from
 759 -- the signature is propagated into MkQ's argument. With the check
 760 -- in the other order, the extra signature in f2 is reqd.]
 761
 762 ---------------------------
 763 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 764 -- Typecheck a syntax operator, checking that it has the specified type
 765 -- The operator is always a variable at this stage (i.e. renamer output)
 766 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
 767 tcSyntaxOp orig other      ty = pprPanic "tcSyntaxOp" (ppr other)
 768
 769 ---------------------------
 770 instFun :: InstOrigin
 771         -> HsExpr TcId
 772         -> TvSubst                -- The instantiating substitution
 773         -> [([TyVar], ThetaType)] -- Stuff to instantiate
 774         -> TcM (HsExpr TcId)
 775
 776 instFun orig fun subst []
 777   = return fun          -- Common short cut
 778
 779 instFun orig fun subst tv_theta_prs
 780   = do  { let ty_theta_prs' = map subst_pr tv_theta_prs
 781
 782                 -- Make two ad-hoc checks
 783         ; doStupidChecks fun ty_theta_prs'
 784
 785                 -- Now do normal instantiation
 786         ; go True fun ty_theta_prs' }
 787   where
 788     subst_pr (tvs, theta)
 789         = (map (substTyVar subst) tvs, substTheta subst theta)
 790
 791     go _ fun [] = return fun
 792
 793     go True (HsVar fun_id) ((tys,theta) : prs)
 794         | want_method_inst theta
 795         = do { meth_id <- newMethodWithGivenTy orig fun_id tys
 796              ; go False (HsVar meth_id) prs }
 797                 -- Go round with 'False' to prevent further use
 798                 -- of newMethod: see Note [Multiple instantiation]
 799
 800     go _ fun ((tys, theta) : prs)
 801         = do { co_fn <- instCall orig tys theta
 802              ; go False (HsWrap co_fn fun) prs }
 803
 804         -- See Note [No method sharing]
 805     want_method_inst theta =  not (null theta)  -- Overloaded
 806                            && not opt_NoMethodSharing
 807 \end{code}
 808
 809 Note [Multiple instantiation]
 810 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 811 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
 812 For example, consider
 813         f :: forall a. Eq a => forall b. Ord b => a -> b
 814 At a call to f, at say [Int, Bool], it's tempting to translate the call to
 815
 816         f_m1
 817   where
 818         f_m1 :: forall b. Ord b => Int -> b
 819         f_m1 = f Int dEqInt
 820
 821         f_m2 :: Int -> Bool
 822         f_m2 = f_m1 Bool dOrdBool
 823
 824 But notice that f_m2 has f_m1 as its meth_id.  Now the danger is that if we do
 825 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
 826         f_m1 = f_mx
 827 But it's entirely possible that f_m2 will continue to float out, because it
 828 mentions no type variables.  Result, f_m1 isn't in scope.
 829
 830 Here's a concrete example that does this (test tc200):
 831
 832     class C a where
 833       f :: Eq b => b -> a -> Int
 834       baz :: Eq a => Int -> a -> Int
 835
 836     instance C Int where
 837       baz = f
 838
 839 Current solution: only do the "method sharing" thing for the first type/dict
 840 application, not for the iterated ones.  A horribly subtle point.
 841
 842 Note [No method sharing]
 843 ~~~~~~~~~~~~~~~~~~~~~~~~
 844 The -fno-method-sharing flag controls what happens so far as the LIE
 845 is concerned.  The default case is that for an overloaded function we
 846 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 847 something like
 848         f :: Num a => a -> a
 849         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 850 If you specify -fno-method-sharing, the dictionary application
 851 isn't shared, so we get
 852         f :: Num a => a -> a
 853         f = /\a (d:Num a) (x:a) -> (+) a d x x
 854 This gets a bit less sharing, but
 855         a) it's better for RULEs involving overloaded functions
 856         b) perhaps fewer separated lambdas
 857
 858 \begin{code}
 859 tcArgs :: LHsExpr Name                          -- The function (for error messages)
 860        -> [LHsExpr Name] -> [TcSigmaType]       -- Actual arguments and expected arg types
 861        -> TcM [LHsExpr TcId]                    -- Resulting args
 862
 863 tcArgs fun args expected_arg_tys
 864   = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
 865
 866 tcArg :: LHsExpr Name                           -- The function (for error messages)
 867        -> (LHsExpr Name, BoxySigmaType, Int)    -- Actual argument and expected arg type
 868        -> TcM (LHsExpr TcId)                    -- Resulting argument
 869 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
 870                               tcPolyExprNC arg ty
 871 \end{code}
 872
 873
 874 Note [tagToEnum#]
 875 ~~~~~~~~~~~~~~~~~
 876 Nasty check to ensure that tagToEnum# is applied to a type that is an
 877 enumeration TyCon.  Unification may refine the type later, but this
 878 check won't see that, alas.  It's crude but it works.
 879
 880 Here's are two cases that should fail
 881         f :: forall a. a
 882         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
 883
 884         g :: Int
 885         g = tagToEnum# 0        -- Int is not an enumeration
 886
 887
 888 \begin{code}
 889 doStupidChecks :: HsExpr TcId
 890                -> [([TcType], ThetaType)]
 891                -> TcM ()
 892 -- Check two tiresome and ad-hoc cases
 893 -- (a) the "stupid theta" for a data con; add the constraints
 894 --     from the "stupid theta" of a data constructor (sigh)
 895 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
 896
 897 doStupidChecks (HsVar fun_id) ((tys,_):_)
 898   | Just con <- isDataConId_maybe fun_id   -- (a)
 899   = addDataConStupidTheta con tys
 900
 901   | fun_id `hasKey` tagToEnumKey           -- (b)
 902   = do  { tys' <- zonkTcTypes tys
 903         ; checkTc (ok tys') (tagToEnumError tys')
 904         }
 905   where
 906     ok []       = False
 907     ok (ty:tys) = case tcSplitTyConApp_maybe ty of
 908                         Just (tc,_) -> isEnumerationTyCon tc
 909                         Nothing     -> False
 910
 911 doStupidChecks fun tv_theta_prs
 912   = return () -- The common case
 913
 914
 915 tagToEnumError tys
 916   = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
 917          2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
 918                   ptext SLIT("e.g. (tagToEnum# x) :: Bool")])
 919   where
 920     at_type | null tys = empty  -- Probably never happens
 921             | otherwise = ptext SLIT("at type") <+> ppr (head tys)
 922 \end{code}
 923
 924 %************************************************************************
 925 %*                                                                      *
 926 \subsection{@tcId@ typchecks an identifier occurrence}
 927 %*                                                                      *
 928 %************************************************************************
 929
 930 \begin{code}
 931 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
 932 lookupFun orig id_name
 933   = do  { thing <- tcLookup id_name
 934         ; case thing of
 935             AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
 936                                    where
 937                                       wrap_id = dataConWrapId con
 938
 939             AGlobal (AnId id)
 940                 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
 941                 | otherwise                  -> return (HsVar id, idType id)
 942                 -- A global cannot possibly be ill-staged
 943                 -- nor does it need the 'lifting' treatment
 944
 945             ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
 946                 -> do { thLocalId orig id ty lvl
 947                       ; case mb_co of
 948                           Nothing -> return (HsVar id, ty)      -- Wobbly, or no free vars
 949                           Just co -> return (mkHsWrap co (HsVar id), ty) }
 950
 951             other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
 952     }
 953
 954 #ifndef GHCI  /* GHCI and TH is off */
 955 --------------------------------------
 956 -- thLocalId : Check for cross-stage lifting
 957 thLocalId orig id id_ty th_bind_lvl
 958   = return ()
 959
 960 #else         /* GHCI and TH is on */
 961 thLocalId orig id id_ty th_bind_lvl
 962   = do  { use_stage <- getStage -- TH case
 963         ; case use_stage of
 964             Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
 965                   -> thBrackId orig id ps_var lie_var
 966             other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
 967                         ; return id }
 968         }
 969
 970 --------------------------------------
 971 thBrackId orig id ps_var lie_var
 972   | isExternalName id_name
 973   =     -- Top-level identifiers in this module,
 974         -- (which have External Names)
 975         -- are just like the imported case:
 976         -- no need for the 'lifting' treatment
 977         -- E.g.  this is fine:
 978         --   f x = x
 979         --   g y = [| f 3 |]
 980         -- But we do need to put f into the keep-alive
 981         -- set, because after desugaring the code will
 982         -- only mention f's *name*, not f itself.
 983     do  { keepAliveTc id_name; return id }
 984
 985   | otherwise
 986   =     -- Nested identifiers, such as 'x' in
 987         -- E.g. \x -> [| h x |]
 988         -- We must behave as if the reference to x was
 989         --      h $(lift x)
 990         -- We use 'x' itself as the splice proxy, used by
 991         -- the desugarer to stitch it all back together.
 992         -- If 'x' occurs many times we may get many identical
 993         -- bindings of the same splice proxy, but that doesn't
 994         -- matter, although it's a mite untidy.
 995     do  { let id_ty = idType id
 996         ; checkTc (isTauTy id_ty) (polySpliceErr id)
 997                -- If x is polymorphic, its occurrence sites might
 998                -- have different instantiations, so we can't use plain
 999                -- 'x' as the splice proxy name.  I don't know how to
1000                -- solve this, and it's probably unimportant, so I'm
1001                -- just going to flag an error for now
1002
1003         ; id_ty' <- zapToMonotype id_ty
1004                 -- The id_ty might have an OpenTypeKind, but we
1005                 -- can't instantiate the Lift class at that kind,
1006                 -- so we zap it to a LiftedTypeKind monotype
1007                 -- C.f. the call in TcPat.newLitInst
1008
1009         ; setLIEVar lie_var     $ do
1010         { lift <- newMethodFromName orig id_ty' DsMeta.liftName
1011                    -- Put the 'lift' constraint into the right LIE
1012
1013                    -- Update the pending splices
1014         ; ps <- readMutVar ps_var
1015         ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
1016
1017         ; return id } }
1018  where
1019    id_name = idName id
1020 #endif /* GHCI */
1021 \end{code}
1022
1023
1024 %************************************************************************
1025 %*                                                                      *
1026 \subsection{Record bindings}
1027 %*                                                                      *
1028 %************************************************************************
1029
1030 Game plan for record bindings
1031 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1032 1. Find the TyCon for the bindings, from the first field label.
1033
1034 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1035
1036 For each binding field = value
1037
1038 3. Instantiate the field type (from the field label) using the type
1039    envt from step 2.
1040
1041 4  Type check the value using tcArg, passing the field type as
1042    the expected argument type.
1043
1044 This extends OK when the field types are universally quantified.
1045
1046
1047 \begin{code}
1048 tcRecordBinds
1049         :: DataCon
1050         -> [TcType]     -- Expected type for each field
1051         -> HsRecordBinds Name
1052         -> TcM (HsRecordBinds TcId)
1053
1054 tcRecordBinds data_con arg_tys rbinds
1055   = do  { mb_binds <- mappM do_bind rbinds
1056         ; return (catMaybes mb_binds) }
1057   where
1058     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1059     do_bind (L loc field_lbl, rhs)
1060       | Just field_ty <- assocMaybe flds_w_tys field_lbl
1061       = addErrCtxt (fieldCtxt field_lbl)        $
1062         do { rhs'   <- tcPolyExprNC rhs field_ty
1063            ; sel_id <- tcLookupField field_lbl
1064            ; ASSERT( isRecordSelector sel_id )
1065              return (Just (L loc sel_id, rhs')) }
1066       | otherwise
1067       = do { addErrTc (badFieldCon data_con field_lbl)
1068            ; return Nothing }
1069
1070 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1071 checkMissingFields data_con rbinds
1072   | null field_labels   -- Not declared as a record;
1073                         -- But C{} is still valid if no strict fields
1074   = if any isMarkedStrict field_strs then
1075         -- Illegal if any arg is strict
1076         addErrTc (missingStrictFields data_con [])
1077     else
1078         returnM ()
1079
1080   | otherwise           -- A record
1081   = checkM (null missing_s_fields)
1082            (addErrTc (missingStrictFields data_con missing_s_fields))   `thenM_`
1083
1084     doptM Opt_WarnMissingFields         `thenM` \ warn ->
1085     checkM (not (warn && notNull missing_ns_fields))
1086            (warnTc True (missingFields data_con missing_ns_fields))
1087
1088   where
1089     missing_s_fields
1090         = [ fl | (fl, str) <- field_info,
1091                  isMarkedStrict str,
1092                  not (fl `elem` field_names_used)
1093           ]
1094     missing_ns_fields
1095         = [ fl | (fl, str) <- field_info,
1096                  not (isMarkedStrict str),
1097                  not (fl `elem` field_names_used)
1098           ]
1099
1100     field_names_used = recBindFields rbinds
1101     field_labels     = dataConFieldLabels data_con
1102
1103     field_info = zipEqual "missingFields"
1104                           field_labels
1105                           field_strs
1106
1107     field_strs = dataConStrictMarks data_con
1108 \end{code}
1109
1110 %************************************************************************
1111 %*                                                                      *
1112 \subsection{Errors and contexts}
1113 %*                                                                      *
1114 %************************************************************************
1115
1116 Boring and alphabetical:
1117 \begin{code}
1118 caseScrutCtxt expr
1119   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1120
1121 exprCtxt expr
1122   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
1123
1124 fieldCtxt field_name
1125   = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
1126
1127 funAppCtxt fun arg arg_no
1128   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1129                     quotes (ppr fun) <> text ", namely"])
1130          4 (quotes (ppr arg))
1131
1132 predCtxt expr
1133   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1134
1135 nonVanillaUpd tycon
1136   = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
1137                 <+> ptext SLIT("is not (yet) supported"),
1138           ptext SLIT("Use pattern-matching instead")]
1139 badFieldsUpd rbinds
1140   = hang (ptext SLIT("No constructor has all these fields:"))
1141          4 (pprQuotedList (recBindFields rbinds))
1142
1143 naughtyRecordSel sel_id
1144   = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
1145     ptext SLIT("as a function due to escaped type variables") $$
1146     ptext SLIT("Probably fix: use pattern-matching syntax instead")
1147
1148 notSelector field
1149   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1150
1151 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1152 missingStrictFields con fields
1153   = header <> rest
1154   where
1155     rest | null fields = empty  -- Happens for non-record constructors
1156                                 -- with strict fields
1157          | otherwise   = colon <+> pprWithCommas ppr fields
1158
1159     header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
1160              ptext SLIT("does not have the required strict field(s)")
1161
1162 missingFields :: DataCon -> [FieldLabel] -> SDoc
1163 missingFields con fields
1164   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
1165         <+> pprWithCommas ppr fields
1166
1167 callCtxt fun args
1168   = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
1169
1170 #ifdef GHCI
1171 polySpliceErr :: Id -> SDoc
1172 polySpliceErr id
1173   = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
1174 #endif
1175 \end{code}