TcExpr.hs 114 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
{-
2
%
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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
9
{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
10
{-# LANGUAGE FlexibleContexts #-}
11
{-# LANGUAGE TypeFamilies #-}
12

13
module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
14
                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
15
16
                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
                tcCheckId,
Adam Gundry's avatar
Adam Gundry committed
17
18
                addExprErrCtxt,
                getFixedTyVars ) where
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
19

20
#include "HsVersions.h"
21

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

25
26
import HsSyn
import TcHsSyn
27
import TcRnMonad
28
29
30
import TcUnify
import BasicTypes
import Inst
31
32
import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds )
import TcSigs           ( tcUserTypeSig, tcInstSig )
33
import TcSimplify       ( simplifyInfer, InferMode(..) )
34
import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
35
import FamInstEnv       ( FamInstEnvs )
36
37
import RnEnv            ( addUsedGRE )
import RnUtils          ( addNameClashErrRn, unknownSubordinateErr )
38
39
40
41
import TcEnv
import TcArrows
import TcMatches
import TcHsType
Matthew Pickering's avatar
Matthew Pickering committed
42
import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
43
44
45
import TcPat
import TcMType
import TcType
46
import DsMonad
47
import Id
Matthew Pickering's avatar
Matthew Pickering committed
48
import IdInfo
Gergő Érdi's avatar
Gergő Érdi committed
49
import ConLike
50
import DataCon
Matthew Pickering's avatar
Matthew Pickering committed
51
import PatSyn
52
import Name
53
54
import NameEnv
import NameSet
Adam Gundry's avatar
Adam Gundry committed
55
import RdrName
56
import TyCon
57
import TyCoRep
58
import Type
59
import TcEvidence
60
61
import VarSet
import TysWiredIn
62
import TysPrim( intPrimTy )
63
import PrimOp( tagToEnumKey )
64
import PrelNames
65
import DynFlags
66
import SrcLoc
67
import Util
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
68
import VarEnv  ( emptyTidyEnv )
69
70
import ListSetOps
import Maybes
71
72
import Outputable
import FastString
73
import Control.Monad
74
import Class(classTyCon)
David Feuer's avatar
David Feuer committed
75
import UniqSet ( nonDetEltsUniqSet )
76
77
import qualified GHC.LanguageExtensions as LangExt

78
79
import Data.Function
import Data.List
80
import Data.Either
81
import qualified Data.Set as Set
82

Austin Seipp's avatar
Austin Seipp committed
83
84
85
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
86
\subsection{Main wrappers}
Austin Seipp's avatar
Austin Seipp committed
87
88
89
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
90

91
tcPolyExpr, tcPolyExprNC
92
93
94
  :: LHsExpr GhcRn         -- Expression to type check
  -> TcSigmaType           -- Expected type (could be a polytype)
  -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type
95

96
97
-- tcPolyExpr is a convenient place (frequent but not too frequent)
-- place to add context information.
98
99
100
-- The NC version does not do so, usually because the caller wants
-- to do so himself.

101
102
103
104
tcPolyExpr   expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)
tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)

-- these versions take an ExpType
105
106
tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType
                              -> TcM (LHsExpr GhcTcId)
107
tc_poly_expr expr res_ty
108
  = addExprErrCtxt expr $
109
    do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
110

111
112
tc_poly_expr_nc (L loc expr) res_ty
  = do { traceTc "tcPolyExprNC" (ppr res_ty)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
113
       ; (wrap, expr')
114
           <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
115
116
117
118
119
              setSrcSpan loc $
                -- NB: setSrcSpan *after* skolemising, so we get better
                -- skolem locations
              tcExpr expr res_ty
       ; return $ L loc (mkHsWrap wrap expr') }
120
121

---------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
122
tcMonoExpr, tcMonoExprNC
123
    :: LHsExpr GhcRn     -- Expression to type check
124
    -> ExpRhoType        -- Expected type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
125
                         -- Definitely no foralls at the top
126
    -> TcM (LHsExpr GhcTcId)
127
128
129
130
131
132

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

tcMonoExprNC (L loc expr) res_ty
133
  = setSrcSpan loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
134
135
    do  { expr' <- tcExpr expr res_ty
        ; return (L loc expr') }
136

137
---------------
138
tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
139
140
141
142
143
144
                                                    , TcSigmaType )
-- Infer a *sigma*-type.
tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)

tcInferSigmaNC (L loc expr)
  = setSrcSpan loc $
145
    do { (expr', sigma) <- tcInferNoInst (tcExpr expr)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
146
147
       ; return (L loc expr', sigma) }

148
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
149
-- Infer a *rho*-type. The return type is always (shallowly) instantiated.
150
151
tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
152
153
tcInferRhoNC expr
  = do { (expr', sigma) <- tcInferSigmaNC expr
154
       ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
155
       ; return (mkLHsWrap wrap expr', rho) }
156

sof's avatar
sof committed
157

Austin Seipp's avatar
Austin Seipp committed
158
159
160
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
161
        tcExpr: the main expression typechecker
Austin Seipp's avatar
Austin Seipp committed
162
163
*                                                                      *
************************************************************************
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
164
165

NB: The res_ty is always deeply skolemised.
Austin Seipp's avatar
Austin Seipp committed
166
-}
sof's avatar
sof committed
167

168
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
169
tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
170
tcExpr (HsUnboundVar uv)  res_ty = tcUnboundId uv res_ty
171

172
173
tcExpr e@(HsApp {})     res_ty = tcApp1 e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
174

175
176
177
tcExpr e@(HsLit lit) res_ty
  = do { let lit_ty = hsLitType lit
       ; tcWrapResult e (HsLit (convertLit lit)) lit_ty res_ty }
178

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
179
180
tcExpr (HsPar expr)   res_ty = do { expr' <- tcMonoExprNC expr res_ty
                                  ; return (HsPar expr') }
181

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

186
tcExpr (HsTickPragma src info srcInfo expr) res_ty
187
  = do { expr' <- tcMonoExpr expr res_ty
188
       ; return (HsTickPragma src info srcInfo expr') }
189

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
194
tcExpr (HsOverLit lit) res_ty
195
  = do  { lit' <- newOverloadedLit lit res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
196
        ; return (HsOverLit lit') }
197
198

tcExpr (NegApp expr neg_expr) res_ty
199
200
201
202
  = do  { (expr', neg_expr')
            <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
               \[arg_ty] ->
               tcMonoExpr expr (mkCheckExpType arg_ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
203
        ; return (NegApp expr' neg_expr') }
204

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
205
206
tcExpr e@(HsIPVar x) res_ty
  = do {   {- Implicit parameters must have a *tau-type* not a
207
208
209
              type scheme.  We enforce this by creating a fresh
              type variable as its type.  (Because res_ty may not
              be a tau-type.) -}
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
210
         ip_ty <- newOpenFlexiTyVarTy
211
       ; let ip_name = mkStrLitTy (hsIPNameFS x)
212
       ; ipClass <- tcLookupClass ipClassName
213
       ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
214
       ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))
215
                      ip_ty res_ty }
216
  where
Gabor Greif's avatar
Gabor Greif committed
217
  -- Coerces a dictionary for `IP "x" t` into `t`.
218
  fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
219
                          unwrapIP $ mkClassPred ipClass [x,ty]
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
220
  origin = IPOccOrigin x
221

222
223
224
225
226
227
228
229
230
231
232
233
tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
  = do { -- See Note [Type-checking overloaded labels]
         loc <- getSrcSpanM
       ; case mb_fromLabel of
           Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty
           Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName
                         ; alpha <- newFlexiTyVarTy liftedTypeKind
                         ; let pred = mkClassPred isLabelClass [lbl, alpha]
                         ; loc <- getSrcSpanM
                         ; var <- emitWantedEvVar origin pred
                         ; tcWrapResult e (fromDict pred (HsVar (L loc var)))
                                        alpha res_ty } }
Adam Gundry's avatar
Adam Gundry committed
234
  where
235
236
  -- Coerces a dictionary for `IsLabel "x" t` into `t`,
  -- or `HasField "x" r a into `r -> a`.
237
  fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
238
  origin = OverLabelOrigin l
239
240
241
242
243
  lbl = mkStrLitTy l

  applyFromLabel loc fromLabel =
    L loc (HsVar (L loc fromLabel)) `HsAppType`
      mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l)))
Adam Gundry's avatar
Adam Gundry committed
244

245
tcExpr (HsLam match) res_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
246
247
  = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
        ; return (mkHsWrap wrap (HsLam match')) }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
248
249
  where
    match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
250
    herald = sep [ text "The lambda expression" <+>
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
251
                   quotes (pprSetDepth (PartWay 1) $
252
                           pprMatches match),
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
253
                        -- The pprSetDepth makes the abstraction print briefly
254
                   text "has"]
255

Simon Peyton Jones's avatar
Simon Peyton Jones committed
256
257
tcExpr e@(HsLamCase matches) res_ty
  = do { (matches', wrap)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
258
259
260
           <- tcMatchLambda msg match_ctxt matches res_ty
           -- The laziness annotation is because we don't want to fail here
           -- if there are multiple arguments
Simon Peyton Jones's avatar
Simon Peyton Jones committed
261
262
263
264
265
       ; return (mkHsWrap wrap $ HsLamCase matches') }
  where
    msg = sep [ text "The function" <+> quotes (ppr e)
              , text "requires"]
    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
266

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
267
tcExpr e@(ExprWithTySig expr sig_ty) res_ty
268
269
270
  = do { let loc = getLoc (hsSigWcType sig_ty)
       ; sig_info <- checkNoErrs $  -- Avoid error cascade
                     tcUserTypeSig loc sig_ty Nothing
271
       ; (expr', poly_ty) <- tcExprSig expr sig_info
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
272
273
       ; let expr'' = ExprWithTySigOut expr' sig_ty
       ; tcWrapResult e expr'' poly_ty res_ty }
274

Adam Gundry's avatar
Adam Gundry committed
275
276
277
{-
Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
278
Recall that we have
Adam Gundry's avatar
Adam Gundry committed
279

280
  module GHC.OverloadedLabels where
Adam Gundry's avatar
Adam Gundry committed
281
    class IsLabel (x :: Symbol) a where
282
283
284
285
286
287
288
289
290
291
      fromLabel :: a

We translate `#foo` to `fromLabel @"foo"`, where we use

 * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not
 * `GHC.OverloadedLabels.fromLabel`.

In the `RebindableSyntax` case, the renamer will have filled in the
first field of `HsOverLabel` with the `fromLabel` function to use, and
we simply apply it to the appropriate visible type argument.
Adam Gundry's avatar
Adam Gundry committed
292

293
294
295
296
297
In the `OverloadedLabels` case, 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 `alpha` (just like for implicit parameters).
Adam Gundry's avatar
Adam Gundry committed
298
299
300
301

-}


Austin Seipp's avatar
Austin Seipp committed
302
303
304
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
305
                Infix operators and sections
Austin Seipp's avatar
Austin Seipp committed
306
307
*                                                                      *
************************************************************************
308

309
310
311
Note [Left sections]
~~~~~~~~~~~~~~~~~~~~
Left sections, like (4 *), are equivalent to
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
312
        \ x -> (*) 4 x,
313
or, if PostfixOperators is enabled, just
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
314
        (*) 4
315
316
317
318
319
320
321
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
322
People write
323
   runST $ blah
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
324
so much, where
325
326
   runST :: (forall s. ST s a) -> a
that I have finally given in and written a special type-checking
327
rule just for saturated applications of ($).
328
  * Infer the type of the first argument
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
329
  * Decompose it; should be of form (arg2_ty -> res_ty),
330
331
332
333
334
335
336
337
       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:
338
339
340
341
342
   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
343
344
    case x of _ -> (# p,q #)

Gabor Greif's avatar
Gabor Greif committed
345
So it seems more uniform to treat 'seq' as if it was a language
346
construct.
347

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
348
See also Note [seqId magic] in MkId
Austin Seipp's avatar
Austin Seipp committed
349
-}
350

351
tcExpr expr@(OpApp arg1 op fix arg2) res_ty
352
  | (L loc (HsVar (L lv op_name))) <- op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
353
  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
354
  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
355
356
357
358
359
       ; let arg2_exp_ty = res_ty
       ; arg1' <- tcArg op arg1 arg1_ty 1
       ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $
                  tc_poly_expr_nc arg2 arg2_exp_ty
       ; arg2_ty <- readExpType arg2_exp_ty
360
       ; op_id <- tcLookupId op_name
361
362
       ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])
                                   (HsVar (L lv op_id)))
363
364
       ; return $ OpApp arg1' op' fix arg2' }

365
  | (L loc (HsVar (L lv op_name))) <- op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
366
  , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
367
  = do { traceTc "Application rule" (ppr op)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
368
       ; (arg1', arg1_ty) <- tcInferSigma arg1
369

370
       ; let doc   = text "The first argument of ($) takes"
371
             orig1 = lexprCtOrigin arg1
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
372
       ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
373
           matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty
374
375
376

         -- We have (arg1 $ arg2)
         -- So: arg1_ty = arg2_ty -> op_res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
377
         -- where arg2_sigma maybe polymorphic; that's the point
378

379
       ; arg2'  <- tcArg op arg2 arg2_sigma 2
380

381
       -- Make sure that the argument type has kind '*'
382
       --   ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
383
       -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
384
       --    (which gives a seg fault)
385
       --
386
387
       -- The *result* type can have any kind (Trac #8739),
       -- so we don't need to check anything for that
388
389
390
391
392
       ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind
           -- ignore the evidence. arg2_sigma must have type * or #,
           -- because we know arg2_sigma -> or_res_ty is well-kinded
           -- (because otherwise matchActualFunTys would fail)
           -- There's no possibility here of, say, a kind family reducing to *.
393

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
394
395
       ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty
                       -- op_res -> res
396

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
397
       ; op_id  <- tcLookupId op_name
398
       ; res_ty <- readExpType res_ty
399
400
401
402
       ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty
                                               , arg2_sigma
                                               , res_ty])
                                   (HsVar (L lv op_id)))
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
403
404
405
406
407
             -- arg1' :: arg1_ty
             -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
             -- wrap_res :: op_res_ty "->" res_ty
             -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty

408
             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
Richard Eisenberg's avatar
Richard Eisenberg committed
409
             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc
410
                     <.> wrap_arg1
Richard Eisenberg's avatar
Richard Eisenberg committed
411
             doc = text "When looking at the argument to ($)"
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
412

413
       ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }
414

415
416
417
418
419
420
421
422
423
  | (L loc (HsRecFld (Ambiguous lbl _))) <- op
  , Just sig_ty <- obviousSig (unLoc arg1)
    -- See Note [Disambiguating record fields]
  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
       ; sel_name <- disambiguateSelector lbl sig_tc_ty
       ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))
       ; tcExpr (OpApp arg1 op' fix arg2) res_ty
       }

424
425
  | otherwise
  = do { traceTc "Non Application rule" (ppr op)
426
       ; (wrap, op', [Left arg1', Left arg2'])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
427
           <- tcApp (Just $ mk_op_msg op)
428
                     op [Left arg1, Left arg2] res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
429
       ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
430

431
-- Right sections, equivalent to \ x -> x `op` expr, or
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
432
433
--      \ x -> op x expr

434
tcExpr expr@(SectionR op arg2) res_ty
435
  = do { (op', op_ty) <- tcInferFun op
436
437
       ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
                  <- matchActualFunTys (mk_op_msg op) fn_orig (Just op) 2 op_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
438
439
       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
                                 (mkFunTy arg1_ty op_res_ty) res_ty
440
       ; arg2' <- tcArg op arg2 arg2_ty 2
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
441
442
       ; return ( mkHsWrap wrap_res $
                  SectionR (mkLHsWrap wrap_fun op') arg2' ) }
443
444
445
446
447
  where
    fn_orig = lexprCtOrigin op
    -- It's important to use the origin of 'op', so that call-stacks
    -- come out right; they are driven by the OccurrenceOf CtOrigin
    -- See Trac #13285
448

449
tcExpr expr@(SectionL arg1 op) res_ty
450
  = do { (op', op_ty) <- tcInferFun op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
451
       ; dflags <- getDynFlags      -- Note [Left sections]
452
453
       ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
                         | otherwise                            = 2
454

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
455
       ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
456
           <- matchActualFunTys (mk_op_msg op) fn_orig (Just op)
457
                                n_reqd_args op_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
458
459
       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
                                 (mkFunTys arg_tys op_res_ty) res_ty
460
       ; arg1' <- tcArg op arg1 arg1_ty 1
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
461
462
       ; return ( mkHsWrap wrap_res $
                  SectionL arg1' (mkLHsWrap wrap_fn op') ) }
463
464
465
466
467
  where
    fn_orig = lexprCtOrigin op
    -- It's important to use the origin of 'op', so that call-stacks
    -- come out right; they are driven by the OccurrenceOf CtOrigin
    -- See Trac #13285
468

469
tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
470
  | all tupArgPresent tup_args
471
472
  = do { let arity  = length tup_args
             tup_tc = tupleTyCon boxity arity
473
       ; res_ty <- expTypeToType res_ty
474
       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
475
                           -- Unboxed tuples have RuntimeRep vars, which we
476
                           -- don't care about here
477
                           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
478
479
480
       ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
                                       Boxed   -> arg_tys
       ; tup_args1 <- tcTupArgs tup_args arg_tys'
481
       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
482

483
484
  | otherwise
  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
485
    do { let arity = length tup_args
486

487
488
489
       ; arg_tys <- case boxity of
           { Boxed   -> newFlexiTyVarTys arity liftedTypeKind
           ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
490
       ; let actual_res_ty
491
492
                 = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
                            (mkTupleTy boxity arg_tys)
493

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
494
495
496
       ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")
                             (Just expr)
                             actual_res_ty res_ty
497
498
499

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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
501
       ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
502

503
504
505
506
507
508
509
510
511
tcExpr (ExplicitSum alt arity expr _) res_ty
  = do { let sum_tc = sumTyCon arity
       ; res_ty <- expTypeToType res_ty
       ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
       ; -- Drop levity vars, we don't care about them here
         let arg_tys' = drop arity arg_tys
       ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))
       ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') }

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
512
tcExpr (ExplicitList _ witness exprs) res_ty
513
  = case witness of
514
515
      Nothing   -> do  { res_ty <- expTypeToType res_ty
                       ; (coi, elt_ty) <- matchExpectedListTy res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
516
                       ; exprs' <- mapM (tc_elt elt_ty) exprs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
517
518
                       ; return $
                         mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
519

520
521
522
523
524
525
526
527
528
      Just fln -> do { ((exprs', elt_ty), fln')
                         <- tcSyntaxOp ListOrigin fln
                                       [synKnownType intTy, SynList] res_ty $
                            \ [elt_ty] ->
                            do { exprs' <-
                                    mapM (tc_elt elt_ty) exprs
                               ; return (exprs', elt_ty) }

                     ; return $ ExplicitList elt_ty (Just fln') exprs' }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
529
     where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
530

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
531
tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
532
533
  = do  { res_ty <- expTypeToType res_ty
        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
534
        ; exprs' <- mapM (tc_elt elt_ty) exprs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
535
536
        ; return $
          mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' }
537
538
  where
    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
539

Austin Seipp's avatar
Austin Seipp committed
540
541
542
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
543
                Let, case, if, do
Austin Seipp's avatar
Austin Seipp committed
544
545
546
*                                                                      *
************************************************************************
-}
547

548
tcExpr (HsLet (L l binds) expr) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
549
550
  = do  { (binds', expr') <- tcLocalBinds binds $
                             tcMonoExpr expr res_ty
551
        ; return (HsLet (L l binds') expr') }
552

553
tcExpr (HsCase scrut matches) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
554
555
556
557
558
559
560
561
562
563
564
565
  = 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)
566
        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
567
        ; return (HsCase scrut' matches') }
568
 where
ross's avatar
ross committed
569
    match_ctxt = MC { mc_what = CaseAlt,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
570
                      mc_body = tcBody }
571

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
572
tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
573
  = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
574
575
576
577
       ; res_ty <- tauifyExpType res_ty
           -- Just like Note [Case branches must never infer a non-tau type]
           -- in TcMatches (See #10619)

578
579
580
581
       ; b1' <- tcMonoExpr b1 res_ty
       ; b2' <- tcMonoExpr b2 res_ty
       ; return (HsIf Nothing pred' b1' b2') }

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
582
tcExpr (HsIf (Just fun) pred b1 b2) res_ty
583
584
585
586
587
588
589
590
  = do { ((pred', b1', b2'), fun')
           <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
              \ [pred_ty, b1_ty, b2_ty] ->
              do { pred' <- tcPolyExpr pred pred_ty
                 ; b1'   <- tcPolyExpr b1   b1_ty
                 ; b2'   <- tcPolyExpr b2   b2_ty
                 ; return (pred', b1', b2') }
       ; return (HsIf (Just fun') pred' b1' b2') }
591

592
tcExpr (HsMultiIf _ alts) res_ty
593
594
  = do { res_ty <- if isSingleton alts
                   then return res_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
595
596
597
598
                   else tauifyExpType res_ty
             -- Just like TcMatches
             -- Note [Case branches must never infer a non-tau type]

599
600
       ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
       ; res_ty <- readExpType res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
601
       ; return (HsMultiIf res_ty alts') }
602
603
  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }

604
tcExpr (HsDo do_or_lc stmts _) res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
605
606
  = do { expr' <- tcDoStmts do_or_lc stmts res_ty
       ; return expr' }
607

608
tcExpr (HsProc pat cmd) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
609
610
  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
611

612
-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
613
-- See Note [Grand plan for static forms] in StaticPtrTable for an overview.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
614
615
616
617
618
619
-- To type check
--      (static e) :: p a
-- we want to check (e :: a),
-- and wrap (static e) in a call to
--    fromStaticPtr :: IsStatic p => StaticPtr a -> p a

620
tcExpr (HsStatic fvs expr) res_ty
621
622
  = do  { res_ty          <- expTypeToType res_ty
        ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
Facundo Domínguez's avatar
Facundo Domínguez committed
623
        ; (expr', lie)    <- captureConstraints $
624
            addErrCtxt (hang (text "In the body of a static form:")
Facundo Domínguez's avatar
Facundo Domínguez committed
625
626
627
                             2 (ppr expr)
                       ) $
            tcPolyExprNC expr expr_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
628

629
        -- Check that the free variables of the static form are closed.
David Feuer's avatar
David Feuer committed
630
        -- It's OK to use nonDetEltsUniqSet here as the only side effects of
631
        -- checkClosedInStaticForm are error messages.
David Feuer's avatar
David Feuer committed
632
        ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
633

Facundo Domínguez's avatar
Facundo Domínguez committed
634
635
636
637
638
        -- 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
639
        ; _ <- emitWantedEvVar StaticOrigin $
Facundo Domínguez's avatar
Facundo Domínguez committed
640
641
                  mkTyConApp (classTyCon typeableClass)
                             [liftedTypeKind, expr_ty]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
642

643
644
        -- Insert the constraints of the static form in a global list for later
        -- validation.
645
646
        ; emitStaticConstraints lie

647
648
649
650
651
        -- Wrap the static form with the 'fromStaticPtr' call.
        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
        ; let wrap = mkWpTyApps [expr_ty]
        ; loc <- getSrcSpanM
        ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr)
652
                                         (L loc (HsStatic fvs expr'))
Facundo Domínguez's avatar
Facundo Domínguez committed
653
654
        }

Austin Seipp's avatar
Austin Seipp committed
655
656
657
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
658
                Record construction and update
Austin Seipp's avatar
Austin Seipp committed
659
660
661
*                                                                      *
************************************************************************
-}
662

663
664
tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
                       , rcon_flds = rbinds }) res_ty
Matthew Pickering's avatar
Matthew Pickering committed
665
  = do  { con_like <- tcLookupConLike con_name
666

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
667
        -- Check for missing fields
Matthew Pickering's avatar
Matthew Pickering committed
668
        ; checkMissingFields con_like rbinds
669

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
670
671
672
673
674
        ; (con_expr, con_sigma) <- tcInferId con_name
        ; (con_wrap, con_tau) <-
            topInstantiate (OccurrenceOf con_name) con_sigma
              -- a shallow instantiation should really be enough for
              -- a data constructor.
Matthew Pickering's avatar
Matthew Pickering committed
675
        ; let arity = conLikeArity con_like
676
              Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
Matthew Pickering's avatar
Matthew Pickering committed
677
678
679
        ; case conLikeWrapId_maybe con_like of
               Nothing -> nonBidirectionalErr (conLikeName con_like)
               Just con_id -> do {
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
680
681
                  res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")
                                          (Just expr) actual_res_ty res_ty
Matthew Pickering's avatar
Matthew Pickering committed
682
                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
683
684
685
686
687
688
                ; return $
                  mkHsWrap res_wrap $
                  RecordCon { rcon_con_name = L loc con_id
                            , rcon_con_expr = mkHsWrap con_wrap con_expr
                            , rcon_con_like = con_like
                            , rcon_flds = rbinds' } } }
689

Austin Seipp's avatar
Austin Seipp committed
690
{-
691
692
693
694
Note [Type of a record update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The main complication with RecordUpd is that we need to explicitly
handle the *non-updated* fields.  Consider:
695

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
696
697
698
699
700
701
        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}
702

703
704
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
705
not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
706
707
NB that it's not good enough to look at just one constructor; we must
look at them all; cf Trac #3219
708

709
After all, upd should be equivalent to:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
710
711
712
713
        upd t x = case t of
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b
                        MkT3 d   -> error ...
714
715
716

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).
717
We call these the "fixed" type variables, and compute them in getFixedTyVars.
718
719

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

Gabor Greif's avatar
Gabor Greif committed
723
Note [Implicit type sharing]
724
725
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We also take into account any "implicit" non-update fields.  For example
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
726
        data T a b where { MkT { f::a } :: T a a; ... }
727
728
729
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
730
        upd t x = t { f=x }
731
We infer the type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
732
733
734
        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 }
735
We can't give it the more general type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
736
        upd :: T a b -> c -> T c b
737
738
739
740
741
742
743
744

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 }
745

746
747
748
749
750
751
The criterion we use is this:

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

752
NB: this is not (quite) the same as being a "naughty" record selector
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
753
(See Note [Naughty record selectors]) in TcTyClsDecls), at least
754
755
756
757
758
759
760
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.)

761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
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
777
        MkT x y -> MkT e y |> co2
778
      where co1 :: T (t1,t2) ~ :TP t1 t2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
779
            co2 :: :TP t3 t2 ~ T (t3,t2)
780
781
782
783
784
785
786
787
788
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
789
790
        *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
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822

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
823
-}
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
824

825
tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
Matthew Pickering's avatar
Matthew Pickering committed
826
  = ASSERT( notNull rbnds )
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
827
828
    do  { -- STEP -2: typecheck the record_expr, the record to be updated
          (record_expr', record_rho) <- tcInferRho record_expr
829

830
        -- STEP -1  See Note [Disambiguating record fields]
Adam Gundry's avatar
Adam Gundry committed
831
        -- After this we know that rbinds is unambiguous
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
832
        ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
Adam Gundry's avatar
Adam Gundry committed
833
834
835
        ; 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
836
837
        -- STEP 0
        -- Check that the field names are really field names
Matthew Pickering's avatar
Matthew Pickering committed
838
839
        -- 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
840
        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
Adam Gundry's avatar
Adam Gundry committed
841
                         | fld <- rbinds,
Matthew Pickering's avatar
Matthew Pickering committed
842
                           -- Excludes class ops
Adam Gundry's avatar
Adam Gundry committed
843
                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),
Matthew Pickering's avatar
Matthew Pickering committed
844
                           not (isRecordSelector sel_id),
Adam Gundry's avatar
Adam Gundry committed
845
                           let fld_name = idName sel_id ]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
846
        ; unless (null bad_guys) (sequence bad_guys >> failM)
Matthew Pickering's avatar
Matthew Pickering committed
847
848
849
850
851
852
        -- 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
853
854
855
856
857

        -- 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
858
859
860
861
862
863
864
865
866
867
868
869
870

              mtycon :: Maybe TyCon
              mtycon = case idDetails sel_id of
                          RecSelId (RecSelData tycon) _ -> Just tycon
                          _ -> Nothing

              con_likes :: [ConLike]
              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
871
872
                -- NB: for a data type family, the tycon is the instance tycon

873
              relevant_cons = conLikesWithFields con_likes upd_fld_occs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
874
875
876
877
878
879
880
                -- 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
881
882
883
884
        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)

        -- Take apart a representative constructor
        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
885
886
887
888
889
890
891
              (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _)
                 = conLikeFullSig con1
              con1_flds   = map flLabel $ conLikeFieldLabels con1
              con1_tv_tys = mkTyVarTys con1_tvs
              con1_res_ty = case mtycon of
                              Just tc -> mkFamilyTyConApp tc con1_tv_tys
                              Nothing -> conLikeResTy con1 con1_tv_tys
Matthew Pickering's avatar
Matthew Pickering committed
892
893
894
895
896

        -- 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
897
898
899
900

        -- 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
Adam Gundry's avatar
Adam Gundry committed
901
902
903
904
        ; 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 &&
905
                                      not (tyCoVarsOfType ty `subVarSet` con1_tv_set)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
906
907
908
909
910
911
912
913
914
        ; 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
        --
Adam Gundry's avatar
Adam Gundry committed
915
        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
916
              is_fixed_tv tv = tv `elemVarSet` fixed_tvs
917

918
              mk_inst_ty :: TCvSubst -> (TyVar,