TcExpr.hs 81 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
{-
2
c%
Austin Seipp's avatar
Austin Seipp committed
3 4 5
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

6
\section[TcExpr]{Typecheck an expression}
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# LANGUAGE CPP #-}
Matthew Pickering's avatar
Matthew Pickering committed
10
{-# LANGUAGE ScopedTypeVariables #-}
11

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
12 13
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
                tcInferRho, tcInferRhoNC,
14
                tcSyntaxOp, tcCheckId,
15 16
                addExprErrCtxt,
                getFixedTyVars ) where
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
17

18
#include "HsVersions.h"
19

20
import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
21
import THNames( liftStringName, liftName )
22

23 24
import HsSyn
import TcHsSyn
25
import TcRnMonad
26 27 28 29
import TcUnify
import BasicTypes
import Inst
import TcBinds
30
import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
31 32 33
import FamInstEnv       ( FamInstEnvs )
import RnEnv            ( addUsedGRE, addNameClashErrRn
                        , unknownSubordinateErr )
34 35 36 37
import TcEnv
import TcArrows
import TcMatches
import TcHsType
Matthew Pickering's avatar
Matthew Pickering committed
38
import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
39 40 41
import TcPat
import TcMType
import TcType
42
import DsMonad
43
import Id
Matthew Pickering's avatar
Matthew Pickering committed
44
import IdInfo
cactus's avatar
cactus committed
45
import ConLike
46
import DataCon
Matthew Pickering's avatar
Matthew Pickering committed
47
import PatSyn
48
import Name
49
import RdrName
50 51
import TyCon
import Type
52
import TcEvidence
53 54
import Var
import VarSet
55
import VarEnv
56
import TysWiredIn
57
import TysPrim( intPrimTy )
58
import PrimOp( tagToEnumKey )
59
import PrelNames
Adam Gundry's avatar
Adam Gundry committed
60
import MkId ( proxyHashId )
61
import DynFlags
62
import SrcLoc
63
import Util
64 65
import ListSetOps
import Maybes
66
import ErrUtils
67 68
import Outputable
import FastString
69
import Control.Monad
70
import Class(classTyCon)
71 72 73
import Data.Function
import Data.List
import qualified Data.Set as Set
74

Austin Seipp's avatar
Austin Seipp committed
75 76 77
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
78
\subsection{Main wrappers}
Austin Seipp's avatar
Austin Seipp committed
79 80 81
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
82

83
tcPolyExpr, tcPolyExprNC
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
84
         :: LHsExpr Name        -- Expression to type check
Gabor Greif's avatar
Gabor Greif committed
85
         -> TcSigmaType         -- Expected type (could be a polytype)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
86
         -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
87

88 89
-- tcPolyExpr is a convenient place (frequent but not too frequent)
-- place to add context information.
90 91 92
-- The NC version does not do so, usually because the caller wants
-- to do so himself.

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
93
tcPolyExpr expr res_ty
94
  = addExprErrCtxt expr $
95
    do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
96

97 98
tcPolyExprNC expr res_ty
  = do { traceTc "tcPolyExprNC" (ppr res_ty)
99
       ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
100
                            tcMonoExprNC expr rho
101
       ; return (mkLHsWrap gen_fn expr') }
102 103

---------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
104
tcMonoExpr, tcMonoExprNC
105 106
    :: LHsExpr Name      -- Expression to type check
    -> TcRhoType         -- Expected type (could be a type variable)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
107
                         -- Definitely no foralls at the top
108 109 110 111 112 113 114
    -> TcM (LHsExpr TcId)

tcMonoExpr expr res_ty
  = addErrCtxt (exprCtxt expr) $
    tcMonoExprNC expr res_ty

tcMonoExprNC (L loc expr) res_ty
115 116
  = ASSERT( not (isSigmaTy res_ty) )
    setSrcSpan loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
117 118
    do  { expr' <- tcExpr expr res_ty
        ; return (L loc expr') }
119

120
---------------
121
tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
122 123 124 125 126
-- Infer a *rho*-type.  This is, in effect, a special case
-- for ids and partial applications, so that if
--     f :: Int -> (forall a. a -> a) -> Int
-- then we can infer
--     f 3 :: (forall a. a -> a) -> Int
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
127
-- And that in turn is useful
128 129 130 131 132 133
--  (a) for the function part of any application (see tcApp)
--  (b) for the special rule for '$'
tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)

tcInferRhoNC (L loc expr)
  = setSrcSpan loc $
134
    do { (expr', rho) <- tcInfer (tcExpr expr)
135 136
       ; return (L loc expr', rho) }

137 138 139 140 141 142 143 144 145 146
tcUnboundId :: OccName -> TcRhoType -> TcM (HsExpr TcId)
-- Typechedk an occurrence of an unbound Id
--
-- Some of these started life as a true hole "_".  Others might simply
-- be variables that accidentally have no binding site
--
-- We turn all of them into HsVar, since HsUnboundVar can't contain an
-- Id; and indeed the evidence for the CHoleCan does bind it, so it's
-- not unbound any more!
tcUnboundId occ res_ty
147 148 149
 = do { ty <- newFlexiTyVarTy liftedTypeKind
      ; name <- newSysName occ
      ; let ev = mkLocalId name ty
150
      ; loc <- getCtLocM HoleOrigin
thomasw's avatar
thomasw committed
151 152
      ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ
                           , cc_hole = ExprHole }
153 154
      ; emitInsoluble can
      ; tcWrapResult (HsVar ev) ty res_ty }
sof's avatar
sof committed
155

Austin Seipp's avatar
Austin Seipp committed
156 157 158
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
159
        tcExpr: the main expression typechecker
Austin Seipp's avatar
Austin Seipp committed
160 161 162
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
163

164
tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
165
tcExpr e res_ty | debugIsOn && isSigmaTy res_ty     -- Sanity check
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
166
                = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
167

168 169
tcExpr (HsVar name)     res_ty = tcCheckId name res_ty
tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty
170

171
tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
172

173
tcExpr (HsLit lit)   res_ty = do { let lit_ty = hsLitType lit
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
174
                                 ; tcWrapResult (HsLit lit) lit_ty res_ty }
175 176

tcExpr (HsPar expr)  res_ty = do { expr' <- tcMonoExprNC expr res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
177
                                 ; return (HsPar expr') }
178

Alan Zimmerman's avatar
Alan Zimmerman committed
179
tcExpr (HsSCC src lbl expr) res_ty
180
  = do { expr' <- tcMonoExpr expr res_ty
Alan Zimmerman's avatar
Alan Zimmerman committed
181
       ; return (HsSCC src lbl expr') }
182

Alan Zimmerman's avatar
Alan Zimmerman committed
183
tcExpr (HsTickPragma src info expr) res_ty
184
  = do { expr' <- tcMonoExpr expr res_ty
Alan Zimmerman's avatar
Alan Zimmerman committed
185
       ; return (HsTickPragma src info expr') }
186

Alan Zimmerman's avatar
Alan Zimmerman committed
187
tcExpr (HsCoreAnn src lbl expr) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
188
  = do  { expr' <- tcMonoExpr expr res_ty
Alan Zimmerman's avatar
Alan Zimmerman committed
189
        ; return (HsCoreAnn src lbl expr') }
190

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
191 192 193
tcExpr (HsOverLit lit) res_ty
  = do  { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
        ; return (HsOverLit lit') }
194 195

tcExpr (NegApp expr neg_expr) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
196 197 198 199
  = do  { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
                                  (mkFunTy res_ty res_ty)
        ; expr' <- tcMonoExpr expr res_ty
        ; return (NegApp expr' neg_expr') }
200

201 202 203 204 205 206 207 208 209 210 211
tcExpr (HsIPVar x) res_ty
  = do { let origin = IPOccOrigin x
           {- Implicit parameters must have a *tau-type* not a.
              type scheme.  We enforce this by creating a fresh
              type variable as its type.  (Because res_ty may not
              be a tau-type.) -}
       ; ip_ty <- newFlexiTyVarTy openTypeKind
       ; let ip_name = mkStrLitTy (hsIPNameFS x)
       ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty])
       ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty }
  where
Gabor Greif's avatar
Gabor Greif committed
212
  -- Coerces a dictionary for `IP "x" t` into `t`.
213 214
  fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
                          unwrapIP $ mkClassPred ipClass [x,ty]
215

Adam Gundry's avatar
Adam Gundry committed
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
tcExpr (HsOverLabel l) res_ty  -- See Note [Type-checking overloaded labels]
  = do { let origin = OverLabelOrigin l
       ; isLabelClass <- tcLookupClass isLabelClassName
       ; alpha <- newFlexiTyVarTy openTypeKind
       ; let lbl = mkStrLitTy l
             pred = mkClassPred isLabelClass [lbl, alpha]
       ; loc <- getSrcSpanM
       ; var <- emitWanted origin pred
       ; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl])
                                         (HsVar proxyHashId))
             tm = L loc (fromDict pred (HsVar var)) `HsApp` proxy_arg
       ; tcWrapResult tm alpha res_ty }
  where
  -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`.
  fromDict pred = HsWrap $ mkWpCast $ TcCoercion $ unwrapIP pred

232
tcExpr (HsLam match) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
233 234
  = do  { (co_fn, match') <- tcMatchLambda match res_ty
        ; return (mkHsWrap co_fn (HsLam match')) }
235

236
tcExpr e@(HsLamCase _ matches) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
237 238 239
  = do  { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty
        ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty
        ; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' }
240 241 242 243
  where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
                  , ptext (sLit "requires")]
        match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }

thomasw's avatar
thomasw committed
244
tcExpr (ExprWithTySig expr sig_ty wcs) res_ty
245 246 247 248
 = tcWildcardBinders wcs $ \ wc_prs ->
   do { addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $
        emitWildcardHoleConstraints wc_prs
      ; sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
249
      ; (gen_fn, expr')
250
            <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
251 252 253

                  -- Remember to extend the lexical type-variable environment
                  -- See Note [More instantiated than scoped] in TcBinds
Austin Seipp's avatar
Austin Seipp committed
254
               tcExtendTyVarEnv2
255 256
                  [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
257
               tcMonoExprNC expr res_ty
258

259
      ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
260

261
      ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
262
      ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty }
263

264
tcExpr (HsType ty) _
265
  = failWithTc (text "Can't handle type argument:" <+> ppr ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
266 267 268 269 270
        -- This is the syntax for type applications that I was planning
        -- but there are difficulties (e.g. what order for type args)
        -- so it's not enabled yet.
        -- Can't eliminate it altogether from the parser, because the
        -- same parser parses *patterns*.
271

Adam Gundry's avatar
Adam Gundry committed
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291

{-
Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that (in GHC.OverloadedLabels) we have

    class IsLabel (x :: Symbol) a where
      fromLabel :: Proxy# x -> a

When we see an overloaded label like `#foo`, we generate a fresh
variable `alpha` for the type and emit an `IsLabel "foo" alpha`
constraint.  Because the `IsLabel` class has a single method, it is
represented by a newtype, so we can coerce `IsLabel "foo" alpha` to
`Proxy# "foo" -> alpha` (just like for implicit parameters).  We then
apply it to `proxy#` of type `Proxy# "foo"`.

That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
-}


Austin Seipp's avatar
Austin Seipp committed
292 293 294
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
295
                Infix operators and sections
Austin Seipp's avatar
Austin Seipp committed
296 297
*                                                                      *
************************************************************************
298

299 300 301
Note [Left sections]
~~~~~~~~~~~~~~~~~~~~
Left sections, like (4 *), are equivalent to
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
302
        \ x -> (*) 4 x,
303
or, if PostfixOperators is enabled, just
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
304
        (*) 4
305 306 307 308 309 310 311
With PostfixOperators we don't actually require the function to take
two arguments at all.  For example, (x `not`) means (not x); you get
postfix operators!  Not Haskell 98, but it's less work and kind of
useful.

Note [Typing rule for ($)]
~~~~~~~~~~~~~~~~~~~~~~~~~~
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
312
People write
313
   runST $ blah
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
314
so much, where
315 316
   runST :: (forall s. ST s a) -> a
that I have finally given in and written a special type-checking
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
317
rule just for saturated appliations of ($).
318
  * Infer the type of the first argument
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
319
  * Decompose it; should be of form (arg2_ty -> res_ty),
320 321 322 323 324 325 326 327
       where arg2_ty might be a polytype
  * Use arg2_ty to typecheck arg2

Note [Typing rule for seq]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to allow
       x `seq` (# p,q #)
which suggests this type for seq:
328 329 330 331 332
   seq :: forall (a:*) (b:Open). a -> b -> b,
with (b:Open) meaning that be can be instantiated with an unboxed
tuple.  The trouble is that this might accept a partially-applied
'seq', and I'm just not certain that would work.  I'm only sure it's
only going to work when it's fully applied, so it turns into
333 334
    case x of _ -> (# p,q #)

335 336
So it seems more uniform to treat 'seq' as it it was a language
construct.
337

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
338
See Note [seqId magic] in MkId, and
Austin Seipp's avatar
Austin Seipp committed
339
-}
340 341 342

tcExpr (OpApp arg1 op fix arg2) res_ty
  | (L loc (HsVar op_name)) <- op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
343
  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
344 345 346 347 348 349 350 351 352
  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
       ; let arg2_ty = res_ty
       ; arg1' <- tcArg op (arg1, arg1_ty, 1)
       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
       ; op_id <- tcLookupId op_name
       ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
       ; return $ OpApp arg1' op' fix arg2' }

  | (L loc (HsVar op_name)) <- op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
353
  , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
354 355
  = do { traceTc "Application rule" (ppr op)
       ; (arg1', arg1_ty) <- tcInferRho arg1
356

357 358
       ; let doc = ptext (sLit "The first argument of ($) takes")
       ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
359 360 361 362 363 364 365

         -- We have (arg1 $ arg2)
         -- So: arg1_ty = arg2_ty -> op_res_ty
         -- where arg2_ty maybe polymorphic; that's the point

       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
       ; co_b  <- unifyType op_res_ty res_ty    -- op_res ~ res
366

367
       -- Make sure that the argument type has kind '*'
368
       --    ($) :: forall (a2:*) (r:Open). (a2->r) -> a2 -> r
369
       -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
370 371
       --    (which gives a seg fault)
       -- We do this by unifying with a MetaTv; but of course
372
       -- it must allow foralls in the type it unifies with (hence ReturnTv)!
373
       --
374 375 376 377 378
       -- The *result* type can have any kind (Trac #8739),
       -- so we don't need to check anything for that
       ; a2_tv <- newReturnTyVar liftedTypeKind
       ; let a2_ty = mkTyVarTy a2_tv
       ; co_a <- unifyType arg2_ty a2_ty     -- arg2 ~ a2
379

380
       ; op_id  <- tcLookupId op_name
381
       ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) (HsVar op_id))
382
       ; return $
Joachim Breitner's avatar
Joachim Breitner committed
383
         OpApp (mkLHsWrapCo (mkTcFunCo Nominal co_a co_b) $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
384 385
                mkLHsWrapCo co_arg1 arg1')
               op' fix
386
               (mkLHsWrapCo co_a arg2') }
387 388 389 390

  | otherwise
  = do { traceTc "Non Application rule" (ppr op)
       ; (op', op_ty) <- tcInferFun op
batterseapower's avatar
batterseapower committed
391
       ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTysWrap op 2 op_ty
392 393
       ; co_res <- unifyType op_res_ty res_ty
       ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
394 395
       ; return $ mkHsWrapCo co_res $
         OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
396

397
-- Right sections, equivalent to \ x -> x `op` expr, or
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
398 399
--      \ x -> op x expr

400 401
tcExpr (SectionR op arg2) res_ty
  = do { (op', op_ty) <- tcInferFun op
batterseapower's avatar
batterseapower committed
402
       ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTysWrap op 2 op_ty
403 404
       ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
405
       ; return $ mkHsWrapCo co_res $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
406
         SectionR (mkLHsWrapCo co_fn op') arg2' }
407 408 409

tcExpr (SectionL arg1 op) res_ty
  = do { (op', op_ty) <- tcInferFun op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
410
       ; dflags <- getDynFlags      -- Note [Left sections]
411
       ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
412 413
                         | otherwise                        = 2

batterseapower's avatar
batterseapower committed
414
       ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTysWrap op n_reqd_args op_ty
415 416
       ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
       ; arg1' <- tcArg op (arg1, arg1_ty, 1)
417 418
       ; return $ mkHsWrapCo co_res $
         SectionL arg1' (mkLHsWrapCo co_fn op') }
419 420 421

tcExpr (ExplicitTuple tup_args boxity) res_ty
  | all tupArgPresent tup_args
422
  = do { let tup_tc = tupleTyCon boxity (length tup_args)
423 424
       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
       ; tup_args1 <- tcTupArgs tup_args arg_tys
425
       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
426

427 428 429
  | otherwise
  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
    do { let kind = case boxity of { Boxed   -> liftedTypeKind
430
                                   ; Unboxed -> openTypeKind }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
431
             arity = length tup_args
432
             tup_tc = tupleTyCon boxity arity
433 434 435

       ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
       ; let actual_res_ty
436 437
               = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args]
                          (mkTyConApp tup_tc arg_tys)
438

439 440 441 442
       ; coi <- unifyType actual_res_ty res_ty

       -- Handle tuple sections where
       ; tup_args1 <- tcTupArgs tup_args arg_tys
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
443

444
       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
445

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
446
tcExpr (ExplicitList _ witness exprs) res_ty
447 448
  = case witness of
      Nothing   -> do  { (coi, elt_ty) <- matchExpectedListTy res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
449
                       ; exprs' <- mapM (tc_elt elt_ty) exprs
450 451 452 453 454 455 456
                       ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') }

      Just fln -> do  { list_ty <- newFlexiTyVarTy liftedTypeKind
                     ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty)
                     ; (coi, elt_ty) <- matchExpectedListTy list_ty
                     ; exprs' <- mapM (tc_elt elt_ty) exprs
                     ; return $ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
457
     where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
458

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
459 460 461 462
tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
  = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
        ; exprs' <- mapM (tc_elt elt_ty) exprs
        ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
463 464
  where
    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
465

Austin Seipp's avatar
Austin Seipp committed
466 467 468
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
469
                Let, case, if, do
Austin Seipp's avatar
Austin Seipp committed
470 471 472
*                                                                      *
************************************************************************
-}
473

474
tcExpr (HsLet (L l binds) expr) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
475 476
  = do  { (binds', expr') <- tcLocalBinds binds $
                             tcMonoExpr expr res_ty
477
        ; return (HsLet (L l binds') expr') }
478

479
tcExpr (HsCase scrut matches) exp_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
480 481 482 483 484 485 486 487 488 489 490 491 492 493
  = do  {  -- We used to typecheck the case alternatives first.
           -- The case patterns tend to give good type info to use
           -- when typechecking the scrutinee.  For example
           --   case (map f) of
           --     (x:xs) -> ...
           -- will report that map is applied to too few arguments
           --
           -- But now, in the GADT world, we need to typecheck the scrutinee
           -- first, to get type info that may be refined in the case alternatives
          (scrut', scrut_ty) <- tcInferRho scrut

        ; traceTc "HsCase" (ppr scrut_ty)
        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
        ; return (HsCase scrut' matches') }
494
 where
495
    match_ctxt = MC { mc_what = CaseAlt,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
496
                      mc_body = tcBody }
497

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
498
tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
499 500 501 502 503
  = do { pred' <- tcMonoExpr pred boolTy
       ; b1' <- tcMonoExpr b1 res_ty
       ; b2' <- tcMonoExpr b2 res_ty
       ; return (HsIf Nothing pred' b1' b2') }

504
tcExpr (HsIf (Just fun) pred b1 b2) res_ty   -- Note [Rebindable syntax for if]
505
  = do { pred_ty <- newFlexiTyVarTy openTypeKind
506 507 508 509
       ; b1_ty   <- newFlexiTyVarTy openTypeKind
       ; b2_ty   <- newFlexiTyVarTy openTypeKind
       ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
       ; fun'  <- tcSyntaxOp IfOrigin fun if_ty
510
       ; pred' <- tcMonoExpr pred pred_ty
511 512 513 514 515 516 517
       ; b1'   <- tcMonoExpr b1 b1_ty
       ; b2'   <- tcMonoExpr b2 b2_ty
       -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
       -- so maybe we should use the code for function applications
       -- (which would allow ifThenElse to be higher rank).
       -- But it's a little awkward, so I'm leaving it alone for now
       -- and it maintains uniformity with other rebindable syntax
518
       ; return (HsIf (Just fun') pred' b1' b2') }
519

520 521 522 523 524
tcExpr (HsMultiIf _ alts) res_ty
  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
       ; return $ HsMultiIf res_ty alts' }
  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }

525 526
tcExpr (HsDo do_or_lc stmts _) res_ty
  = tcDoStmts do_or_lc stmts res_ty
527

528
tcExpr (HsProc pat cmd) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
529 530
  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
531

532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553
tcExpr (HsStatic expr) res_ty
  = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
        ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
        ; (expr', lie)    <- captureConstraints $
            addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
                             2 (ppr expr)
                       ) $
            tcPolyExprNC expr expr_ty
        -- Require the type of the argument to be Typeable.
        -- The evidence is not used, but asking the constraint ensures that
        -- the current implementation is as restrictive as future versions
        -- of the StaticPointers extension.
        ; typeableClass <- tcLookupClass typeableClassName
        ; _ <- emitWanted StaticOrigin $
                  mkTyConApp (classTyCon typeableClass)
                             [liftedTypeKind, expr_ty]
        -- Insert the static form in a global list for later validation.
        ; stWC <- tcg_static_wc <$> getGblEnv
        ; updTcRef stWC (andWC lie)
        ; return $ mkHsWrapCo co $ HsStatic expr'
        }

Austin Seipp's avatar
Austin Seipp committed
554
{-
555 556 557 558 559 560 561 562
Note [Rebindable syntax for if]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The rebindable syntax for 'if' uses the most flexible possible type
for conditionals:
  ifThenElse :: p -> b1 -> b2 -> res
to support expressions like this:

 ifThenElse :: Maybe a -> (a -> b) -> b -> b
Jan Stolarek's avatar
Jan Stolarek committed
563 564
 ifThenElse (Just a) f _ = f a
 ifThenElse Nothing  _ e = e
565 566 567 568 569 570 571

 example :: String
 example = if Just 2
              then \v -> show v
              else "No value"


Austin Seipp's avatar
Austin Seipp committed
572 573
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
574
                Record construction and update
Austin Seipp's avatar
Austin Seipp committed
575 576 577
*                                                                      *
************************************************************************
-}
578

579
tcExpr (RecordCon { rcon_con_name = L loc con_name, rcon_flds = rbinds }) res_ty
Matthew Pickering's avatar
Matthew Pickering committed
580
  = do  { con_like <- tcLookupConLike con_name
581

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
582
        -- Check for missing fields
Matthew Pickering's avatar
Matthew Pickering committed
583
        ; checkMissingFields con_like rbinds
584

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
585
        ; (con_expr, con_tau) <- tcInferId con_name
Matthew Pickering's avatar
Matthew Pickering committed
586
        ; let arity = conLikeArity con_like
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
587
              (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
Matthew Pickering's avatar
Matthew Pickering committed
588 589 590 591 592 593
        ; case conLikeWrapId_maybe con_like of
               Nothing -> nonBidirectionalErr (conLikeName con_like)
               Just con_id -> do {
                  co_res <- unifyType actual_res_ty res_ty
                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
                ; return $ mkHsWrapCo co_res $
594 595 596 597
                    RecordCon { rcon_con_name = L loc con_id
                              , rcon_con_expr = con_expr
                              , rcon_con_like = con_like
                              , rcon_flds = rbinds' } } }
598

Austin Seipp's avatar
Austin Seipp committed
599
{-
600 601 602 603
Note [Type of a record update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The main complication with RecordUpd is that we need to explicitly
handle the *non-updated* fields.  Consider:
604

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
605 606 607 608 609 610
        data T a b c = MkT1 { fa :: a, fb :: (b,c) }
                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
                     | MkT3 { fd :: a }

        upd :: T a b c -> (b',c) -> T a b' c
        upd t x = t { fb = x}
611

612 613
The result type should be (T a b' c)
not (T a b c),   because 'b' *is not* mentioned in a non-updated field
Gabor Greif's avatar
typos  
Gabor Greif committed
614
not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
615 616
NB that it's not good enough to look at just one constructor; we must
look at them all; cf Trac #3219
617

618
After all, upd should be equivalent to:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
619 620 621 622
        upd t x = case t of
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b
                        MkT3 d   -> error ...
623 624 625

So we need to give a completely fresh type to the result record,
and then constrain it by the fields that are *not* updated ("p" above).
626
We call these the "fixed" type variables, and compute them in getFixedTyVars.
627 628

Note that because MkT3 doesn't contain all the fields being updated,
629 630
its RHS is simply an error, so it doesn't impose any type constraints.
Hence the use of 'relevant_cont'.
631

Gabor Greif's avatar
Gabor Greif committed
632
Note [Implicit type sharing]
633 634
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We also take into account any "implicit" non-update fields.  For example
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
635
        data T a b where { MkT { f::a } :: T a a; ... }
636 637 638
So the "real" type of MkT is: forall ab. (a~b) => a -> T a b

Then consider
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
639
        upd t x = t { f=x }
640
We infer the type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
641 642 643
        upd :: T a b -> a -> T a b
        upd (t::T a b) (x::a)
           = case t of { MkT (co:a~b) (_:a) -> MkT co x }
644
We can't give it the more general type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
645
        upd :: T a b -> c -> T c b
646 647 648 649 650 651 652 653

Note [Criteria for update]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to allow update for existentials etc, provided the updated
field isn't part of the existential. For example, this should be ok.
  data T a where { MkT { f1::a, f2::b->b } :: T a }
  f :: T a -> b -> T b
  f t b = t { f1=b }
654

655 656 657 658 659 660
The criterion we use is this:

  The types of the updated fields
  mention only the universally-quantified type variables
  of the data constructor

661
NB: this is not (quite) the same as being a "naughty" record selector
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
662
(See Note [Naughty record selectors]) in TcTyClsDecls), at least
663 664 665 666 667 668 669
in the case of GADTs. Consider
   data T a where { MkT :: { f :: a } :: T [a] }
Then f is not "naughty" because it has a well-typed record selector.
But we don't allow updates for 'f'.  (One could consider trying to
allow this, but it makes my head hurt.  Badly.  And no one has asked
for it.)

670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685
In principle one could go further, and allow
  g :: T a -> T a
  g t = t { f2 = \x -> x }
because the expression is polymorphic...but that seems a bridge too far.

Note [Data family example]
~~~~~~~~~~~~~~~~~~~~~~~~~~
    data instance T (a,b) = MkT { x::a, y::b }
  --->
    data :TP a b = MkT { a::a, y::b }
    coTP a b :: T (a,b) ~ :TP a b

Suppose r :: T (t1,t2), e :: t3
Then  r { x=e } :: T (t3,t1)
  --->
      case r |> co1 of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
686
        MkT x y -> MkT e y |> co2
687
      where co1 :: T (t1,t2) ~ :TP t1 t2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
688
            co2 :: :TP t3 t2 ~ T (t3,t2)
689 690 691 692 693 694 695 696 697
The wrapping with co2 is done by the constructor wrapper for MkT

Outgoing invariants
~~~~~~~~~~~~~~~~~~~
In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):

  * cons are the data constructors to be updated

  * in_inst_tys, out_inst_tys have same length, and instantiate the
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
698 699
        *representation* tycon of the data cons.  In Note [Data
        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
Matthew Pickering's avatar
Matthew Pickering committed
700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732

Note [Mixed Record Field Updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Consider the following pattern synonym.

  data MyRec = MyRec { foo :: Int, qux :: String }

  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}

This allows updates such as the following

  updater :: MyRec -> MyRec
  updater a = a {f1 = 1 }

It would also make sense to allow the following update (which we reject).

  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"

This leads to confusing behaviour when the selectors in fact refer the same
field.

  updater a = a {f1 = 1, foo = 2} ==? ???

For this reason, we reject a mixture of pattern synonym and normal record
selectors in the same update block. Although of course we still allow the
following.

  updater a = (a {f1 = 1}) {foo = 2}

  > updater (MyRec 0 "str")
  MyRec 2 "str"

Austin Seipp's avatar
Austin Seipp committed
733
-}
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
734

735
tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
Matthew Pickering's avatar
Matthew Pickering committed
736 737
  = ASSERT( notNull rbnds )
    do  {
738
        -- STEP -1  See Note [Disambiguating record fields]
739 740 741 742 743
        -- After this we know that rbinds is unambiguous
        rbinds <- disambiguateRecordBinds record_expr rbnds res_ty
        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
              upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
              sel_ids      = map selectorAmbiguousFieldOcc upd_flds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
744 745
        -- STEP 0
        -- Check that the field names are really field names
Matthew Pickering's avatar
Matthew Pickering committed
746 747
        -- and they are all field names for proper records or
        -- all field names for pattern synonyms.
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
748
        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
749
                         | fld <- rbinds,
Matthew Pickering's avatar
Matthew Pickering committed
750
                           -- Excludes class ops
751
                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),
Matthew Pickering's avatar
Matthew Pickering committed
752
                           not (isRecordSelector sel_id),
753
                           let fld_name = idName sel_id ]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
754
        ; unless (null bad_guys) (sequence bad_guys >> failM)
Matthew Pickering's avatar
Matthew Pickering committed
755 756 757 758 759 760
        -- See note [Mixed Record Selectors]
        ; let (data_sels, pat_syn_sels) =
                partition isDataConRecordSelector sel_ids
        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
        ; checkTc ( null data_sels || null pat_syn_sels )
                  ( mixedSelectors data_sels pat_syn_sels )
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
761 762 763 764 765

        -- STEP 1
        -- Figure out the tycon and data cons from the first field name
        ; let   -- It's OK to use the non-tc splitters here (for a selector)
              sel_id : _  = sel_ids
Matthew Pickering's avatar
Matthew Pickering committed
766 767 768 769 770 771 772 773 774 775 776
              mtycon  =
                case idDetails sel_id of
                  RecSelId (RecSelData tycon) _ -> Just tycon
                  _ -> Nothing
              con_likes  =
                case idDetails sel_id of
                  RecSelId (RecSelData tc) _ ->
                    map RealDataCon (tyConDataCons tc)
                  RecSelId (RecSelPatSyn ps) _ ->
                    [PatSynCon ps]
                  _ -> panic "tcRecordUpd"
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
777 778
                -- NB: for a data type family, the tycon is the instance tycon

Matthew Pickering's avatar
Matthew Pickering committed
779
              relevant_cons   = conLikesWithFields con_likes upd_fld_occs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
780 781 782 783 784 785 786
                -- A constructor is only relevant to this process if
                -- it contains *all* the fields that are being updated
                -- Other ones will cause a runtime error if they occur

        -- Step 2
        -- Check that at least one constructor has all the named fields
        -- i.e. has an empty set of bad fields returned by badFields
Matthew Pickering's avatar
Matthew Pickering committed
787 788 789 790 791 792 793 794 795 796 797 798 799 800 801
        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)

        -- Take apart a representative constructor
        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
              (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) =
                conLikeFullSig con1
              con1_flds = map flLabel $ conLikeFieldLabels con1
              def_res_ty  = conLikeResTy con1
              con1_res_ty =
                (maybe def_res_ty mkFamilyTyConApp mtycon) (mkTyVarTys con1_tvs)

        -- Check that we're not dealing with a unidirectional pattern
        -- synonym
        ; unless (isJust $ conLikeWrapId_maybe con1)
                  (nonBidirectionalErr (conLikeName con1))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
802 803 804 805

        -- STEP 3    Note [Criteria for update]
        -- Check that each updated field is polymorphic; that is, its type
        -- mentions only the universally-quantified variables of the data con
806 807 808 809
        ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
              bad_upd_flds = filter bad_fld flds1_w_tys
              con1_tv_set  = mkVarSet con1_tvs
              bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
810 811 812 813 814 815 816 817 818 819
                                      not (tyVarsOfType ty `subVarSet` con1_tv_set)
        ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)

        -- STEP 4  Note [Type of a record update]
        -- Figure out types for the scrutinee and result
        -- Both are of form (T a b c), with fresh type variables, but with
        -- common variables where the scrutinee and result must have the same type
        -- These are variables that appear in *any* arg of *any* of the
        -- relevant constructors *except* in the updated fields
        --
820
        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
821
              is_fixed_tv tv = tv `elemVarSet` fixed_tvs
822 823 824

              mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType)
              -- Deals with instantiation of kind variables
825
              --   c.f. TcMType.tcInstTyVars
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
826 827
              mk_inst_ty subst (tv, result_inst_ty)
                | is_fixed_tv tv   -- Same as result type
828
                = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
829
                | otherwise        -- Fresh type, of correct kind
830 831 832
                = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv))
                     ; return (extendTvSubst subst tv new_ty, new_ty) }

833 834
        ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs
        ; let result_inst_tys = mkTyVarTys con1_tvs'
835

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
836 837
        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst
                                                      (con1_tvs `zip` result_inst_tys)
838

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
839 840 841
        ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty
              scrut_ty      = TcType.substTy scrut_subst  con1_res_ty
              con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
842

843 844
        ; co_res <- unifyType rec_res_ty res_ty

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
845 846 847
        -- STEP 5
        -- Typecheck the thing to be updated, and the bindings
        ; record_expr' <- tcMonoExpr record_expr scrut_ty
848
        ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
849 850

        -- STEP 6: Deal with the stupid theta
Matthew Pickering's avatar
Matthew Pickering committed
851
        ; let theta' = substTheta scrut_subst (conLikeStupidTheta con1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
852 853 854
        ; instStupidTheta RecordUpdOrigin theta'

        -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
Matthew Pickering's avatar
Matthew Pickering committed
855
        ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe =<< mtycon
Joachim Breitner's avatar
Joachim Breitner committed
856
                       = mkWpCast (mkTcUnbranchedAxInstCo Representational co_con scrut_inst_tys)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
857 858
                       | otherwise
                       = idHsWrapper
Matthew Pickering's avatar
Matthew Pickering committed
859 860 861 862 863 864 865

        -- Step 8: Check that the req constraints are satisfied
        -- For normal data constructors req_theta is empty but we must do
        -- this check for pattern synonyms.
        ; let req_theta' = substTheta scrut_subst req_theta
        ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
866
        -- Phew!
867
        ; return $ mkHsWrapCo co_res $
868 869 870 871
          RecordUpd { rupd_expr = mkLHsWrap scrut_co record_expr'
                    , rupd_flds = rbinds'
                    , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys
                    , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
872

873
tcExpr (HsRecFld f) res_ty
874
    = tcCheckRecSelId f res_ty
875

Austin Seipp's avatar
Austin Seipp committed
876 877 878
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
879 880 881
        Arithmetic sequences                    e.g. [a,b..]
        and their parallel-array counterparts   e.g. [: a,b.. :]

Austin Seipp's avatar
Austin Seipp committed
882 883 884
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
885

886 887
tcExpr (ArithSeq _ witness seq) res_ty
  = tcArithSeq witness seq res_ty
888

889
tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
890 891 892 893 894 895 896
  = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
        ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
                                 (idName enumFromToP) elt_ty
        ; return $ mkHsWrapCo coi
897
                     (PArrSeq enum_from_to (FromTo expr1' expr2')) }
898

899
tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
900 901 902 903 904 905 906 907
  = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; expr3' <- tcPolyExpr expr3 elt_ty
        ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
        ; eft <- newMethodFromName (PArrSeqOrigin seq)
                      (idName enumFromThenToP) elt_ty        -- !!!FIXME: chak
        ; return $ mkHsWrapCo coi
908
                     (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
909

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
910
tcExpr (PArrSeq _ _) _
911
  = panic "TcExpr.tcExpr: Infinite parallel array!"
912 913
    -- the parser shouldn't have generated it and the renamer shouldn't have
    -- let it through
914

Austin Seipp's avatar
Austin Seipp committed
915 916 917
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
918
                Template Haskell
Austin Seipp's avatar
Austin Seipp committed
919 920 921
*                                                                      *
************************************************************************
-}
922

923
tcExpr (HsSpliceE splice)        res_ty = tcSpliceExpr splice res_ty
924 925
tcExpr (HsBracket brack)         res_ty = tcTypedBracket   brack res_ty
tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
926

Austin Seipp's avatar
Austin Seipp committed
927 928 929
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
930
                Catch-all
Austin Seipp's avatar
Austin Seipp committed
931 932 933
*                                                                      *
************************************************************************
-}
934

935
tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
936
  -- Include ArrForm, ArrApp, which shouldn't appear at all
937
  -- Also HsTcBracketOut, HsQuasiQuoteE
938

Austin Seipp's avatar
Austin Seipp committed
939 940 941
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
942
                Arithmetic sequences [a..b] etc
Austin Seipp's avatar
Austin Seipp committed
943 944 945
*                                                                      *
************************************************************************
-}
946 947 948 949 950 951 952

tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType
           -> TcM (HsExpr TcId)

tcArithSeq witness seq@(From expr) res_ty
  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
       ; expr' <- tcPolyExpr expr elt_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
953 954
       ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
                              enumFromName elt_ty
955
       ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
956

957 958 959 960
tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
       ; expr1' <- tcPolyExpr expr1 elt_ty
       ; expr2' <- tcPolyExpr expr2 elt_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
961 962
       ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
                              enumFromThenName elt_ty
963
       ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
964

965 966 967 968
tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
       ; expr1' <- tcPolyExpr expr1 elt_ty
       ; expr2' <- tcPolyExpr expr2 elt_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
969 970
       ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
                              enumFromToName elt_ty
971 972 973 974 975 976 977
       ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) }

tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; expr3' <- tcPolyExpr expr3 elt_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
978 979
        ; eft <- newMethodFromName (ArithSeqOrigin seq)
                              enumFromThenToName elt_ty
980 981 982
        ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }

-----------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
983
arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType
984 985 986 987 988 989 990 991 992 993
              -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id))
arithSeqEltType Nothing res_ty
  = do { (coi, elt_ty) <- matchExpectedListTy res_ty
       ; return (coi, elt_ty, Nothing) }
arithSeqEltType (Just fl) res_ty
  = do { list_ty <- newFlexiTyVarTy liftedTypeKind
       ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty)
       ; (coi, elt_ty) <- matchExpectedListTy list_ty
       ; return (coi, elt_ty, Just fl') }

Austin Seipp's avatar
Austin Seipp committed
994 995 996
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
997
                Applications
Austin Seipp's avatar
Austin Seipp committed
998 999 1000
*                                                                      *
************************************************************************
-}
1001

1002 1003 1004 1005 1006 1007 1008
tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
      -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args

tcApp (L _ (HsPar e)) args res_ty
  = tcApp e args res_ty

tcApp (L _ (HsApp e1 e2)) args res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1009
  = tcApp e1 (e2:args) res_ty   -- Accumulate the arguments
1010 1011 1012 1013 1014 1015

tcApp (L loc (HsVar fun)) args res_ty
  | fun `hasKey` tagToEnumKey
  , [arg] <- args
  = tcTagToEnum loc fun arg res_ty

1016 1017 1018 1019
  | fun `hasKey` seqIdKey
  , [arg1,arg2] <- args
  = tcSeq loc fun arg1 arg2 res_ty

1020 1021 1022 1023 1024 1025 1026 1027
-- Look for applications of ambiguous record selectors to arguments
-- with type signatures, see Note [Disambiguating record fields]
tcApp (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg:_) res_ty
  | Just sig_ty <- obviousSig arg
  = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
       ; sel_name <- disambiguateSelector lbl sig_tc_ty
       ; tcApp (L loc (HsRecFld (Unambiguous lbl sel_name))) args res_ty }

1028
tcApp fun args res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1029 1030
  = do  {   -- Type-check the function
        ; (fun1, fun_tau) <- tcInferFun fun
1031

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1032 1033 1034
            -- Extract its argument types
        ; (co_fun, expected_arg_tys, actual_res_ty)
              <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
1035

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1036
        -- Typecheck the result, thereby propagating
1037 1038
        -- info (if any) from result into the argument types
        -- Both actual_res_ty and res_ty are deeply skolemised
1039 1040 1041 1042
        -- Rather like tcWrapResult, but (perhaps for historical reasons)
        -- we do this before typechecking the arguments
        ; wrap_res <- addErrCtxtM (funResCtxt True (unLoc fun) actual_res_ty res_ty) $
                      tcSubTypeDS_NC GenSigCtxt actual_res_ty res_ty