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