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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
12 13
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
                tcInferRho, tcInferRhoNC,
14
                tcSyntaxOp, tcCheckId,
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
54
import TcEvidence
55
import VarSet
56
import VarEnv
57
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
65 66
import ListSetOps
import Maybes
67
import ErrUtils
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
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
87
         :: LHsExpr Name        -- Expression to type check
Gabor Greif's avatar
Gabor Greif committed
88
         -> TcSigmaType         -- Expected type (could be a polytype)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
89
         -> 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.

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

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

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

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

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

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

tcInferRhoNC (L loc expr)
  = setSrcSpan loc $
137
    do { (expr', rho) <- tcInfer (tcExpr expr)
138 139
       ; return (L loc expr', rho) }

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

Austin Seipp's avatar
Austin Seipp committed
162 163 164
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
165
        tcExpr: the main expression typechecker
Austin Seipp's avatar
Austin Seipp committed
166 167 168
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
169

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

174 175
tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
tcExpr (HsUnboundVar v)   res_ty = tcUnboundId v res_ty
176

177
tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
178

179
tcExpr (HsLit lit)   res_ty = do { let lit_ty = hsLitType lit
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
180
                                 ; tcWrapResult (HsLit lit) lit_ty res_ty }
181 182

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

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

Alan Zimmerman's avatar
Alan Zimmerman committed
189
tcExpr (HsTickPragma src info expr) res_ty
190
  = do { expr' <- tcMonoExpr expr res_ty
Alan Zimmerman's avatar
Alan Zimmerman committed
191
       ; return (HsTickPragma src info expr') }
192

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
197 198 199
tcExpr (HsOverLit lit) res_ty
  = do  { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
        ; return (HsOverLit lit') }
200 201

tcExpr (NegApp expr neg_expr) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
202 203 204 205
  = do  { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
                                  (mkFunTy res_ty res_ty)
        ; expr' <- tcMonoExpr expr res_ty
        ; return (NegApp expr' neg_expr') }
206

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

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

239
tcExpr (HsLam match) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
240 241
  = do  { (co_fn, match') <- tcMatchLambda match res_ty
        ; return (mkHsWrap co_fn (HsLam match')) }
242

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

251 252 253 254 255 256 257 258
tcExpr (ExprWithTySig expr sig_ty) res_ty
  = do { sig_info <- checkNoErrs $  -- Avoid error cascade
                     tcUserTypeSig sig_ty Nothing
       ; (expr', poly_ty) <- tcExprSig expr sig_info
       ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin poly_ty
       ; let expr'' = mkHsWrap inst_wrap $
                      ExprWithTySigOut expr' sig_ty
       ; tcWrapResult expr'' rho res_ty }
259

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

Adam Gundry's avatar
Adam Gundry committed
268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287

{-
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
288 289 290
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
291
                Infix operators and sections
Austin Seipp's avatar
Austin Seipp committed
292 293
*                                                                      *
************************************************************************
294

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

331 332
So it seems more uniform to treat 'seq' as it it was a language
construct.
333

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
334
See Note [seqId magic] in MkId, and
Austin Seipp's avatar
Austin Seipp committed
335
-}
336

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

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

354 355
       ; let doc = ptext (sLit "The first argument of ($) takes")
       ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
356 357 358 359 360

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

361 362
       ; arg2'  <- tcArg op (arg2, arg2_ty, 2)
       ; co_b   <- unifyType (Just expr) op_res_ty res_ty    -- op_res ~ res
363

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

377
       ; op_id  <- tcLookupId op_name
378 379 380 381

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

389 390 391 392 393 394 395 396 397
  | (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
       }

398 399 400
  | otherwise
  = do { traceTc "Non Application rule" (ppr op)
       ; (op', op_ty) <- tcInferFun op
batterseapower's avatar
batterseapower committed
401
       ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTysWrap op 2 op_ty
402
       ; co_res <- unifyType (Just expr) op_res_ty res_ty
403
       ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
404 405
       ; return $ mkHsWrapCo co_res $
         OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
406

407
-- Right sections, equivalent to \ x -> x `op` expr, or
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
408 409
--      \ x -> op x expr

410
tcExpr expr@(SectionR op arg2) res_ty
411
  = do { (op', op_ty) <- tcInferFun op
batterseapower's avatar
batterseapower committed
412
       ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTysWrap op 2 op_ty
413
       ; co_res <- unifyType (Just expr) (mkFunTy arg1_ty op_res_ty) res_ty
414
       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
415
       ; return $ mkHsWrapCo co_res $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
416
         SectionR (mkLHsWrapCo co_fn op') arg2' }
417

418
tcExpr expr@(SectionL arg1 op) res_ty
419
  = do { (op', op_ty) <- tcInferFun op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
420
       ; dflags <- getDynFlags      -- Note [Left sections]
421 422
       ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
                         | otherwise                            = 2
423

batterseapower's avatar
batterseapower committed
424
       ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTysWrap op n_reqd_args op_ty
425
       ; co_res <- unifyType (Just expr) (mkFunTys arg_tys op_res_ty) res_ty
426
       ; arg1' <- tcArg op (arg1, arg1_ty, 1)
427 428
       ; return $ mkHsWrapCo co_res $
         SectionL arg1' (mkLHsWrapCo co_fn op') }
429

430
tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
431
  | all tupArgPresent tup_args
432 433
  = do { let arity  = length tup_args
             tup_tc = tupleTyCon boxity arity
434
       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
435 436 437 438 439 440
                           -- 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'
441
       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
442

443 444
  | otherwise
  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
445
    do { let arity = length tup_args
446

447 448 449
       ; arg_tys <- case boxity of
           { Boxed   -> newFlexiTyVarTys arity liftedTypeKind
           ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
450
       ; let actual_res_ty
451 452
                 = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
                            (mkTupleTy boxity arg_tys)
453

454
       ; coi <- unifyType (Just expr) actual_res_ty res_ty
455 456 457

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

459
       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
460

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
461
tcExpr (ExplicitList _ witness exprs) res_ty
462 463
  = case witness of
      Nothing   -> do  { (coi, elt_ty) <- matchExpectedListTy res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
464
                       ; exprs' <- mapM (tc_elt elt_ty) exprs
465 466 467 468 469 470 471
                       ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') }

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
474 475 476 477
tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
  = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
        ; exprs' <- mapM (tc_elt elt_ty) exprs
        ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
478 479
  where
    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
480

Austin Seipp's avatar
Austin Seipp committed
481 482 483
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
484
                Let, case, if, do
Austin Seipp's avatar
Austin Seipp committed
485 486 487
*                                                                      *
************************************************************************
-}
488

489
tcExpr (HsLet (L l binds) expr) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
490 491
  = do  { (binds', expr') <- tcLocalBinds binds $
                             tcMonoExpr expr res_ty
492
        ; return (HsLet (L l binds') expr') }
493

494
tcExpr (HsCase scrut matches) exp_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
495 496 497 498 499 500 501 502 503 504 505 506 507 508
  = do  {  -- We used to typecheck the case alternatives first.
           -- The case patterns tend to give good type info to use
           -- when typechecking the scrutinee.  For example
           --   case (map f) of
           --     (x:xs) -> ...
           -- will report that map is applied to too few arguments
           --
           -- But now, in the GADT world, we need to typecheck the scrutinee
           -- first, to get type info that may be refined in the case alternatives
          (scrut', scrut_ty) <- tcInferRho scrut

        ; traceTc "HsCase" (ppr scrut_ty)
        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
        ; return (HsCase scrut' matches') }
509
 where
ross's avatar
ross committed
510
    match_ctxt = MC { mc_what = CaseAlt,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
511
                      mc_body = tcBody }
512

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
513
tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
514 515 516 517 518
  = do { pred' <- tcMonoExpr pred boolTy
       ; b1' <- tcMonoExpr b1 res_ty
       ; b2' <- tcMonoExpr b2 res_ty
       ; return (HsIf Nothing pred' b1' b2') }

519
tcExpr (HsIf (Just fun) pred b1 b2) res_ty   -- Note [Rebindable syntax for if]
520 521 522
  = do { pred_ty <- newOpenFlexiTyVarTy
       ; b1_ty   <- newOpenFlexiTyVarTy
       ; b2_ty   <- newOpenFlexiTyVarTy
523 524
       ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
       ; fun'  <- tcSyntaxOp IfOrigin fun if_ty
525
       ; pred' <- tcMonoExpr pred pred_ty
526 527 528 529 530 531 532
       ; b1'   <- tcMonoExpr b1 b1_ty
       ; b2'   <- tcMonoExpr b2 b2_ty
       -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
       -- so maybe we should use the code for function applications
       -- (which would allow ifThenElse to be higher rank).
       -- But it's a little awkward, so I'm leaving it alone for now
       -- and it maintains uniformity with other rebindable syntax
533
       ; return (HsIf (Just fun') pred' b1' b2') }
534

535 536 537 538 539
tcExpr (HsMultiIf _ alts) res_ty
  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
       ; return $ HsMultiIf res_ty alts' }
  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }

540 541
tcExpr (HsDo do_or_lc stmts _) res_ty
  = tcDoStmts do_or_lc stmts res_ty
542

543
tcExpr (HsProc pat cmd) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
544 545
  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
546

Facundo Domínguez's avatar
Facundo Domínguez committed
547 548 549 550 551 552 553 554 555 556 557 558 559
tcExpr (HsStatic expr) res_ty
  = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
        ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
        ; (expr', lie)    <- captureConstraints $
            addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
                             2 (ppr expr)
                       ) $
            tcPolyExprNC expr expr_ty
        -- Require the type of the argument to be Typeable.
        -- The evidence is not used, but asking the constraint ensures that
        -- the current implementation is as restrictive as future versions
        -- of the StaticPointers extension.
        ; typeableClass <- tcLookupClass typeableClassName
560
        ; _ <- emitWantedEvVar StaticOrigin $
Facundo Domínguez's avatar
Facundo Domínguez committed
561 562 563 564 565 566 567 568
                  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
569
{-
570 571 572 573 574 575 576 577
Note [Rebindable syntax for if]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The rebindable syntax for 'if' uses the most flexible possible type
for conditionals:
  ifThenElse :: p -> b1 -> b2 -> res
to support expressions like this:

 ifThenElse :: Maybe a -> (a -> b) -> b -> b
Jan Stolarek's avatar
Jan Stolarek committed
578 579
 ifThenElse (Just a) f _ = f a
 ifThenElse Nothing  _ e = e
580 581 582 583 584 585 586

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


Austin Seipp's avatar
Austin Seipp committed
587 588
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
589
                Record construction and update
Austin Seipp's avatar
Austin Seipp committed
590 591 592
*                                                                      *
************************************************************************
-}
593

594 595
tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
                       , rcon_flds = rbinds }) res_ty
Matthew Pickering's avatar
Matthew Pickering committed
596
  = do  { con_like <- tcLookupConLike con_name
597

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
598
        -- Check for missing fields
Matthew Pickering's avatar
Matthew Pickering committed
599
        ; checkMissingFields con_like rbinds
600

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
601
        ; (con_expr, con_tau) <- tcInferId con_name
Matthew Pickering's avatar
Matthew Pickering committed
602
        ; let arity = conLikeArity con_like
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
603
              (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
Matthew Pickering's avatar
Matthew Pickering committed
604 605 606
        ; case conLikeWrapId_maybe con_like of
               Nothing -> nonBidirectionalErr (conLikeName con_like)
               Just con_id -> do {
607
                  co_res <- unifyType (Just expr) actual_res_ty res_ty
Matthew Pickering's avatar
Matthew Pickering committed
608 609
                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
                ; return $ mkHsWrapCo co_res $
610 611 612 613
                    RecordCon { rcon_con_name = L loc con_id
                              , rcon_con_expr = con_expr
                              , rcon_con_like = con_like
                              , rcon_flds = rbinds' } } }
614

Austin Seipp's avatar
Austin Seipp committed
615
{-
616 617 618 619
Note [Type of a record update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The main complication with RecordUpd is that we need to explicitly
handle the *non-updated* fields.  Consider:
620

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
621 622 623 624 625 626
        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}
627

628 629
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
630
not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
631 632
NB that it's not good enough to look at just one constructor; we must
look at them all; cf Trac #3219
633

634
After all, upd should be equivalent to:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
635 636 637 638
        upd t x = case t of
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b
                        MkT3 d   -> error ...
639 640 641

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

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

Gabor Greif's avatar
Gabor Greif committed
648
Note [Implicit type sharing]
649 650
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We also take into account any "implicit" non-update fields.  For example
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
651
        data T a b where { MkT { f::a } :: T a a; ... }
652 653 654
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
655
        upd t x = t { f=x }
656
We infer the type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
657 658 659
        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 }
660
We can't give it the more general type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
661
        upd :: T a b -> c -> T c b
662 663 664 665 666 667 668 669

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

671 672 673 674 675 676
The criterion we use is this:

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

677
NB: this is not (quite) the same as being a "naughty" record selector
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
678
(See Note [Naughty record selectors]) in TcTyClsDecls), at least
679 680 681 682 683 684 685
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.)

686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701
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
702
        MkT x y -> MkT e y |> co2
703
      where co1 :: T (t1,t2) ~ :TP t1 t2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
704
            co2 :: :TP t3 t2 ~ T (t3,t2)
705 706 707 708 709 710 711 712 713
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
714 715
        *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
716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747

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

750
tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
Matthew Pickering's avatar
Matthew Pickering committed
751
  = ASSERT( notNull rbnds )
752 753 754
    do  { -- STEP -2: typecheck the record_expr, the record to bd updated
          (record_expr', record_tau) <- tcInferFun record_expr

755
        -- STEP -1  See Note [Disambiguating record fields]
Adam Gundry's avatar
Adam Gundry committed
756
        -- After this we know that rbinds is unambiguous
757
        ; rbinds <- disambiguateRecordBinds record_expr record_tau rbnds res_ty
Adam Gundry's avatar
Adam Gundry committed
758 759 760
        ; 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
761 762
        -- STEP 0
        -- Check that the field names are really field names
Matthew Pickering's avatar
Matthew Pickering committed
763 764
        -- 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
765
        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
Adam Gundry's avatar
Adam Gundry committed
766
                         | fld <- rbinds,
Matthew Pickering's avatar
Matthew Pickering committed
767
                           -- Excludes class ops
Adam Gundry's avatar
Adam Gundry committed
768
                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),
Matthew Pickering's avatar
Matthew Pickering committed
769
                           not (isRecordSelector sel_id),
Adam Gundry's avatar
Adam Gundry committed
770
                           let fld_name = idName sel_id ]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
771
        ; unless (null bad_guys) (sequence bad_guys >> failM)
Matthew Pickering's avatar
Matthew Pickering committed
772 773 774 775 776 777
        -- 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
778 779 780 781 782

        -- 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
783 784 785 786 787 788 789 790 791 792 793 794 795

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

798
              relevant_cons = conLikesWithFields con_likes upd_fld_occs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
799 800 801 802 803 804 805
                -- 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
806 807 808 809
        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)

        -- Take apart a representative constructor
        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
810 811 812 813 814 815 816
              (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
817 818 819 820 821

        -- 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
822 823 824 825

        -- 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
826 827 828 829
        ; 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 &&
830
                                      not (tyCoVarsOfType ty `subVarSet` con1_tv_set)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
831 832 833 834 835 836 837 838 839
        ; 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
840
        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
841
              is_fixed_tv tv = tv `elemVarSet` fixed_tvs
842

843
              mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
844
              -- Deals with instantiation of kind variables
845
              --   c.f. TcMType.tcInstTyVars
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
846 847
              mk_inst_ty subst (tv, result_inst_ty)
                | is_fixed_tv tv   -- Same as result type
848
                = return (extendTCvSubst subst tv result_inst_ty, result_inst_ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
849
                | otherwise        -- Fresh type, of correct kind
850 851
                = do { (subst', new_tv) <- tcInstTyVarX subst tv
                     ; return (subst', mkTyVarTy new_tv) }
852

853 854
        ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs
        ; let result_inst_tys = mkTyVarTys con1_tvs'
855

856
        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTCvSubst
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
857
                                                      (con1_tvs `zip` result_inst_tys)
858

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
859 860 861
        ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty
              scrut_ty      = TcType.substTy scrut_subst  con1_res_ty
              con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
862