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