compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[TcExpr]{Typecheck an expression}
   6
   7 \begin{code}
   8 {-# OPTIONS -w #-}
   9 -- The above warning supression flag is a temporary kludge.
  10 -- While working on this module you are encouraged to remove it and fix
  11 -- any warnings in the module. See
  12 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  13 -- for details
  14
  15 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
  16                 tcInferRho, tcInferRhoNC, tcSyntaxOp,
  17                 addExprErrCtxt ) where
  18
  19 #include "HsVersions.h"
  20
  21 #ifdef GHCI     /* Only if bootstrapped */
  22 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcBracket )
  23 import qualified DsMeta
  24 #endif
  25
  26 import HsSyn
  27 import TcHsSyn
  28 import TcRnMonad
  29 import TcUnify
  30 import BasicTypes
  31 import Inst
  32 import TcBinds
  33 import TcEnv
  34 import TcArrows
  35 import TcMatches
  36 import TcHsType
  37 import TcPat
  38 import TcMType
  39 import TcType
  40 import TcIface  ( checkWiredInTyCon )
  41 import Id
  42 import DataCon
  43 import Name
  44 import TyCon
  45 import Type
  46 import TypeRep
  47 import Coercion
  48 import Var
  49 import VarSet
  50 import TysWiredIn
  51 import PrelNames
  52 import PrimOp
  53 import DynFlags
  54 import StaticFlags
  55 import HscTypes
  56 import SrcLoc
  57 import Util
  58 import ListSetOps
  59 import Maybes
  60 import Outputable
  61 import FastString
  62
  63 import Data.List( partition )
  64 import Control.Monad
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection{Main wrappers}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 tcPolyExpr, tcPolyExprNC
  75          :: LHsExpr Name                -- Expession to type check
  76          -> BoxySigmaType               -- Expected type (could be a polytpye)
  77          -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
  78
  79 -- tcPolyExpr is a convenient place (frequent but not too frequent) place
  80 -- to add context information.
  81 -- The NC version does not do so, usually because the caller wants
  82 -- to do so himself.
  83
  84 tcPolyExpr expr res_ty
  85   = addExprErrCtxt expr $
  86     (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
  87
  88 tcPolyExprNC expr res_ty
  89   | isSigmaTy res_ty
  90   = do  { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
  91         ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing $ \ _ res_ty ->
  92                              tcPolyExprNC expr res_ty
  93                 -- Note the recursive call to tcPolyExpr, because the
  94                 -- type may have multiple layers of for-alls
  95                 -- E.g. forall a. Eq a => forall b. Ord b => ....
  96         ; return (mkLHsWrap gen_fn expr') }
  97
  98   | otherwise
  99   = tcMonoExprNC expr res_ty
 100
 101 ---------------
 102 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
 103 tcPolyExprs [] [] = return []
 104 tcPolyExprs (expr:exprs) (ty:tys)
 105  = do   { expr'  <- tcPolyExpr  expr  ty
 106         ; exprs' <- tcPolyExprs exprs tys
 107         ; return (expr':exprs') }
 108 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
 109
 110 ---------------
 111 tcMonoExpr, tcMonoExprNC
 112     :: LHsExpr Name     -- Expression to type check
 113     -> BoxyRhoType      -- Expected type (could be a type variable)
 114                         -- Definitely no foralls at the top
 115                         -- Can contain boxes, which will be filled in
 116     -> TcM (LHsExpr TcId)
 117
 118 tcMonoExpr expr res_ty
 119   = addErrCtxt (exprCtxt expr) $
 120     tcMonoExprNC expr res_ty
 121
 122 tcMonoExprNC (L loc expr) res_ty
 123   = ASSERT( not (isSigmaTy res_ty) )
 124     setSrcSpan loc $
 125     do  { expr' <- tcExpr expr res_ty
 126         ; return (L loc expr') }
 127
 128 ---------------
 129 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 130 tcInferRho   expr = tcInfer (tcMonoExpr expr)
 131 tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137         tcExpr: the main expression typechecker
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
 143 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty     -- Sanity check
 144                 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
 145
 146 tcExpr (HsVar name)     res_ty = tcId (OccurrenceOf name) name res_ty
 147
 148 tcExpr (HsLit lit)      res_ty = do { let lit_ty = hsLitType lit
 149                                     ; coi <- boxyUnify lit_ty res_ty
 150                                     ; return $ mkHsWrapCoI coi (HsLit lit)
 151                                     }
 152
 153 tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExprNC expr res_ty
 154                                     ; return (HsPar expr') }
 155
 156 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
 157                                     ; return (HsSCC lbl expr') }
 158 tcExpr (HsTickPragma info expr) res_ty
 159                                = do { expr' <- tcMonoExpr expr res_ty
 160                                     ; return (HsTickPragma info 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 NegateOrigin 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  { let origin = IPOccOrigin ip
 178                 -- Implicit parameters must have a *tau-type* not a
 179                 -- type scheme.  We enforce this by creating a fresh
 180                 -- type variable as its type.  (Because res_ty may not
 181                 -- be a tau-type.)
 182         ; ip_ty <- newFlexiTyVarTy argTypeKind  -- argTypeKind: it can't be an unboxed tuple
 183         ; co_fn <- tcSubExp origin ip_ty res_ty
 184         ; (ip', inst) <- newIPDict origin ip ip_ty
 185         ; extendLIE inst
 186         ; return (mkHsWrap co_fn (HsIPVar ip')) }
 187
 188 tcExpr (HsApp e1 e2) res_ty
 189   = go e1 [e2]
 190   where
 191     go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
 192     go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
 193     go lfun@(L loc fun) args
 194         = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
 195                                 tcApp fun (length args) (tcArgs lfun args) res_ty
 196              ; traceTc (text "tcExpr args': " <+> ppr args')
 197              ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
 198
 199 tcExpr (HsLam match) res_ty
 200   = do  { (co_fn, match') <- tcMatchLambda match res_ty
 201         ; return (mkHsWrap co_fn (HsLam match')) }
 202
 203 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
 204  = do   { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 205
 206         -- Remember to extend the lexical type-variable environment
 207         ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ skol_tvs res_ty ->
 208                              tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
 209                                 -- See Note [More instantiated than scoped] in TcBinds
 210                              tcMonoExprNC expr res_ty
 211
 212         ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
 213         ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
 214
 215 tcExpr (HsType ty) res_ty
 216   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 217         -- This is the syntax for type applications that I was planning
 218         -- but there are difficulties (e.g. what order for type args)
 219         -- so it's not enabled yet.
 220         -- Can't eliminate it altogether from the parser, because the
 221         -- same parser parses *patterns*.
 222 \end{code}
 223
 224
 225 %************************************************************************
 226 %*                                                                      *
 227                 Infix operators and sections
 228 %*                                                                      *
 229 %************************************************************************
 230
 231 \begin{code}
 232 tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
 233   = do  { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
 234         ; return (OpApp arg1' (L loc op') fix arg2') }
 235
 236 -- Left sections, equivalent to
 237 --      \ x -> e op x,
 238 -- or
 239 --      \ x -> op e x,
 240 -- or, if PostfixOperators is enabled, just
 241 --      op e
 242 --
 243 -- With PostfixOperators we don't
 244 -- actually require the function to take two arguments
 245 -- at all.  For example, (x `not`) means (not x);
 246 -- you get postfix operators!  Not Haskell 98,
 247 -- but it's less work and kind of useful.
 248
 249 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 250   = do { dflags <- getDOpts
 251        ; if dopt Opt_PostfixOperators dflags
 252          then do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
 253                  ; return (SectionL arg1' (L loc op')) }
 254          else do
 255        { (co_fn, expr')
 256              <- subFunTys doc 1 res_ty Nothing $ \ [arg2_ty'] res_ty' ->
 257                 do { (op', (arg1', co_arg2)) <- tcApp op 2 (tc_args arg2_ty') res_ty'
 258                    ; let coi = mkFunTyCoI arg2_ty' co_arg2 res_ty' IdCo
 259                    ; return (mkHsWrapCoI coi (SectionL arg1' (L loc op'))) }
 260        ; return (mkHsWrap co_fn expr') } }
 261   where
 262     doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
 263                 <+> ptext (sLit "takes one argument")
 264     tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty]
 265         = do { co_arg2 <- boxyUnify (substTyWith qtvs qtys arg2_ty) arg2_ty'
 266              ; arg1'   <- tcArg lop 1 arg1 qtvs qtys arg1_ty
 267              ; qtys'   <- mapM refineBox qtys   -- c.f. tcArgs
 268              ; return (qtys', (arg1', co_arg2)) }
 269     tc_args _ _ _ _ = panic "tcExpr SectionL"
 270
 271 -- Right sections, equivalent to \ x -> x `op` expr, or
 272 --      \ x -> op x expr
 273
 274 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
 275   = do  { (co_fn, expr')
 276               <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
 277                  do { (op', (co_arg1, arg2')) <- tcApp op 2 (tc_args arg1_ty') res_ty'
 278                     ; let coi = mkFunTyCoI arg1_ty' co_arg1 res_ty' IdCo
 279                     ; return (mkHsWrapCoI coi $ SectionR (L loc op') arg2') }
 280         ; return (mkHsWrap co_fn expr') }
 281   where
 282     doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
 283                 <+> ptext (sLit "takes one argument")
 284     tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty]
 285         = do { co_arg1 <- boxyUnify (substTyWith qtvs qtys arg1_ty) arg1_ty'
 286              ; arg2'   <- tcArg lop 2 arg2 qtvs qtys arg2_ty
 287              ; qtys'   <- mapM refineBox qtys   -- c.f. tcArgs
 288              ; return (qtys', (co_arg1, arg2')) }
 289     tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
 290
 291 -- For tuples, take care to preserve rigidity
 292 -- E.g.         case (x,y) of ....
 293 --         The scrutinee should have a rigid type if x,y do
 294 -- The general scheme is the same as in tcIdApp
 295 tcExpr in_expr@(ExplicitTuple tup_args boxity) res_ty
 296   = do { let kind = case boxity of { Boxed   -> liftedTypeKind
 297                                    ; Unboxed -> argTypeKind }
 298              arity = length tup_args
 299              tup_tc = tupleTyCon boxity arity
 300              mk_tup_res_ty arg_tys
 301                  = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
 302                             (mkTyConApp tup_tc arg_tys)
 303
 304        ; checkWiredInTyCon tup_tc       -- Ensure instances are available
 305        ; tvs <- newBoxyTyVars (replicate arity kind)
 306        ; let arg_tys1 = map mkTyVarTy tvs
 307        ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty
 308
 309        ; let go (Missing _,    arg_ty) = return (Missing arg_ty)
 310              go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
 311                                             ; return (Present expr') }
 312        ; tup_args' <- mapM go (tup_args `zip` arg_tys2)
 313
 314        ; arg_tys3 <- mapM refineBox arg_tys2
 315        ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty
 316        ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) }
 317 \end{code}
 318
 319 \begin{code}
 320 tcExpr (HsLet binds expr) res_ty
 321   = do  { (binds', expr') <- tcLocalBinds binds $
 322                              tcMonoExpr expr res_ty
 323         ; return (HsLet binds' expr') }
 324
 325 tcExpr (HsCase scrut matches) exp_ty
 326   = do  {  -- We used to typecheck the case alternatives first.
 327            -- The case patterns tend to give good type info to use
 328            -- when typechecking the scrutinee.  For example
 329            --   case (map f) of
 330            --     (x:xs) -> ...
 331            -- will report that map is applied to too few arguments
 332            --
 333            -- But now, in the GADT world, we need to typecheck the scrutinee
 334            -- first, to get type info that may be refined in the case alternatives
 335           (scrut', scrut_ty) <- tcInferRho scrut
 336
 337         ; traceTc (text "HsCase" <+> ppr scrut_ty)
 338         ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
 339         ; return (HsCase scrut' matches') }
 340  where
 341     match_ctxt = MC { mc_what = CaseAlt,
 342                       mc_body = tcBody }
 343
 344 tcExpr (HsIf pred b1 b2) res_ty
 345   = do  { pred' <- tcMonoExpr pred boolTy
 346         ; b1' <- tcMonoExpr b1 res_ty
 347         ; b2' <- tcMonoExpr b2 res_ty
 348         ; return (HsIf pred' b1' b2') }
 349
 350 tcExpr (HsDo do_or_lc stmts body _) res_ty
 351   = tcDoStmts do_or_lc stmts body res_ty
 352
 353 tcExpr in_expr@(ExplicitList _ exprs) res_ty
 354   = do  { (elt_ty, coi) <- boxySplitListTy res_ty
 355         ; exprs' <- mapM (tc_elt elt_ty) exprs
 356         ; when (null exprs) (zapToMonotype elt_ty >> return ())
 357                 -- If there are no expressions in the comprehension
 358                 -- we must still fill in the box
 359                 --
 360                 -- The GHC front end never generates an empty ExplicitList
 361                 -- (instead it generates the [] data constructor) but
 362                 -- Template Haskell might.  We could fix the bit of
 363                 -- TH that generates ExplicitList, but it seems less
 364                 -- fragile to just handle the case here.
 365         ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
 366   where
 367     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 368
 369 tcExpr in_expr@(ExplicitPArr _ exprs) res_ty    -- maybe empty
 370   = do  { (elt_ty, coi) <- boxySplitPArrTy res_ty
 371         ; exprs' <- mapM (tc_elt elt_ty) exprs
 372         ; when (null exprs) (zapToMonotype elt_ty >> return ())
 373                 -- If there are no expressions in the comprehension
 374                 -- we must still fill in the box
 375                 -- (Not needed for [] and () becuase they happen
 376                 --  to parse as data constructors.)
 377         ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
 378   where
 379     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 380
 381 tcExpr (HsProc pat cmd) res_ty
 382   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
 383         ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
 384
 385 tcExpr e@(HsArrApp _ _ _ _ _) _
 386   = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
 387                       ptext (sLit "was found where an expression was expected")])
 388
 389 tcExpr e@(HsArrForm _ _ _) _
 390   = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
 391                       ptext (sLit "was found where an expression was expected")])
 392 \end{code}
 393
 394 %************************************************************************
 395 %*                                                                      *
 396                 Record construction and update
 397 %*                                                                      *
 398 %************************************************************************
 399
 400 \begin{code}
 401 tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
 402   = do  { data_con <- tcLookupDataCon con_name
 403
 404         -- Check for missing fields
 405         ; checkMissingFields data_con rbinds
 406
 407         ; let arity = dataConSourceArity data_con
 408               check_fields qtvs qtys arg_tys
 409                   = do  { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
 410                         ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
 411                         ; qtys' <- mapM refineBoxToTau qtys
 412                         ; return (qtys', rbinds') }
 413                 -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
 414                 -- filled, which is the invariant expected by tcIdApp
 415                 -- How could this not be the case?  Consider a record construction
 416                 -- that does not mention all the fields.
 417
 418         ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
 419
 420         ; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
 421 \end{code}
 422
 423 Note [Type of a record update]
 424 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 425 The main complication with RecordUpd is that we need to explicitly
 426 handle the *non-updated* fields.  Consider:
 427
 428         data T a b c = MkT1 { fa :: a, fb :: (b,c) }
 429                      | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
 430                      | MkT3 { fd :: a }
 431
 432         upd :: T a b c -> (b',c) -> T a b' c
 433         upd t x = t { fb = x}
 434
 435 The result type should be (T a b' c)
 436 not (T a b c),   because 'b' *is not* mentioned in a non-updated field
 437 not (T a b' c'), becuase 'c' *is*     mentioned in a non-updated field
 438 NB that it's not good enough to look at just one constructor; we must
 439 look at them all; cf Trac #3219
 440
 441 After all, upd should be equivalent to:
 442         upd t x = case t of
 443                         MkT1 p q -> MkT1 p x
 444                         MkT2 a b -> MkT2 p b
 445                         MkT3 d   -> error ...
 446
 447 So we need to give a completely fresh type to the result record,
 448 and then constrain it by the fields that are *not* updated ("p" above).
 449 We call these the "fixed" type variables, and compute them in getFixedTyVars.
 450
 451 Note that because MkT3 doesn't contain all the fields being updated,
 452 its RHS is simply an error, so it doesn't impose any type constraints.
 453 Hence the use of 'relevant_cont'.
 454
 455 Note [Implict type sharing]
 456 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 457 We also take into account any "implicit" non-update fields.  For example
 458         data T a b where { MkT { f::a } :: T a a; ... }
 459 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
 460
 461 Then consider
 462         upd t x = t { f=x }
 463 We infer the type
 464         upd :: T a b -> a -> T a b
 465         upd (t::T a b) (x::a)
 466            = case t of { MkT (co:a~b) (_:a) -> MkT co x }
 467 We can't give it the more general type
 468         upd :: T a b -> c -> T c b
 469
 470 Note [Criteria for update]
 471 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 472 We want to allow update for existentials etc, provided the updated
 473 field isn't part of the existential. For example, this should be ok.
 474   data T a where { MkT { f1::a, f2::b->b } :: T a }
 475   f :: T a -> b -> T b
 476   f t b = t { f1=b }
 477
 478 The criterion we use is this:
 479
 480   The types of the updated fields
 481   mention only the universally-quantified type variables
 482   of the data constructor
 483
 484 NB: this is not (quite) the same as being a "naughty" record selector
 485 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
 486 in the case of GADTs. Consider
 487    data T a where { MkT :: { f :: a } :: T [a] }
 488 Then f is not "naughty" because it has a well-typed record selector.
 489 But we don't allow updates for 'f'.  (One could consider trying to
 490 allow this, but it makes my head hurt.  Badly.  And no one has asked
 491 for it.)
 492
 493 In principle one could go further, and allow
 494   g :: T a -> T a
 495   g t = t { f2 = \x -> x }
 496 because the expression is polymorphic...but that seems a bridge too far.
 497
 498 Note [Data family example]
 499 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 500     data instance T (a,b) = MkT { x::a, y::b }
 501   --->
 502     data :TP a b = MkT { a::a, y::b }
 503     coTP a b :: T (a,b) ~ :TP a b
 504
 505 Suppose r :: T (t1,t2), e :: t3
 506 Then  r { x=e } :: T (t3,t1)
 507   --->
 508       case r |> co1 of
 509         MkT x y -> MkT e y |> co2
 510       where co1 :: T (t1,t2) ~ :TP t1 t2
 511             co2 :: :TP t3 t2 ~ T (t3,t2)
 512 The wrapping with co2 is done by the constructor wrapper for MkT
 513
 514 Outgoing invariants
 515 ~~~~~~~~~~~~~~~~~~~
 516 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
 517
 518   * cons are the data constructors to be updated
 519
 520   * in_inst_tys, out_inst_tys have same length, and instantiate the
 521         *representation* tycon of the data cons.  In Note [Data
 522         family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
 523
 524 \begin{code}
 525 tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
 526   = ASSERT( notNull upd_fld_names )
 527     do  {
 528         -- STEP 0
 529         -- Check that the field names are really field names
 530         ; sel_ids <- mapM tcLookupField upd_fld_names
 531                         -- The renamer has already checked that
 532                         -- selectors are all in scope
 533         ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
 534                          | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
 535                            not (isRecordSelector sel_id),       -- Excludes class ops
 536                            let L loc fld_name = hsRecFieldId fld ]
 537         ; unless (null bad_guys) (sequence bad_guys >> failM)
 538
 539         -- STEP 1
 540         -- Figure out the tycon and data cons from the first field name
 541         ; let   -- It's OK to use the non-tc splitters here (for a selector)
 542               sel_id : _  = sel_ids
 543               (tycon, _)  = recordSelectorFieldLabel sel_id     -- We've failed already if
 544               data_cons   = tyConDataCons tycon                 -- it's not a field label
 545                 -- NB: for a data type family, the tycon is the instance tycon
 546
 547               relevant_cons   = filter is_relevant data_cons
 548               is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
 549                 -- A constructor is only relevant to this process if
 550                 -- it contains *all* the fields that are being updated
 551                 -- Other ones will cause a runtime error if they occur
 552
 553                 -- Take apart a representative constructor
 554               con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
 555               (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
 556               con1_flds = dataConFieldLabels con1
 557               con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
 558
 559         -- Step 2
 560         -- Check that at least one constructor has all the named fields
 561         -- i.e. has an empty set of bad fields returned by badFields
 562         ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
 563
 564         -- STEP 3    Note [Criteria for update]
 565         -- Check that each updated field is polymorphic; that is, its type
 566         -- mentions only the universally-quantified variables of the data con
 567         ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
 568               (upd_flds1_w_tys, fixed_flds1_w_tys) = partition is_updated flds1_w_tys
 569               is_updated (fld,ty) = fld `elem` upd_fld_names
 570
 571               bad_upd_flds = filter bad_fld upd_flds1_w_tys
 572               con1_tv_set = mkVarSet con1_tvs
 573               bad_fld (fld, ty) = fld `elem` upd_fld_names &&
 574                                       not (tyVarsOfType ty `subVarSet` con1_tv_set)
 575         ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
 576
 577         -- STEP 4  Note [Type of a record update]
 578         -- Figure out types for the scrutinee and result
 579         -- Both are of form (T a b c), with fresh type variables, but with
 580         -- common variables where the scrutinee and result must have the same type
 581         -- These are variables that appear in *any* arg of *any* of the
 582         -- relevant constructors *except* in the updated fields
 583         --
 584         ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
 585               is_fixed_tv tv = tv `elemVarSet` fixed_tvs
 586               mk_inst_ty tv result_inst_ty
 587                 | is_fixed_tv tv = return result_inst_ty            -- Same as result type
 588                 | otherwise      = newFlexiTyVarTy (tyVarKind tv)  -- Fresh type, of correct kind
 589
 590         ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
 591         ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
 592
 593         ; let result_ty     = substTy result_inst_env con1_res_ty
 594               con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
 595               scrut_subst   = zipTopTvSubst con1_tvs scrut_inst_tys
 596               scrut_ty      = substTy scrut_subst con1_res_ty
 597
 598         -- STEP 5
 599         -- Typecheck the thing to be updated, and the bindings
 600         ; record_expr' <- tcMonoExpr record_expr scrut_ty
 601         ; rbinds'      <- tcRecordBinds con1 con1_arg_tys' rbinds
 602
 603         ; let origin = RecordUpdOrigin
 604         ; co_fn <- tcSubExp origin result_ty res_ty
 605
 606         -- STEP 6: Deal with the stupid theta
 607         ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
 608         ; instStupidTheta origin theta'
 609
 610         -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
 611         ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
 612                        = WpCast $ mkTyConApp co_con scrut_inst_tys
 613                        | otherwise
 614                        = idHsWrapper
 615
 616         -- Phew!
 617         ; return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
 618                                         relevant_cons scrut_inst_tys result_inst_tys)) }
 619   where
 620     upd_fld_names = hsRecFields rbinds
 621
 622     getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
 623     -- These tyvars must not change across the updates
 624     getFixedTyVars tvs1 cons
 625       = mkVarSet [tv1 | con <- cons
 626                       , let (tvs, theta, arg_tys, _) = dataConSig con
 627                             flds = dataConFieldLabels con
 628                             fixed_tvs = exactTyVarsOfTypes fixed_tys
 629                                     -- fixed_tys: See Note [Type of a record update]
 630                                         `unionVarSet` tyVarsOfTheta theta
 631                                     -- Universally-quantified tyvars that
 632                                     -- appear in any of the *implicit*
 633                                     -- arguments to the constructor are fixed
 634                                     -- See Note [Implict type sharing]
 635
 636                             fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
 637                                             , not (fld `elem` upd_fld_names)]
 638                       , (tv1,tv) <- tvs1 `zip` tvs      -- Discards existentials in tvs
 639                       , tv `elemVarSet` fixed_tvs ]
 640 \end{code}
 641
 642 %************************************************************************
 643 %*                                                                      *
 644         Arithmetic sequences                    e.g. [a,b..]
 645         and their parallel-array counterparts   e.g. [: a,b.. :]
 646
 647 %*                                                                      *
 648 %************************************************************************
 649
 650 \begin{code}
 651 tcExpr (ArithSeq _ seq@(From expr)) res_ty
 652   = do  { (elt_ty, coi) <- boxySplitListTy res_ty
 653         ; expr' <- tcPolyExpr expr elt_ty
 654         ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
 655                               elt_ty enumFromName
 656         ; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) }
 657
 658 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
 659   = do  { (elt_ty, coi) <- boxySplitListTy res_ty
 660         ; expr1' <- tcPolyExpr expr1 elt_ty
 661         ; expr2' <- tcPolyExpr expr2 elt_ty
 662         ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
 663                               elt_ty enumFromThenName
 664         ; return $ mkHsWrapCoI coi
 665                     (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
 666
 667 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
 668   = do  { (elt_ty, coi) <- boxySplitListTy res_ty
 669         ; expr1' <- tcPolyExpr expr1 elt_ty
 670         ; expr2' <- tcPolyExpr expr2 elt_ty
 671         ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
 672                               elt_ty enumFromToName
 673         ; return $ mkHsWrapCoI coi
 674                      (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
 675
 676 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 677   = do  { (elt_ty, coi) <- boxySplitListTy res_ty
 678         ; expr1' <- tcPolyExpr expr1 elt_ty
 679         ; expr2' <- tcPolyExpr expr2 elt_ty
 680         ; expr3' <- tcPolyExpr expr3 elt_ty
 681         ; eft <- newMethodFromName (ArithSeqOrigin seq)
 682                       elt_ty enumFromThenToName
 683         ; return $ mkHsWrapCoI coi
 684                      (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
 685
 686 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
 687   = do  { (elt_ty, coi) <- boxySplitPArrTy res_ty
 688         ; expr1' <- tcPolyExpr expr1 elt_ty
 689         ; expr2' <- tcPolyExpr expr2 elt_ty
 690         ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
 691                                       elt_ty enumFromToPName
 692         ; return $ mkHsWrapCoI coi
 693                      (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
 694
 695 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 696   = do  { (elt_ty, coi) <- boxySplitPArrTy res_ty
 697         ; expr1' <- tcPolyExpr expr1 elt_ty
 698         ; expr2' <- tcPolyExpr expr2 elt_ty
 699         ; expr3' <- tcPolyExpr expr3 elt_ty
 700         ; eft <- newMethodFromName (PArrSeqOrigin seq)
 701                       elt_ty enumFromThenToPName
 702         ; return $ mkHsWrapCoI coi
 703                      (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
 704
 705 tcExpr (PArrSeq _ _) _
 706   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 707     -- the parser shouldn't have generated it and the renamer shouldn't have
 708     -- let it through
 709 \end{code}
 710
 711
 712 %************************************************************************
 713 %*                                                                      *
 714                 Template Haskell
 715 %*                                                                      *
 716 %************************************************************************
 717
 718 \begin{code}
 719 #ifdef GHCI     /* Only if bootstrapped */
 720         -- Rename excludes these cases otherwise
 721 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 722 tcExpr (HsBracket brack)  res_ty = do   { e <- tcBracket brack res_ty
 723                                         ; return (unLoc e) }
 724 tcExpr e@(HsQuasiQuoteE _) res_ty =
 725     pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
 726 #endif /* GHCI */
 727 \end{code}
 728
 729
 730 %************************************************************************
 731 %*                                                                      *
 732                 Catch-all
 733 %*                                                                      *
 734 %************************************************************************
 735
 736 \begin{code}
 737 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 738 \end{code}
 739
 740
 741 %************************************************************************
 742 %*                                                                      *
 743                 Applications
 744 %*                                                                      *
 745 %************************************************************************
 746
 747 \begin{code}
 748 ---------------------------
 749 tcApp :: HsExpr Name                            -- Function
 750       -> Arity                                  -- Number of args reqd
 751       -> ArgChecker results
 752       -> BoxyRhoType                            -- Result type
 753       -> TcM (HsExpr TcId, results)
 754
 755 -- (tcFun fun n_args arg_checker res_ty)
 756 -- The argument type checker, arg_checker, will be passed exactly n_args types
 757
 758 tcApp (HsVar fun_name) n_args arg_checker res_ty
 759   = tcIdApp fun_name n_args arg_checker res_ty
 760
 761 tcApp fun n_args arg_checker res_ty     -- The vanilla case (rula APP)
 762   = do  { arg_boxes  <- newBoxyTyVars (replicate n_args argTypeKind)
 763         ; fun'       <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
 764         ; arg_tys'   <- mapM readFilledBox arg_boxes
 765         ; (_, args') <- arg_checker [] [] arg_tys'      -- Yuk
 766         ; return (fun', args') }
 767
 768 ---------------------------
 769 tcIdApp :: Name                                 -- Function
 770         -> Arity                                -- Number of args reqd
 771         -> ArgChecker results   -- The arg-checker guarantees to fill all boxes in the arg types
 772         -> BoxyRhoType                          -- Result type
 773         -> TcM (HsExpr TcId, results)
 774
 775 -- Call         (f e1 ... en) :: res_ty
 776 -- Type         f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
 777 --                      (where k <= n; fres has the rest)
 778 -- NB:  if k < n then the function doesn't have enough args, and
 779 --      presumably fres is a type variable that we are going to
 780 --      instantiate with a function type
 781 --
 782 -- Then         fres <= bx_(k+1) -> ... -> bx_n -> res_ty
 783
 784 tcIdApp fun_name n_args arg_checker res_ty
 785   = do  { let orig = OccurrenceOf fun_name
 786         ; (fun, fun_ty) <- lookupFun orig fun_name
 787
 788         -- Split up the function type
 789         ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
 790               (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
 791
 792               qtvs = concatMap fst tv_theta_prs         -- Quantified tyvars
 793               arg_qtvs = exactTyVarsOfTypes fun_arg_tys
 794               res_qtvs = exactTyVarsOfType fun_res_ty
 795                 -- NB: exactTyVarsOfType.  See Note [Silly type synonyms in smart-app]
 796               tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
 797               k              = length fun_arg_tys       -- k <= n_args
 798               n_missing_args = n_args - k               -- Always >= 0
 799
 800         -- Match the result type of the function with the
 801         -- result type of the context, to get an inital substitution
 802         ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
 803         ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
 804               res_ty'        = mkFunTys extra_arg_tys' res_ty
 805         ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
 806
 807         -- Typecheck the arguments!
 808         -- Doing so will fill arg_qtvs and extra_arg_tys'
 809         ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
 810
 811         -- Strip boxes from the qtvs that have been filled in by the arg checking
 812         ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
 813
 814         -- Result subsumption
 815         -- This fills in res_qtvs
 816         ; let res_subst = zipOpenTvSubst qtvs qtys''
 817               fun_res_ty'' = substTy res_subst fun_res_ty
 818               res_ty'' = mkFunTys extra_arg_tys'' res_ty
 819         ; co_fn <- tcSubExp orig fun_res_ty'' res_ty''
 820
 821         -- And pack up the results
 822         -- By applying the coercion just to the *function* we can make
 823         -- tcFun work nicely for OpApp and Sections too
 824         ; fun' <- instFun orig fun res_subst tv_theta_prs
 825         ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
 826         ; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun')
 827         ; return (mkHsWrap co_fn' fun', args') }
 828 \end{code}
 829
 830 Note [Silly type synonyms in smart-app]
 831 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 832 When we call sripBoxyType, all of the boxes should be filled
 833 in.  But we need to be careful about type synonyms:
 834         type T a = Int
 835         f :: T a -> Int
 836         ...(f x)...
 837 In the call (f x) we'll typecheck x, expecting it to have type
 838 (T box).  Usually that would fill in the box, but in this case not;
 839 because 'a' is discarded by the silly type synonym T.  So we must
 840 use exactTyVarsOfType to figure out which type variables are free
 841 in the argument type.
 842
 843 \begin{code}
 844 -- tcId is a specialisation of tcIdApp when there are no arguments
 845 -- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
 846 --                ; return res }
 847
 848 tcId :: InstOrigin
 849      -> Name                                    -- Function
 850      -> BoxyRhoType                             -- Result type
 851      -> TcM (HsExpr TcId)
 852 tcId orig fun_name res_ty
 853   = do  { (fun, fun_ty) <- lookupFun orig fun_name
 854         ; traceTc (text "tcId" <+> ppr fun_name <+> (ppr fun_ty $$ ppr res_ty))
 855
 856         -- Split up the function type
 857         ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
 858               qtvs = concatMap fst tv_theta_prs         -- Quantified tyvars
 859               tau_qtvs = exactTyVarsOfType fun_tau      -- Mentioned in the tau part
 860         ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
 861
 862         -- Do the subsumption check wrt the result type
 863         ; let res_subst = zipTopTvSubst qtvs qtv_tys
 864               fun_tau'  = substTy res_subst fun_tau
 865
 866         ; traceTc (text "tcId2" <+> ppr fun_name <+> (ppr qtvs $$ ppr qtv_tys))
 867
 868         ; co_fn <- tcSubExp orig fun_tau' res_ty
 869
 870         -- And pack up the results
 871         ; fun' <- instFun orig fun res_subst tv_theta_prs
 872         ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun'))
 873         ; return (mkHsWrap co_fn fun') }
 874
 875 --      Note [Push result type in]
 876 --
 877 -- Unify with expected result before (was: after) type-checking the args
 878 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
 879 -- This is when we might detect a too-few args situation.
 880 -- (One can think of cases when the opposite order would give
 881 -- a better error message.)
 882 -- [March 2003: I'm experimenting with putting this first.  Here's an
 883 --              example where it actually makes a real difference
 884 --    class C t a b | t a -> b
 885 --    instance C Char a Bool
 886 --
 887 --    data P t a = forall b. (C t a b) => MkP b
 888 --    data Q t   = MkQ (forall a. P t a)
 889
 890 --    f1, f2 :: Q Char;
 891 --    f1 = MkQ (MkP True)
 892 --    f2 = MkQ (MkP True :: forall a. P Char a)
 893 --
 894 -- With the change, f1 will type-check, because the 'Char' info from
 895 -- the signature is propagated into MkQ's argument. With the check
 896 -- in the other order, the extra signature in f2 is reqd.]
 897
 898 ---------------------------
 899 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 900 -- Typecheck a syntax operator, checking that it has the specified type
 901 -- The operator is always a variable at this stage (i.e. renamer output)
 902 -- This version assumes ty is a monotype
 903 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
 904 tcSyntaxOp orig other      ty = pprPanic "tcSyntaxOp" (ppr other)
 905
 906 ---------------------------
 907 instFun :: InstOrigin
 908         -> HsExpr TcId
 909         -> TvSubst                -- The instantiating substitution
 910         -> [([TyVar], ThetaType)] -- Stuff to instantiate
 911         -> TcM (HsExpr TcId)
 912
 913 instFun orig fun subst []
 914   = return fun          -- Common short cut
 915
 916 instFun orig fun subst tv_theta_prs
 917   = do  { let ty_theta_prs' = map subst_pr tv_theta_prs
 918         ; traceTc (text "instFun" <+> ppr ty_theta_prs')
 919                 -- Make two ad-hoc checks
 920         ; doStupidChecks fun ty_theta_prs'
 921
 922                 -- Now do normal instantiation
 923         ; method_sharing <- doptM Opt_MethodSharing
 924         ; result <- go method_sharing True fun ty_theta_prs'
 925         ; traceTc (text "instFun result" <+> ppr result)
 926         ; return result
 927         }
 928   where
 929     subst_pr (tvs, theta)
 930         = (substTyVars subst tvs, substTheta subst theta)
 931
 932     go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun }
 933
 934     go method_sharing True (HsVar fun_id) ((tys,theta) : prs)
 935         | want_method_inst method_sharing theta
 936         = do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta")
 937              ; meth_id <- newMethodWithGivenTy orig fun_id tys
 938              ; go method_sharing False (HsVar meth_id) prs }
 939                 -- Go round with 'False' to prevent further use
 940                 -- of newMethod: see Note [Multiple instantiation]
 941
 942     go method_sharing _ fun ((tys, theta) : prs)
 943         = do { co_fn <- instCall orig tys theta
 944              ; traceTc (text "go yields co_fn" <+> ppr co_fn)
 945              ; go method_sharing False (HsWrap co_fn fun) prs }
 946
 947         -- See Note [No method sharing]
 948     want_method_inst method_sharing theta =  not (null theta)   -- Overloaded
 949                                           && method_sharing
 950 \end{code}
 951
 952 Note [Multiple instantiation]
 953 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 954 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
 955 For example, consider
 956         f :: forall a. Eq a => forall b. Ord b => a -> b
 957 At a call to f, at say [Int, Bool], it's tempting to translate the call to
 958
 959         f_m1
 960   where
 961         f_m1 :: forall b. Ord b => Int -> b
 962         f_m1 = f Int dEqInt
 963
 964         f_m2 :: Int -> Bool
 965         f_m2 = f_m1 Bool dOrdBool
 966
 967 But notice that f_m2 has f_m1 as its meth_id.  Now the danger is that if we do
 968 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
 969         f_m1 = f_mx
 970 But it's entirely possible that f_m2 will continue to float out, because it
 971 mentions no type variables.  Result, f_m1 isn't in scope.
 972
 973 Here's a concrete example that does this (test tc200):
 974
 975     class C a where
 976       f :: Eq b => b -> a -> Int
 977       baz :: Eq a => Int -> a -> Int
 978
 979     instance C Int where
 980       baz = f
 981
 982 Current solution: only do the "method sharing" thing for the first type/dict
 983 application, not for the iterated ones.  A horribly subtle point.
 984
 985 Note [No method sharing]
 986 ~~~~~~~~~~~~~~~~~~~~~~~~
 987 The -fno-method-sharing flag controls what happens so far as the LIE
 988 is concerned.  The default case is that for an overloaded function we
 989 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 990 something like
 991         f :: Num a => a -> a
 992         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 993 If you specify -fno-method-sharing, the dictionary application
 994 isn't shared, so we get
 995         f :: Num a => a -> a
 996         f = /\a (d:Num a) (x:a) -> (+) a d x x
 997 This gets a bit less sharing, but
 998         a) it's better for RULEs involving overloaded functions
 999         b) perhaps fewer separated lambdas
1000
1001 Note [Left to right]
1002 ~~~~~~~~~~~~~~~~~~~~
1003 tcArgs implements a left-to-right order, which goes beyond what is described in the
1004 impredicative type inference paper.  In particular, it allows
1005         runST $ foo
1006 where runST :: (forall s. ST s a) -> a
1007 When typechecking the application of ($)::(a->b) -> a -> b, we first check that
1008 runST has type (a->b), thereby filling in a=forall s. ST s a.  Then we un-box this type
1009 before checking foo.  The left-to-right order really helps here.
1010
1011 \begin{code}
1012 tcArgs :: LHsExpr Name                          -- The function (for error messages)
1013        -> [LHsExpr Name]                        -- Actual args
1014        -> ArgChecker [LHsExpr TcId]
1015
1016 type ArgChecker results
1017    = [TyVar] -> [TcSigmaType]           -- Current instantiation
1018    -> [TcSigmaType]                     -- Expected arg types (**before** applying the instantiation)
1019    -> TcM ([TcSigmaType], results)      -- Resulting instantiation and args
1020
1021 tcArgs fun args qtvs qtys arg_tys
1022   = go 1 qtys args arg_tys
1023   where
1024     go n qtys [] [] = return (qtys, [])
1025     go n qtys (arg:args) (arg_ty:arg_tys)
1026         = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
1027              ; qtys' <- mapM refineBox qtys     -- Exploit new info
1028              ; (qtys'', args') <- go (n+1) qtys' args arg_tys
1029              ; return (qtys'', arg':args') }
1030     go n qtys args arg_tys = panic "tcArgs"
1031
1032 tcArg :: LHsExpr Name                           -- The function
1033       -> Int                                    --   and arg number (for error messages)
1034       -> LHsExpr Name
1035       -> [TyVar] -> [TcSigmaType]               -- Instantiate the arg type like this
1036       -> BoxySigmaType
1037       -> TcM (LHsExpr TcId)                     -- Resulting argument
1038 tcArg fun arg_no arg qtvs qtys ty
1039   = addErrCtxt (funAppCtxt fun arg arg_no) $
1040     tcPolyExprNC arg (substTyWith qtvs qtys ty)
1041 \end{code}
1042
1043
1044 Note [tagToEnum#]
1045 ~~~~~~~~~~~~~~~~~
1046 Nasty check to ensure that tagToEnum# is applied to a type that is an
1047 enumeration TyCon.  Unification may refine the type later, but this
1048 check won't see that, alas.  It's crude but it works.
1049
1050 Here's are two cases that should fail
1051         f :: forall a. a
1052         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
1053
1054         g :: Int
1055         g = tagToEnum# 0        -- Int is not an enumeration
1056
1057
1058 \begin{code}
1059 doStupidChecks :: HsExpr TcId
1060                -> [([TcType], ThetaType)]
1061                -> TcM ()
1062 -- Check two tiresome and ad-hoc cases
1063 -- (a) the "stupid theta" for a data con; add the constraints
1064 --     from the "stupid theta" of a data constructor (sigh)
1065 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
1066
1067 doStupidChecks (HsVar fun_id) ((tys,_):_)
1068   | Just con <- isDataConId_maybe fun_id   -- (a)
1069   = addDataConStupidTheta con tys
1070
1071   | fun_id `hasKey` tagToEnumKey           -- (b)
1072   = do  { tys' <- zonkTcTypes tys
1073         ; checkTc (ok tys') (tagToEnumError tys')
1074         }
1075   where
1076     ok []       = False
1077     ok (ty:tys) = case tcSplitTyConApp_maybe ty of
1078                         Just (tc,_) -> isEnumerationTyCon tc
1079                         Nothing     -> False
1080
1081 doStupidChecks fun tv_theta_prs
1082   = return () -- The common case
1083
1084
1085 tagToEnumError tys
1086   = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type)
1087          2 (vcat [ptext (sLit "Specify the type by giving a type signature"),
1088                   ptext (sLit "e.g. (tagToEnum# x) :: Bool")])
1089   where
1090     at_type | null tys = empty  -- Probably never happens
1091             | otherwise = ptext (sLit "at type") <+> ppr (head tys)
1092 \end{code}
1093
1094 %************************************************************************
1095 %*                                                                      *
1096 \subsection{@tcId@ typechecks an identifier occurrence}
1097 %*                                                                      *
1098 %************************************************************************
1099
1100 \begin{code}
1101 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
1102 lookupFun orig id_name
1103   = do  { thing <- tcLookup id_name
1104         ; case thing of
1105             AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
1106                                    where
1107                                       wrap_id = dataConWrapId con
1108
1109             AGlobal (AnId id)
1110                 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
1111                 | otherwise                  -> return (HsVar id, idType id)
1112                 -- A global cannot possibly be ill-staged
1113                 -- nor does it need the 'lifting' treatment
1114
1115             ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
1116                 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
1117                                           -- Note [Local record selectors]
1118                 | otherwise
1119                 -> do { thLocalId orig id ty lvl
1120                       ; case mb_co of
1121                           Unrefineable    -> return (HsVar id, ty)
1122                           Rigid co        -> return (mkHsWrap co (HsVar id), ty)
1123                           Wobbly          -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty)     -- Wobbly, or no free vars
1124                           WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)"))
1125                       }
1126
1127             other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected"))
1128     }
1129
1130 #ifndef GHCI  /* GHCI and TH is off */
1131 --------------------------------------
1132 thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM ()
1133 -- Check for cross-stage lifting
1134 thLocalId orig id id_ty bind_lvl
1135   = return ()
1136
1137 #else         /* GHCI and TH is on */
1138 thLocalId orig id id_ty bind_lvl
1139   = do  { use_stage <- getStage -- TH case
1140         ; let use_lvl = thLevel use_stage
1141         ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
1142         ; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
1143         ; when (use_lvl > bind_lvl) $
1144           checkCrossStageLifting orig id id_ty bind_lvl use_stage }
1145
1146 --------------------------------------
1147 checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM ()
1148 -- We are inside brackets, and (use_lvl > bind_lvl)
1149 -- Now we must check whether there's a cross-stage lift to do
1150 -- Examples   \x -> [| x |]
1151 --            [| map |]
1152
1153 checkCrossStageLifting _ _ _ _ Comp   = return ()
1154 checkCrossStageLifting _ _ _ _ Splice = return ()
1155
1156 checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var)
1157   | thTopLevelId id
1158   =     -- Top-level identifiers in this module,
1159         -- (which have External Names)
1160         -- are just like the imported case:
1161         -- no need for the 'lifting' treatment
1162         -- E.g.  this is fine:
1163         --   f x = x
1164         --   g y = [| f 3 |]
1165         -- But we do need to put f into the keep-alive
1166         -- set, because after desugaring the code will
1167         -- only mention f's *name*, not f itself.
1168     keepAliveTc id
1169
1170   | otherwise   -- bind_lvl = outerLevel presumably,
1171                 -- but the Id is not bound at top level
1172   =     -- Nested identifiers, such as 'x' in
1173         -- E.g. \x -> [| h x |]
1174         -- We must behave as if the reference to x was
1175         --      h $(lift x)
1176         -- We use 'x' itself as the splice proxy, used by
1177         -- the desugarer to stitch it all back together.
1178         -- If 'x' occurs many times we may get many identical
1179         -- bindings of the same splice proxy, but that doesn't
1180         -- matter, although it's a mite untidy.
1181     do  { checkTc (isTauTy id_ty) (polySpliceErr id)
1182                -- If x is polymorphic, its occurrence sites might
1183                -- have different instantiations, so we can't use plain
1184                -- 'x' as the splice proxy name.  I don't know how to
1185                -- solve this, and it's probably unimportant, so I'm
1186                -- just going to flag an error for now
1187
1188         ; id_ty' <- zapToMonotype id_ty
1189                 -- The id_ty might have an OpenTypeKind, but we
1190                 -- can't instantiate the Lift class at that kind,
1191                 -- so we zap it to a LiftedTypeKind monotype
1192                 -- C.f. the call in TcPat.newLitInst
1193
1194         ; lift <- if isStringTy id_ty' then
1195                      tcLookupId DsMeta.liftStringName
1196                      -- See Note [Lifting strings]
1197                   else
1198                      setLIEVar lie_var  $ do  -- Put the 'lift' constraint into the right LIE
1199                      newMethodFromName orig id_ty' DsMeta.liftName
1200
1201                    -- Update the pending splices
1202         ; ps <- readMutVar ps_var
1203         ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
1204
1205         ; return () }
1206 #endif /* GHCI */
1207 \end{code}
1208
1209 Note [Lifting strings]
1210 ~~~~~~~~~~~~~~~~~~~~~~
1211 If we see $(... [| s |] ...) where s::String, we don't want to
1212 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1213 So this conditional short-circuits the lifting mechanism to generate
1214 (liftString "xy") in that case.  I didn't want to use overlapping instances
1215 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1216 errors in a polymorphic situation.
1217
1218 If this check fails (which isn't impossible) we get another chance; see
1219 Note [Converting strings] in Convert.lhs
1220
1221 Local record selectors
1222 ~~~~~~~~~~~~~~~~~~~~~~
1223 Record selectors for TyCons in this module are ordinary local bindings,
1224 which show up as ATcIds rather than AGlobals.  So we need to check for
1225 naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
1226
1227
1228 %************************************************************************
1229 %*                                                                      *
1230 \subsection{Record bindings}
1231 %*                                                                      *
1232 %************************************************************************
1233
1234 Game plan for record bindings
1235 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1236 1. Find the TyCon for the bindings, from the first field label.
1237
1238 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1239
1240 For each binding field = value
1241
1242 3. Instantiate the field type (from the field label) using the type
1243    envt from step 2.
1244
1245 4  Type check the value using tcArg, passing the field type as
1246    the expected argument type.
1247
1248 This extends OK when the field types are universally quantified.
1249
1250
1251 \begin{code}
1252 tcRecordBinds
1253         :: DataCon
1254         -> [TcType]     -- Expected type for each field
1255         -> HsRecordBinds Name
1256         -> TcM (HsRecordBinds TcId)
1257
1258 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1259   = do  { mb_binds <- mapM do_bind rbinds
1260         ; return (HsRecFields (catMaybes mb_binds) dd) }
1261   where
1262     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1263     do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1264       | Just field_ty <- assocMaybe flds_w_tys field_lbl
1265       = addErrCtxt (fieldCtxt field_lbl)        $
1266         do { rhs' <- tcPolyExprNC rhs field_ty
1267            ; let field_id = mkUserLocal (nameOccName field_lbl)
1268                                         (nameUnique field_lbl)
1269                                         field_ty loc
1270                 -- Yuk: the field_id has the *unique* of the selector Id
1271                 --          (so we can find it easily)
1272                 --      but is a LocalId with the appropriate type of the RHS
1273                 --          (so the desugarer knows the type of local binder to make)
1274            ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
1275       | otherwise
1276       = do { addErrTc (badFieldCon data_con field_lbl)
1277            ; return Nothing }
1278
1279 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1280 checkMissingFields data_con rbinds
1281   | null field_labels   -- Not declared as a record;
1282                         -- But C{} is still valid if no strict fields
1283   = if any isBanged field_strs then
1284         -- Illegal if any arg is strict
1285         addErrTc (missingStrictFields data_con [])
1286     else
1287         return ()
1288
1289   | otherwise = do              -- A record
1290     unless (null missing_s_fields)
1291            (addErrTc (missingStrictFields data_con missing_s_fields))
1292
1293     warn <- doptM Opt_WarnMissingFields
1294     unless (not (warn && notNull missing_ns_fields))
1295            (warnTc True (missingFields data_con missing_ns_fields))
1296
1297   where
1298     missing_s_fields
1299         = [ fl | (fl, str) <- field_info,
1300                  isBanged str,
1301                  not (fl `elem` field_names_used)
1302           ]
1303     missing_ns_fields
1304         = [ fl | (fl, str) <- field_info,
1305                  not (isBanged str),
1306                  not (fl `elem` field_names_used)
1307           ]
1308
1309     field_names_used = hsRecFields rbinds
1310     field_labels     = dataConFieldLabels data_con
1311
1312     field_info = zipEqual "missingFields"
1313                           field_labels
1314                           field_strs
1315
1316     field_strs = dataConStrictMarks data_con
1317 \end{code}
1318
1319 %************************************************************************
1320 %*                                                                      *
1321 \subsection{Errors and contexts}
1322 %*                                                                      *
1323 %************************************************************************
1324
1325 Boring and alphabetical:
1326 \begin{code}
1327 addExprErrCtxt :: OutputableBndr id => LHsExpr id -> TcM a -> TcM a
1328 addExprErrCtxt expr = addErrCtxt (exprCtxt (unLoc expr))
1329
1330 exprCtxt expr
1331   = hang (ptext (sLit "In the expression:")) 4 (ppr expr)
1332
1333 fieldCtxt field_name
1334   = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1335
1336 funAppCtxt fun arg arg_no
1337   = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1338                     quotes (ppr fun) <> text ", namely"])
1339          4 (quotes (ppr arg))
1340
1341 badFieldTypes prs
1342   = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1343                          <> plural prs <> colon)
1344        2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1345
1346 badFieldsUpd rbinds
1347   = hang (ptext (sLit "No constructor has all these fields:"))
1348          4 (pprQuotedList (hsRecFields rbinds))
1349
1350 naughtyRecordSel sel_id
1351   = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1352     ptext (sLit "as a function due to escaped type variables") $$
1353     ptext (sLit "Probable fix: use pattern-matching syntax instead")
1354
1355 notSelector field
1356   = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1357
1358 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1359 missingStrictFields con fields
1360   = header <> rest
1361   where
1362     rest | null fields = empty  -- Happens for non-record constructors
1363                                 -- with strict fields
1364          | otherwise   = colon <+> pprWithCommas ppr fields
1365
1366     header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1367              ptext (sLit "does not have the required strict field(s)")
1368
1369 missingFields :: DataCon -> [FieldLabel] -> SDoc
1370 missingFields con fields
1371   = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1372         <+> pprWithCommas ppr fields
1373
1374 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1375
1376 #ifdef GHCI
1377 polySpliceErr :: Id -> SDoc
1378 polySpliceErr id
1379   = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
1380 #endif
1381 \end{code}