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