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

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

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

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

20
#include "HsVersions.h"
21

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

sof's avatar
sof committed
157

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

293 294 295 296 297
In the `OverloadedLabels` case, when we see an overloaded label like
`#foo`, we generate a fresh variable `alpha` for the type and emit an
`IsLabel "foo" alpha` constraint.  Because the `IsLabel` class has a
single method, it is represented by a newtype, so we can coerce
`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).
Adam Gundry's avatar
Adam Gundry committed
298 299 300 301

-}


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

309 310 311
Note [Left sections]
~~~~~~~~~~~~~~~~~~~~
Left sections, like (4 *), are equivalent to
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
312
        \ x -> (*) 4 x,
313
or, if PostfixOperators is enabled, just
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
314
        (*) 4
315 316 317 318 319 320 321
With PostfixOperators we don't actually require the function to take
two arguments at all.  For example, (x `not`) means (not x); you get
postfix operators!  Not Haskell 98, but it's less work and kind of
useful.

Note [Typing rule for ($)]
~~~~~~~~~~~~~~~~~~~~~~~~~~
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
322
People write
323
   runST $ blah
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
324
so much, where
325 326
   runST :: (forall s. ST s a) -> a
that I have finally given in and written a special type-checking
327
rule just for saturated applications of ($).
328
  * Infer the type of the first argument
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
329
  * Decompose it; should be of form (arg2_ty -> res_ty),
330 331 332 333 334 335 336 337
       where arg2_ty might be a polytype
  * Use arg2_ty to typecheck arg2

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

553
tcExpr (HsCase scrut matches) res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
554 555 556 557 558 559 560 561 562 563 564 565
  = do  {  -- We used to typecheck the case alternatives first.
           -- The case patterns tend to give good type info to use
           -- when typechecking the scrutinee.  For example
           --   case (map f) of
           --     (x:xs) -> ...
           -- will report that map is applied to too few arguments
           --
           -- But now, in the GADT world, we need to typecheck the scrutinee
           -- first, to get type info that may be refined in the case alternatives
          (scrut', scrut_ty) <- tcInferRho scrut

        ; traceTc "HsCase" (ppr scrut_ty)
566
        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
567
        ; return (HsCase scrut' matches') }
568
 where
ross's avatar
ross committed
569
    match_ctxt = MC { mc_what = CaseAlt,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
570
                      mc_body = tcBody }
571

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

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

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

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

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

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

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

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

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

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

Facundo Domínguez's avatar
Facundo Domínguez committed
634 635 636 637 638
        -- Require the type of the argument to be Typeable.
        -- The evidence is not used, but asking the constraint ensures that
        -- the current implementation is as restrictive as future versions
        -- of the StaticPointers extension.
        ; typeableClass <- tcLookupClass typeableClassName
639
        ; _ <- emitWantedEvVar StaticOrigin $
Facundo Domínguez's avatar
Facundo Domínguez committed
640 641
                  mkTyConApp (classTyCon typeableClass)
                             [liftedTypeKind, expr_ty]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
642

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

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

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

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

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

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
696 697 698 699 700 701
        data T a b c = MkT1 { fa :: a, fb :: (b,c) }
                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
                     | MkT3 { fd :: a }

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

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

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

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

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

Gabor Greif's avatar
Gabor Greif committed
723
Note [Implicit type sharing]
724 725
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We also take into account any "implicit" non-update fields.  For example
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
726
        data T a b where { MkT { f::a } :: T a a; ... }
727 728 729
So the "real" type of MkT is: forall ab. (a~b) => a -> T a b

Then consider
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
730
        upd t x = t { f=x }
731
We infer the type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
732 733 734
        upd :: T a b -> a -> T a b
        upd (t::T a b) (x::a)
           = case t of { MkT (co:a~b) (_:a) -> MkT co x }
735
We can't give it the more general type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
736
        upd :: T a b -> c -> T c b
737 738 739 740 741 742 743 744

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

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

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

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

761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776
In principle one could go further, and allow
  g :: T a -> T a
  g t = t { f2 = \x -> x }
because the expression is polymorphic...but that seems a bridge too far.

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

Suppose r :: T (t1,t2), e :: t3
Then  r { x=e } :: T (t3,t1)
  --->
      case r |> co1 of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
777
        MkT x y -> MkT e y |> co2
778
      where co1 :: T (t1,t2) ~ :TP t1 t2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
779
            co2 :: :TP t3 t2 ~ T (t3,t2)
780 781 782 783 784 785 786 787 788
The wrapping with co2 is done by the constructor wrapper for MkT

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

  * cons are the data constructors to be updated