TcExpr.hs 100 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

11
module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
12
                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
13 14
                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
                tcCheckId,
Adam Gundry's avatar
Adam Gundry committed
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
import TcUnify
import BasicTypes
import Inst
29 30 31
import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds
                        , tcUserTypeSig, tcExtendTyVarEnvFromSig )
import TcSimplify       ( simplifyInfer )
32
import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
33 34 35
import FamInstEnv       ( FamInstEnvs )
import RnEnv            ( addUsedGRE, addNameClashErrRn
                        , unknownSubordinateErr )
36 37 38 39
import TcEnv
import TcArrows
import TcMatches
import TcHsType
Matthew Pickering's avatar
Matthew Pickering committed
40
import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
41 42 43
import TcPat
import TcMType
import TcType
44
import DsMonad
45
import Id
Matthew Pickering's avatar
Matthew Pickering committed
46
import IdInfo
cactus's avatar
cactus committed
47
import ConLike
48
import DataCon
Matthew Pickering's avatar
Matthew Pickering committed
49
import PatSyn
50
import Name
Adam Gundry's avatar
Adam Gundry committed
51
import RdrName
52 53
import TyCon
import Type
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
54
import TysPrim        ( tYPE )
55
import TcEvidence
56 57
import VarSet
import TysWiredIn
58
import TysPrim( intPrimTy )
59
import PrimOp( tagToEnumKey )
60
import PrelNames
Adam Gundry's avatar
Adam Gundry committed
61
import MkId ( proxyHashId )
62
import DynFlags
63
import SrcLoc
64
import Util
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
65
import VarEnv  ( emptyTidyEnv )
66 67
import ListSetOps
import Maybes
68 69
import Outputable
import FastString
70
import Control.Monad
71
import Class(classTyCon)
72 73
import qualified GHC.LanguageExtensions as LangExt

74 75 76
import Data.Function
import Data.List
import qualified Data.Set as Set
77

Austin Seipp's avatar
Austin Seipp committed
78 79 80
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
81
\subsection{Main wrappers}
Austin Seipp's avatar
Austin Seipp committed
82 83 84
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
85

86
tcPolyExpr, tcPolyExprNC
87 88 89
  :: LHsExpr Name        -- Expression to type check
  -> TcSigmaType         -- Expected type (could be a polytype)
  -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
90

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

96 97 98 99 100 101
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
tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId)
tc_poly_expr expr res_ty
102
  = addExprErrCtxt expr $
103
    do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
104

105 106
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
107
       ; (wrap, expr')
108
           <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
109 110 111 112 113
              setSrcSpan loc $
                -- NB: setSrcSpan *after* skolemising, so we get better
                -- skolem locations
              tcExpr expr res_ty
       ; return $ L loc (mkHsWrap wrap expr') }
114 115

---------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
116
tcMonoExpr, tcMonoExprNC
117
    :: LHsExpr Name      -- Expression to type check
118
    -> ExpRhoType        -- Expected type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
119
                         -- Definitely no foralls at the top
120 121 122 123 124 125 126
    -> TcM (LHsExpr TcId)

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

tcMonoExprNC (L loc expr) res_ty
127
  = setSrcSpan loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
128 129
    do  { expr' <- tcExpr expr res_ty
        ; return (L loc expr') }
130

131
---------------
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
132 133 134 135 136 137 138 139 140 141
tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM ( LHsExpr TcId
                                                    , TcSigmaType )
-- Infer a *sigma*-type.
tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)

tcInferSigmaNC (L loc expr)
  = setSrcSpan loc $
    do { (expr', sigma) <- tcInfer (tcExpr expr)
       ; return (L loc expr', sigma) }

142
tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
143
-- Infer a *rho*-type. The return type is always (shallowly) instantiated.
144 145
tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
146 147 148 149
tcInferRhoNC expr
  = do { (expr', sigma) <- tcInferSigmaNC expr
       ; (wrap, rho) <- topInstantiate (exprCtOrigin (unLoc expr)) sigma
       ; return (mkLHsWrap wrap expr', rho) }
150

sof's avatar
sof committed
151

Austin Seipp's avatar
Austin Seipp committed
152 153 154
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
155
        tcExpr: the main expression typechecker
Austin Seipp's avatar
Austin Seipp committed
156 157
*                                                                      *
************************************************************************
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
158 159

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

162
tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
163 164
tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
tcExpr (HsUnboundVar v)   res_ty = tcUnboundId v res_ty
165

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
166 167 168
tcExpr (HsApp e1 e2) res_ty
  = do { (wrap, fun, args) <- tcApp Nothing e1 [e2] res_ty
       ; return (mkHsWrap wrap $ unLoc $ foldl mkHsApp fun args) }
169

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
170 171
tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit
                                 ; tcWrapResult e (HsLit lit) lit_ty res_ty }
172

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

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

180
tcExpr (HsTickPragma src info srcInfo expr) res_ty
181
  = do { expr' <- tcMonoExpr expr res_ty
182
       ; return (HsTickPragma src info srcInfo expr') }
183

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
188
tcExpr (HsOverLit lit) res_ty
189
  = do  { lit' <- newOverloadedLit lit res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
190
        ; return (HsOverLit lit') }
191 192

tcExpr (NegApp expr neg_expr) res_ty
193 194 195 196
  = 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
197
        ; return (NegApp expr' neg_expr') }
198

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
199 200
tcExpr e@(HsIPVar x) res_ty
  = do {   {- Implicit parameters must have a *tau-type* not a
201 202 203
              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
204
         ip_ty <- newOpenFlexiTyVarTy
205
       ; let ip_name = mkStrLitTy (hsIPNameFS x)
206
       ; ipClass <- tcLookupClass ipClassName
207
       ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
208
       ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))
209
                      ip_ty res_ty }
210
  where
Gabor Greif's avatar
Gabor Greif committed
211
  -- Coerces a dictionary for `IP "x" t` into `t`.
212
  fromDict ipClass x ty = HsWrap $ mkWpCastR $
213
                          unwrapIP $ mkClassPred ipClass [x,ty]
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
214
  origin = IPOccOrigin x
215

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

232
tcExpr (HsLam match) res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
233
  = do  { (co_fn, _, match') <- tcMatchLambda herald match_ctxt match res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
234
        ; return (mkHsWrap co_fn (HsLam match')) }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
235 236
  where
    match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
237
    herald = sep [ text "The lambda expression" <+>
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
238 239 240
                   quotes (pprSetDepth (PartWay 1) $
                           pprMatches (LambdaExpr :: HsMatchContext Name) match),
                        -- The pprSetDepth makes the abstraction print briefly
241
                   text "has"]
242

243
tcExpr e@(HsLamCase _ matches) res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
244 245 246 247 248
  = do { (co_fn, ~[arg_ty], matches')
           <- tcMatchLambda msg match_ctxt matches res_ty
           -- The laziness annotation is because we don't want to fail here
           -- if there are multiple arguments
       ; return (mkHsWrap co_fn $ HsLamCase arg_ty matches') }
249 250
  where msg = sep [ text "The function" <+> quotes (ppr e)
                  , text "requires"]
251 252
        match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
253
tcExpr e@(ExprWithTySig expr sig_ty) res_ty
254 255 256
  = do { sig_info <- checkNoErrs $  -- Avoid error cascade
                     tcUserTypeSig sig_ty Nothing
       ; (expr', poly_ty) <- tcExprSig expr sig_info
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
257 258
       ; let expr'' = ExprWithTySigOut expr' sig_ty
       ; tcWrapResult e expr'' poly_ty res_ty }
259

260
tcExpr (HsType ty) _
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
261 262
  = failWithTc (sep [ text "Type argument used outside of a function argument:"
                    , ppr ty ])
263

Adam Gundry's avatar
Adam Gundry committed
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283

{-
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
284 285 286
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
287
                Infix operators and sections
Austin Seipp's avatar
Austin Seipp committed
288 289
*                                                                      *
************************************************************************
290

291 292 293
Note [Left sections]
~~~~~~~~~~~~~~~~~~~~
Left sections, like (4 *), are equivalent to
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
294
        \ x -> (*) 4 x,
295
or, if PostfixOperators is enabled, just
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
296
        (*) 4
297 298 299 300 301 302 303
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
304
People write
305
   runST $ blah
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
306
so much, where
307 308
   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
309
rule just for saturated appliations of ($).
310
  * Infer the type of the first argument
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
311
  * Decompose it; should be of form (arg2_ty -> res_ty),
312 313 314 315 316 317 318 319
       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:
320 321 322 323 324
   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
325 326
    case x of _ -> (# p,q #)

327 328
So it seems more uniform to treat 'seq' as it it was a language
construct.
329

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
330
See also Note [seqId magic] in MkId
Austin Seipp's avatar
Austin Seipp committed
331
-}
332

333
tcExpr expr@(OpApp arg1 op fix arg2) res_ty
334
  | (L loc (HsVar (L lv op_name))) <- op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
335
  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
336
  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
337 338 339 340 341
       ; 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
342
       ; op_id <- tcLookupId op_name
343 344
       ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty])
                                 (HsVar (L lv op_id)))
345 346
       ; return $ OpApp arg1' op' fix arg2' }

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

352
       ; let doc   = text "The first argument of ($) takes"
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
353 354
             orig1 = exprCtOrigin (unLoc arg1)
       ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
355
           matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty
356 357 358

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

361
       ; arg2'  <- tcArg op arg2 arg2_sigma 2
362

363
       -- Make sure that the argument type has kind '*'
364
       --   ($) :: forall (v:Levity) (a:*) (b:TYPE v). (a->b) -> a -> b
365
       -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
366
       --    (which gives a seg fault)
367
       --
368 369
       -- The *result* type can have any kind (Trac #8739),
       -- so we don't need to check anything for that
370 371 372 373 374
       ; _ <- 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 *.
375

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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
379
       ; op_id  <- tcLookupId op_name
380
       ; res_ty <- readExpType res_ty
381
       ; let op' = L loc (HsWrap (mkWpTyApps [ getLevity "tcExpr ($)" res_ty
382
                                             , arg2_sigma
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
383
                                             , res_ty])
384
                                 (HsVar (L lv op_id)))
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
385 386 387 388 389
             -- 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

390 391 392
             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty
                     <.> wrap_arg1
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
393

394
       ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }
395

396 397 398 399 400 401 402 403 404
  | (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
       }

405 406
  | otherwise
  = do { traceTc "Non Application rule" (ppr op)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
407 408 409 410
       ; (wrap, op', [arg1', arg2'])
           <- tcApp (Just $ mk_op_msg op)
                     op [arg1, arg2] res_ty
       ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
411

412
-- Right sections, equivalent to \ x -> x `op` expr, or
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
413 414
--      \ x -> op x expr

415
tcExpr expr@(SectionR op arg2) res_ty
416
  = do { (op', op_ty) <- tcInferFun op
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
417
       ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <-
418
           matchActualFunTys (mk_op_msg op) SectionOrigin (Just op) 2 op_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
419 420
       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
                                 (mkFunTy arg1_ty op_res_ty) res_ty
421
       ; arg2' <- tcArg op arg2 arg2_ty 2
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
422 423
       ; return ( mkHsWrap wrap_res $
                  SectionR (mkLHsWrap wrap_fun op') arg2' ) }
424

425
tcExpr expr@(SectionL arg1 op) res_ty
426
  = do { (op', op_ty) <- tcInferFun op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
427
       ; dflags <- getDynFlags      -- Note [Left sections]
428 429
       ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
                         | otherwise                            = 2
430

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
431
       ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
432 433
           <- matchActualFunTys (mk_op_msg op) SectionOrigin (Just op)
                                n_reqd_args op_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
434 435
       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
                                 (mkFunTys arg_tys op_res_ty) res_ty
436
       ; arg1' <- tcArg op arg1 arg1_ty 1
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
437 438
       ; return ( mkHsWrap wrap_res $
                  SectionL arg1' (mkLHsWrap wrap_fn op') ) }
439

440
tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
441
  | all tupArgPresent tup_args
442 443
  = do { let arity  = length tup_args
             tup_tc = tupleTyCon boxity arity
444
       ; res_ty <- expTypeToType res_ty
445
       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
446 447 448 449 450 451
                           -- Unboxed tuples have levity vars, which we
                           -- don't care about here
                           -- See Note [Unboxed tuple levity vars] in TyCon
       ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
                                       Boxed   -> arg_tys
       ; tup_args1 <- tcTupArgs tup_args arg_tys'
452
       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
453

454 455
  | otherwise
  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
456
    do { let arity = length tup_args
457

458 459 460
       ; arg_tys <- case boxity of
           { Boxed   -> newFlexiTyVarTys arity liftedTypeKind
           ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
461
       ; let actual_res_ty
462 463
                 = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
                            (mkTupleTy boxity arg_tys)
464

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
465 466 467
       ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")
                             (Just expr)
                             actual_res_ty res_ty
468 469 470

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
474
tcExpr (ExplicitList _ witness exprs) res_ty
475
  = case witness of
476 477
      Nothing   -> do  { res_ty <- expTypeToType res_ty
                       ; (coi, elt_ty) <- matchExpectedListTy res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
478
                       ; exprs' <- mapM (tc_elt elt_ty) exprs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
479 480
                       ; return $
                         mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
481

482 483 484 485 486 487 488 489 490
      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
491
     where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
492

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
493
tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
494 495
  = do  { res_ty <- expTypeToType res_ty
        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
496
        ; exprs' <- mapM (tc_elt elt_ty) exprs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
497 498
        ; return $
          mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' }
499 500
  where
    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
501

Austin Seipp's avatar
Austin Seipp committed
502 503 504
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
505
                Let, case, if, do
Austin Seipp's avatar
Austin Seipp committed
506 507 508
*                                                                      *
************************************************************************
-}
509

510
tcExpr (HsLet (L l binds) expr) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
511 512
  = do  { (binds', expr') <- tcLocalBinds binds $
                             tcMonoExpr expr res_ty
513
        ; return (HsLet (L l binds') expr') }
514

515
tcExpr (HsCase scrut matches) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
516 517 518 519 520 521 522 523 524 525 526 527
  = 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)
528
        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
529
        ; return (HsCase scrut' matches') }
530
 where
ross's avatar
ross committed
531
    match_ctxt = MC { mc_what = CaseAlt,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
532
                      mc_body = tcBody }
533

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
534
tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
535
  = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
536 537
            -- this forces the branches to be fully instantiated
            -- (See #10619)
538
       ; res_ty <- mkCheckExpType <$> expTypeToType res_ty
539 540 541 542
       ; 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
543
tcExpr (HsIf (Just fun) pred b1 b2) res_ty
544 545 546 547 548 549 550 551
  = 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') }
552

553
tcExpr (HsMultiIf _ alts) res_ty
554 555 556 557 558 559 560
  = do { res_ty <- if isSingleton alts
                   then return res_ty
                   else mkCheckExpType <$> expTypeToType res_ty
        -- Just like Note [Case branches must never infer a non-tau type]
        -- in TcMatches
       ; 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
561
       ; return (HsMultiIf res_ty alts') }
562 563
  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }

564
tcExpr (HsDo do_or_lc stmts _) res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
565 566
  = do { expr' <- tcDoStmts do_or_lc stmts res_ty
       ; return expr' }
567

568
tcExpr (HsProc pat cmd) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
569 570
  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
571

Facundo Domínguez's avatar
Facundo Domínguez committed
572 573
tcExpr (HsStatic expr) res_ty
  = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
574
        ; res_ty          <- expTypeToType res_ty
Facundo Domínguez's avatar
Facundo Domínguez committed
575 576
        ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
        ; (expr', lie)    <- captureConstraints $
577
            addErrCtxt (hang (text "In the body of a static form:")
Facundo Domínguez's avatar
Facundo Domínguez committed
578 579 580 581 582 583 584 585
                             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
586
        ; _ <- emitWantedEvVar StaticOrigin $
Facundo Domínguez's avatar
Facundo Domínguez committed
587 588 589 590 591 592 593 594
                  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
595 596 597
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
598
                Record construction and update
Austin Seipp's avatar
Austin Seipp committed
599 600 601
*                                                                      *
************************************************************************
-}
602

603 604
tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
                       , rcon_flds = rbinds }) res_ty
Matthew Pickering's avatar
Matthew Pickering committed
605
  = do  { con_like <- tcLookupConLike con_name
606

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
607
        -- Check for missing fields
Matthew Pickering's avatar
Matthew Pickering committed
608
        ; checkMissingFields con_like rbinds
609

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
610 611 612 613 614
        ; (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
615
        ; let arity = conLikeArity con_like
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
616
              (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
Matthew Pickering's avatar
Matthew Pickering committed
617 618 619
        ; 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
620 621
                  res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")
                                          (Just expr) actual_res_ty res_ty
Matthew Pickering's avatar
Matthew Pickering committed
622
                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
623 624 625 626 627 628
                ; 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' } } }
629

Austin Seipp's avatar
Austin Seipp committed
630
{-
631 632 633 634
Note [Type of a record update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The main complication with RecordUpd is that we need to explicitly
handle the *non-updated* fields.  Consider:
635

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
636 637 638 639 640 641
        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}
642

643 644
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
645
not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
646 647
NB that it's not good enough to look at just one constructor; we must
look at them all; cf Trac #3219
648

649
After all, upd should be equivalent to:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
650 651 652 653
        upd t x = case t of
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b
                        MkT3 d   -> error ...
654 655 656

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

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

Gabor Greif's avatar
Gabor Greif committed
663
Note [Implicit type sharing]
664 665
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We also take into account any "implicit" non-update fields.  For example
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
666
        data T a b where { MkT { f::a } :: T a a; ... }
667 668 669
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
670
        upd t x = t { f=x }
671
We infer the type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
672 673 674
        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 }
675
We can't give it the more general type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
676
        upd :: T a b -> c -> T c b
677 678 679 680 681 682 683 684

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

686 687 688 689 690 691
The criterion we use is this:

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

692
NB: this is not (quite) the same as being a "naughty" record selector
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
693
(See Note [Naughty record selectors]) in TcTyClsDecls), at least
694 695 696 697 698 699 700
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.)

701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716
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
717
        MkT x y -> MkT e y |> co2
718
      where co1 :: T (t1,t2) ~ :TP t1 t2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
719
            co2 :: :TP t3 t2 ~ T (t3,t2)
720 721 722 723 724 725 726 727 728
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
729 730
        *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
731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762

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

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

770
        -- STEP -1  See Note [Disambiguating record fields]
Adam Gundry's avatar
Adam Gundry committed
771
        -- After this we know that rbinds is unambiguous
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
772
        ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
Adam Gundry's avatar
Adam Gundry committed
773 774 775
        ; 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
776 777
        -- STEP 0
        -- Check that the field names are really field names
Matthew Pickering's avatar
Matthew Pickering committed
778 779
        -- 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
780
        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
Adam Gundry's avatar
Adam Gundry committed
781
                         | fld <- rbinds,
Matthew Pickering's avatar
Matthew Pickering committed
782
                           -- Excludes class ops
Adam Gundry's avatar
Adam Gundry committed
783
                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),
Matthew Pickering's avatar
Matthew Pickering committed
784
                           not (isRecordSelector sel_id),
Adam Gundry's avatar
Adam Gundry committed
785
                           let fld_name = idName sel_id ]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
786
        ; unless (null bad_guys) (sequence bad_guys >> failM)
Matthew Pickering's avatar
Matthew Pickering committed
787 788 789 790 791 792
        -- 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
793 794 795 796 797

        -- 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
798 799 800 801 802 803 804 805 806 807 808 809 810

              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
811 812
                -- NB: for a data type family, the tycon is the instance tycon

813
              relevant_cons = conLikesWithFields con_likes upd_fld_occs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
814 815 816 817 818 819 820
                -- 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
821 822 823 824
        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)

        -- Take apart a representative constructor
        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
825 826 827 828 829 830 831
              (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
832 833 834 835 836

        -- 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
837 838 839 840

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