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