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  { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
 854         ; (fun, fun_ty) <- lookupFun orig fun_name
 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         ; co_fn <- tcSubExp orig fun_tau' res_ty
 867
 868         -- And pack up the results
 869         ; fun' <- instFun orig fun res_subst tv_theta_prs
 870         ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun'))
 871         ; return (mkHsWrap co_fn fun') }
 872
 873 --      Note [Push result type in]
 874 --
 875 -- Unify with expected result before (was: after) type-checking the args
 876 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
 877 -- This is when we might detect a too-few args situation.
 878 -- (One can think of cases when the opposite order would give
 879 -- a better error message.)
 880 -- [March 2003: I'm experimenting with putting this first.  Here's an
 881 --              example where it actually makes a real difference
 882 --    class C t a b | t a -> b
 883 --    instance C Char a Bool
 884 --
 885 --    data P t a = forall b. (C t a b) => MkP b
 886 --    data Q t   = MkQ (forall a. P t a)
 887
 888 --    f1, f2 :: Q Char;
 889 --    f1 = MkQ (MkP True)
 890 --    f2 = MkQ (MkP True :: forall a. P Char a)
 891 --
 892 -- With the change, f1 will type-check, because the 'Char' info from
 893 -- the signature is propagated into MkQ's argument. With the check
 894 -- in the other order, the extra signature in f2 is reqd.]
 895
 896 ---------------------------
 897 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 898 -- Typecheck a syntax operator, checking that it has the specified type
 899 -- The operator is always a variable at this stage (i.e. renamer output)
 900 -- This version assumes ty is a monotype
 901 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
 902 tcSyntaxOp orig other      ty = pprPanic "tcSyntaxOp" (ppr other)
 903
 904 ---------------------------
 905 instFun :: InstOrigin
 906         -> HsExpr TcId
 907         -> TvSubst                -- The instantiating substitution
 908         -> [([TyVar], ThetaType)] -- Stuff to instantiate
 909         -> TcM (HsExpr TcId)
 910
 911 instFun orig fun subst []
 912   = return fun          -- Common short cut
 913
 914 instFun orig fun subst tv_theta_prs
 915   = do  { let ty_theta_prs' = map subst_pr tv_theta_prs
 916         ; traceTc (text "instFun" <+> ppr ty_theta_prs')
 917                 -- Make two ad-hoc checks
 918         ; doStupidChecks fun ty_theta_prs'
 919
 920                 -- Now do normal instantiation
 921         ; method_sharing <- doptM Opt_MethodSharing
 922         ; result <- go method_sharing True fun ty_theta_prs'
 923         ; traceTc (text "instFun result" <+> ppr result)
 924         ; return result
 925         }
 926   where
 927     subst_pr (tvs, theta)
 928         = (substTyVars subst tvs, substTheta subst theta)
 929
 930     go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun }
 931
 932     go method_sharing True (HsVar fun_id) ((tys,theta) : prs)
 933         | want_method_inst method_sharing theta
 934         = do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta")
 935              ; meth_id <- newMethodWithGivenTy orig fun_id tys
 936              ; go method_sharing False (HsVar meth_id) prs }
 937                 -- Go round with 'False' to prevent further use
 938                 -- of newMethod: see Note [Multiple instantiation]
 939
 940     go method_sharing _ fun ((tys, theta) : prs)
 941         = do { co_fn <- instCall orig tys theta
 942              ; traceTc (text "go yields co_fn" <+> ppr co_fn)
 943              ; go method_sharing False (HsWrap co_fn fun) prs }
 944
 945         -- See Note [No method sharing]
 946     want_method_inst method_sharing theta =  not (null theta)   -- Overloaded
 947                                           && method_sharing
 948 \end{code}
 949
 950 Note [Multiple instantiation]
 951 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 952 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
 953 For example, consider
 954         f :: forall a. Eq a => forall b. Ord b => a -> b
 955 At a call to f, at say [Int, Bool], it's tempting to translate the call to
 956
 957         f_m1
 958   where
 959         f_m1 :: forall b. Ord b => Int -> b
 960         f_m1 = f Int dEqInt
 961
 962         f_m2 :: Int -> Bool
 963         f_m2 = f_m1 Bool dOrdBool
 964
 965 But notice that f_m2 has f_m1 as its meth_id.  Now the danger is that if we do
 966 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
 967         f_m1 = f_mx
 968 But it's entirely possible that f_m2 will continue to float out, because it
 969 mentions no type variables.  Result, f_m1 isn't in scope.
 970
 971 Here's a concrete example that does this (test tc200):
 972
 973     class C a where
 974       f :: Eq b => b -> a -> Int
 975       baz :: Eq a => Int -> a -> Int
 976
 977     instance C Int where
 978       baz = f
 979
 980 Current solution: only do the "method sharing" thing for the first type/dict
 981 application, not for the iterated ones.  A horribly subtle point.
 982
 983 Note [No method sharing]
 984 ~~~~~~~~~~~~~~~~~~~~~~~~
 985 The -fno-method-sharing flag controls what happens so far as the LIE
 986 is concerned.  The default case is that for an overloaded function we
 987 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 988 something like
 989         f :: Num a => a -> a
 990         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 991 If you specify -fno-method-sharing, the dictionary application
 992 isn't shared, so we get
 993         f :: Num a => a -> a
 994         f = /\a (d:Num a) (x:a) -> (+) a d x x
 995 This gets a bit less sharing, but
 996         a) it's better for RULEs involving overloaded functions
 997         b) perhaps fewer separated lambdas
 998
 999 Note [Left to right]
1000 ~~~~~~~~~~~~~~~~~~~~
1001 tcArgs implements a left-to-right order, which goes beyond what is described in the
1002 impredicative type inference paper.  In particular, it allows
1003         runST $ foo
1004 where runST :: (forall s. ST s a) -> a
1005 When typechecking the application of ($)::(a->b) -> a -> b, we first check that
1006 runST has type (a->b), thereby filling in a=forall s. ST s a.  Then we un-box this type
1007 before checking foo.  The left-to-right order really helps here.
1008
1009 \begin{code}
1010 tcArgs :: LHsExpr Name                          -- The function (for error messages)
1011        -> [LHsExpr Name]                        -- Actual args
1012        -> ArgChecker [LHsExpr TcId]
1013
1014 type ArgChecker results
1015    = [TyVar] -> [TcSigmaType]           -- Current instantiation
1016    -> [TcSigmaType]                     -- Expected arg types (**before** applying the instantiation)
1017    -> TcM ([TcSigmaType], results)      -- Resulting instantiation and args
1018
1019 tcArgs fun args qtvs qtys arg_tys
1020   = go 1 qtys args arg_tys
1021   where
1022     go n qtys [] [] = return (qtys, [])
1023     go n qtys (arg:args) (arg_ty:arg_tys)
1024         = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
1025              ; qtys' <- mapM refineBox qtys     -- Exploit new info
1026              ; (qtys'', args') <- go (n+1) qtys' args arg_tys
1027              ; return (qtys'', arg':args') }
1028     go n qtys args arg_tys = panic "tcArgs"
1029
1030 tcArg :: LHsExpr Name                           -- The function
1031       -> Int                                    --   and arg number (for error messages)
1032       -> LHsExpr Name
1033       -> [TyVar] -> [TcSigmaType]               -- Instantiate the arg type like this
1034       -> BoxySigmaType
1035       -> TcM (LHsExpr TcId)                     -- Resulting argument
1036 tcArg fun arg_no arg qtvs qtys ty
1037   = addErrCtxt (funAppCtxt fun arg arg_no) $
1038     tcPolyExprNC arg (substTyWith qtvs qtys ty)
1039 \end{code}
1040
1041
1042 Note [tagToEnum#]
1043 ~~~~~~~~~~~~~~~~~
1044 Nasty check to ensure that tagToEnum# is applied to a type that is an
1045 enumeration TyCon.  Unification may refine the type later, but this
1046 check won't see that, alas.  It's crude but it works.
1047
1048 Here's are two cases that should fail
1049         f :: forall a. a
1050         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
1051
1052         g :: Int
1053         g = tagToEnum# 0        -- Int is not an enumeration
1054
1055
1056 \begin{code}
1057 doStupidChecks :: HsExpr TcId
1058                -> [([TcType], ThetaType)]
1059                -> TcM ()
1060 -- Check two tiresome and ad-hoc cases
1061 -- (a) the "stupid theta" for a data con; add the constraints
1062 --     from the "stupid theta" of a data constructor (sigh)
1063 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
1064
1065 doStupidChecks (HsVar fun_id) ((tys,_):_)
1066   | Just con <- isDataConId_maybe fun_id   -- (a)
1067   = addDataConStupidTheta con tys
1068
1069   | fun_id `hasKey` tagToEnumKey           -- (b)
1070   = do  { tys' <- zonkTcTypes tys
1071         ; checkTc (ok tys') (tagToEnumError tys')
1072         }
1073   where
1074     ok []       = False
1075     ok (ty:tys) = case tcSplitTyConApp_maybe ty of
1076                         Just (tc,_) -> isEnumerationTyCon tc
1077                         Nothing     -> False
1078
1079 doStupidChecks fun tv_theta_prs
1080   = return () -- The common case
1081
1082
1083 tagToEnumError tys
1084   = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type)
1085          2 (vcat [ptext (sLit "Specify the type by giving a type signature"),
1086                   ptext (sLit "e.g. (tagToEnum# x) :: Bool")])
1087   where
1088     at_type | null tys = empty  -- Probably never happens
1089             | otherwise = ptext (sLit "at type") <+> ppr (head tys)
1090 \end{code}
1091
1092 %************************************************************************
1093 %*                                                                      *
1094 \subsection{@tcId@ typechecks an identifier occurrence}
1095 %*                                                                      *
1096 %************************************************************************
1097
1098 \begin{code}
1099 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
1100 lookupFun orig id_name
1101   = do  { thing <- tcLookup id_name
1102         ; case thing of
1103             AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
1104                                    where
1105                                       wrap_id = dataConWrapId con
1106
1107             AGlobal (AnId id)
1108                 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
1109                 | otherwise                  -> return (HsVar id, idType id)
1110                 -- A global cannot possibly be ill-staged
1111                 -- nor does it need the 'lifting' treatment
1112
1113             ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
1114                 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
1115                                           -- Note [Local record selectors]
1116                 | otherwise
1117                 -> do { thLocalId orig id ty lvl
1118                       ; case mb_co of
1119                           Unrefineable    -> return (HsVar id, ty)
1120                           Rigid co        -> return (mkHsWrap co (HsVar id), ty)
1121                           Wobbly          -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty)     -- Wobbly, or no free vars
1122                           WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)"))
1123                       }
1124
1125             other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected"))
1126     }
1127
1128 #ifndef GHCI  /* GHCI and TH is off */
1129 --------------------------------------
1130 thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM ()
1131 -- Check for cross-stage lifting
1132 thLocalId orig id id_ty bind_lvl
1133   = return ()
1134
1135 #else         /* GHCI and TH is on */
1136 thLocalId orig id id_ty bind_lvl
1137   = do  { use_stage <- getStage -- TH case
1138         ; let use_lvl = thLevel use_stage
1139         ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
1140         ; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
1141         ; when (use_lvl > bind_lvl) $
1142           checkCrossStageLifting orig id id_ty bind_lvl use_stage }
1143
1144 --------------------------------------
1145 checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM ()
1146 -- We are inside brackets, and (use_lvl > bind_lvl)
1147 -- Now we must check whether there's a cross-stage lift to do
1148 -- Examples   \x -> [| x |]
1149 --            [| map |]
1150
1151 checkCrossStageLifting _ _ _ _ Comp   = return ()
1152 checkCrossStageLifting _ _ _ _ Splice = return ()
1153
1154 checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var)
1155   | thTopLevelId id
1156   =     -- Top-level identifiers in this module,
1157         -- (which have External Names)
1158         -- are just like the imported case:
1159         -- no need for the 'lifting' treatment
1160         -- E.g.  this is fine:
1161         --   f x = x
1162         --   g y = [| f 3 |]
1163         -- But we do need to put f into the keep-alive
1164         -- set, because after desugaring the code will
1165         -- only mention f's *name*, not f itself.
1166     keepAliveTc id
1167
1168   | otherwise   -- bind_lvl = outerLevel presumably,
1169                 -- but the Id is not bound at top level
1170   =     -- Nested identifiers, such as 'x' in
1171         -- E.g. \x -> [| h x |]
1172         -- We must behave as if the reference to x was
1173         --      h $(lift x)
1174         -- We use 'x' itself as the splice proxy, used by
1175         -- the desugarer to stitch it all back together.
1176         -- If 'x' occurs many times we may get many identical
1177         -- bindings of the same splice proxy, but that doesn't
1178         -- matter, although it's a mite untidy.
1179     do  { checkTc (isTauTy id_ty) (polySpliceErr id)
1180                -- If x is polymorphic, its occurrence sites might
1181                -- have different instantiations, so we can't use plain
1182                -- 'x' as the splice proxy name.  I don't know how to
1183                -- solve this, and it's probably unimportant, so I'm
1184                -- just going to flag an error for now
1185
1186         ; id_ty' <- zapToMonotype id_ty
1187                 -- The id_ty might have an OpenTypeKind, but we
1188                 -- can't instantiate the Lift class at that kind,
1189                 -- so we zap it to a LiftedTypeKind monotype
1190                 -- C.f. the call in TcPat.newLitInst
1191
1192         ; lift <- if isStringTy id_ty' then
1193                      tcLookupId DsMeta.liftStringName
1194                      -- See Note [Lifting strings]
1195                   else
1196                      setLIEVar lie_var  $ do  -- Put the 'lift' constraint into the right LIE
1197                      newMethodFromName orig id_ty' DsMeta.liftName
1198
1199                    -- Update the pending splices
1200         ; ps <- readMutVar ps_var
1201         ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
1202
1203         ; return () }
1204 #endif /* GHCI */
1205 \end{code}
1206
1207 Note [Lifting strings]
1208 ~~~~~~~~~~~~~~~~~~~~~~
1209 If we see $(... [| s |] ...) where s::String, we don't want to
1210 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1211 So this conditional short-circuits the lifting mechanism to generate
1212 (liftString "xy") in that case.  I didn't want to use overlapping instances
1213 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1214 errors in a polymorphic situation.
1215
1216 If this check fails (which isn't impossible) we get another chance; see
1217 Note [Converting strings] in Convert.lhs
1218
1219 Local record selectors
1220 ~~~~~~~~~~~~~~~~~~~~~~
1221 Record selectors for TyCons in this module are ordinary local bindings,
1222 which show up as ATcIds rather than AGlobals.  So we need to check for
1223 naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
1224
1225
1226 %************************************************************************
1227 %*                                                                      *
1228 \subsection{Record bindings}
1229 %*                                                                      *
1230 %************************************************************************
1231
1232 Game plan for record bindings
1233 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1234 1. Find the TyCon for the bindings, from the first field label.
1235
1236 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1237
1238 For each binding field = value
1239
1240 3. Instantiate the field type (from the field label) using the type
1241    envt from step 2.
1242
1243 4  Type check the value using tcArg, passing the field type as
1244    the expected argument type.
1245
1246 This extends OK when the field types are universally quantified.
1247
1248
1249 \begin{code}
1250 tcRecordBinds
1251         :: DataCon
1252         -> [TcType]     -- Expected type for each field
1253         -> HsRecordBinds Name
1254         -> TcM (HsRecordBinds TcId)
1255
1256 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1257   = do  { mb_binds <- mapM do_bind rbinds
1258         ; return (HsRecFields (catMaybes mb_binds) dd) }
1259   where
1260     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1261     do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1262       | Just field_ty <- assocMaybe flds_w_tys field_lbl
1263       = addErrCtxt (fieldCtxt field_lbl)        $
1264         do { rhs' <- tcPolyExprNC rhs field_ty
1265            ; let field_id = mkUserLocal (nameOccName field_lbl)
1266                                         (nameUnique field_lbl)
1267                                         field_ty loc
1268                 -- Yuk: the field_id has the *unique* of the selector Id
1269                 --          (so we can find it easily)
1270                 --      but is a LocalId with the appropriate type of the RHS
1271                 --          (so the desugarer knows the type of local binder to make)
1272            ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
1273       | otherwise
1274       = do { addErrTc (badFieldCon data_con field_lbl)
1275            ; return Nothing }
1276
1277 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1278 checkMissingFields data_con rbinds
1279   | null field_labels   -- Not declared as a record;
1280                         -- But C{} is still valid if no strict fields
1281   = if any isMarkedStrict field_strs then
1282         -- Illegal if any arg is strict
1283         addErrTc (missingStrictFields data_con [])
1284     else
1285         return ()
1286
1287   | otherwise = do              -- A record
1288     unless (null missing_s_fields)
1289            (addErrTc (missingStrictFields data_con missing_s_fields))
1290
1291     warn <- doptM Opt_WarnMissingFields
1292     unless (not (warn && notNull missing_ns_fields))
1293            (warnTc True (missingFields data_con missing_ns_fields))
1294
1295   where
1296     missing_s_fields
1297         = [ fl | (fl, str) <- field_info,
1298                  isMarkedStrict str,
1299                  not (fl `elem` field_names_used)
1300           ]
1301     missing_ns_fields
1302         = [ fl | (fl, str) <- field_info,
1303                  not (isMarkedStrict str),
1304                  not (fl `elem` field_names_used)
1305           ]
1306
1307     field_names_used = hsRecFields rbinds
1308     field_labels     = dataConFieldLabels data_con
1309
1310     field_info = zipEqual "missingFields"
1311                           field_labels
1312                           field_strs
1313
1314     field_strs = dataConStrictMarks data_con
1315 \end{code}
1316
1317 %************************************************************************
1318 %*                                                                      *
1319 \subsection{Errors and contexts}
1320 %*                                                                      *
1321 %************************************************************************
1322
1323 Boring and alphabetical:
1324 \begin{code}
1325 addExprErrCtxt :: OutputableBndr id => LHsExpr id -> TcM a -> TcM a
1326 addExprErrCtxt expr = addErrCtxt (exprCtxt (unLoc expr))
1327
1328 exprCtxt expr
1329   = hang (ptext (sLit "In the expression:")) 4 (ppr expr)
1330
1331 fieldCtxt field_name
1332   = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1333
1334 funAppCtxt fun arg arg_no
1335   = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1336                     quotes (ppr fun) <> text ", namely"])
1337          4 (quotes (ppr arg))
1338
1339 badFieldTypes prs
1340   = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1341                          <> plural prs <> colon)
1342        2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1343
1344 badFieldsUpd rbinds
1345   = hang (ptext (sLit "No constructor has all these fields:"))
1346          4 (pprQuotedList (hsRecFields rbinds))
1347
1348 naughtyRecordSel sel_id
1349   = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1350     ptext (sLit "as a function due to escaped type variables") $$
1351     ptext (sLit "Probable fix: use pattern-matching syntax instead")
1352
1353 notSelector field
1354   = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1355
1356 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1357 missingStrictFields con fields
1358   = header <> rest
1359   where
1360     rest | null fields = empty  -- Happens for non-record constructors
1361                                 -- with strict fields
1362          | otherwise   = colon <+> pprWithCommas ppr fields
1363
1364     header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1365              ptext (sLit "does not have the required strict field(s)")
1366
1367 missingFields :: DataCon -> [FieldLabel] -> SDoc
1368 missingFields con fields
1369   = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1370         <+> pprWithCommas ppr fields
1371
1372 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1373
1374 #ifdef GHCI
1375 polySpliceErr :: Id -> SDoc
1376 polySpliceErr id
1377   = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
1378 #endif
1379 \end{code}