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

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

19
#include "HsVersions.h"
20

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

24 25
import HsSyn
import TcHsSyn
26
import TcRnMonad
27 28 29
import TcUnify
import BasicTypes
import Inst
30 31
import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds )
import TcSigs           ( tcUserTypeSig, tcInstSig )
32
import TcSimplify       ( simplifyInfer, InferMode(..) )
33
import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
34 35 36
import FamInstEnv       ( FamInstEnvs )
import RnEnv            ( addUsedGRE, addNameClashErrRn
                        , unknownSubordinateErr )
37 38 39 40
import TcEnv
import TcArrows
import TcMatches
import TcHsType
Matthew Pickering's avatar
Matthew Pickering committed
41
import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
42 43 44
import TcPat
import TcMType
import TcType
45
import DsMonad
46
import Id
Matthew Pickering's avatar
Matthew Pickering committed
47
import IdInfo
cactus's avatar
cactus committed
48
import ConLike
49
import DataCon
Matthew Pickering's avatar
Matthew Pickering committed
50
import PatSyn
51
import Name
52 53
import NameEnv
import NameSet
Adam Gundry's avatar
Adam Gundry committed
54
import RdrName
55 56
import TyCon
import Type
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
57
import TysPrim        ( tYPE )
58
import TcEvidence
59 60
import VarSet
import TysWiredIn
61
import TysPrim( intPrimTy )
62
import PrimOp( tagToEnumKey )
63
import PrelNames
Adam Gundry's avatar
Adam Gundry committed
64
import MkId ( proxyHashId )
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)
75
import UniqFM ( nonDetEltsUFM )
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 Name        -- Expression to type check
  -> TcSigmaType         -- Expected type (could be a polytype)
  -> TcM (LHsExpr TcId)  -- 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 105 106
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
107
  = addExprErrCtxt expr $
108
    do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
109

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

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

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

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

136
---------------
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
137 138 139 140 141 142 143 144 145 146
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) }

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

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

sof's avatar
sof committed
156

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

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

167
tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
168
tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
169
tcExpr (HsUnboundVar uv)  res_ty = tcUnboundId uv res_ty
170

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

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

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

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

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

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

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

tcExpr (NegApp expr neg_expr) res_ty
197 198 199 200
  = 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
201
        ; return (NegApp expr' neg_expr') }
202

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

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

236
tcExpr (HsLam match) res_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
237 238
  = 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
239 240
  where
    match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
241
    herald = sep [ text "The lambda expression" <+>
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
242
                   quotes (pprSetDepth (PartWay 1) $
243
                           pprMatches match),
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
244
                        -- The pprSetDepth makes the abstraction print briefly
245
                   text "has"]
246

Simon Peyton Jones's avatar
Simon Peyton Jones committed
247 248
tcExpr e@(HsLamCase matches) res_ty
  = do { (matches', wrap)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
249 250 251
           <- 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
252 253 254 255 256
       ; 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 }
257

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
258
tcExpr e@(ExprWithTySig expr sig_ty) res_ty
259 260 261
  = do { let loc = getLoc (hsSigWcType sig_ty)
       ; sig_info <- checkNoErrs $  -- Avoid error cascade
                     tcUserTypeSig loc sig_ty Nothing
262
       ; (expr', poly_ty) <- tcExprSig expr sig_info
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
263 264
       ; let expr'' = ExprWithTySigOut expr' sig_ty
       ; tcWrapResult e expr'' poly_ty res_ty }
265

Adam Gundry's avatar
Adam Gundry committed
266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284
{-
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
285 286 287
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
288
                Infix operators and sections
Austin Seipp's avatar
Austin Seipp committed
289 290
*                                                                      *
************************************************************************
291

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

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

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

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

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

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

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

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

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

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

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

391 392 393
             -- 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
394

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

541 542 543 544
       ; 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
545
tcExpr (HsIf (Just fun) pred b1 b2) res_ty
546 547 548 549 550 551 552 553
  = 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') }
554

555
tcExpr (HsMultiIf _ alts) res_ty
556 557
  = do { res_ty <- if isSingleton alts
                   then return res_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
558 559 560 561
                   else tauifyExpType res_ty
             -- Just like TcMatches
             -- Note [Case branches must never infer a non-tau type]

562 563
       ; 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
564
       ; return (HsMultiIf res_ty alts') }
565 566
  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }

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

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

575
-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
576
tcExpr (HsStatic fvs expr) res_ty
577 578
  = do  { res_ty          <- expTypeToType res_ty
        ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
Facundo Domínguez's avatar
Facundo Domínguez committed
579
        ; (expr', lie)    <- captureConstraints $
580
            addErrCtxt (hang (text "In the body of a static form:")
Facundo Domínguez's avatar
Facundo Domínguez committed
581 582 583
                             2 (ppr expr)
                       ) $
            tcPolyExprNC expr expr_ty
584
        -- Check that the free variables of the static form are closed.
585 586 587
        -- It's OK to use nonDetEltsUFM here as the only side effects of
        -- checkClosedInStaticForm are error messages.
        ; mapM_ checkClosedInStaticForm $ nonDetEltsUFM fvs
588

Facundo Domínguez's avatar
Facundo Domínguez committed
589 590 591 592 593
        -- 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
594
        ; _ <- emitWantedEvVar StaticOrigin $
Facundo Domínguez's avatar
Facundo Domínguez committed
595 596
                  mkTyConApp (classTyCon typeableClass)
                             [liftedTypeKind, expr_ty]
597 598
        -- Insert the constraints of the static form in a global list for later
        -- validation.
Facundo Domínguez's avatar
Facundo Domínguez committed
599 600
        ; stWC <- tcg_static_wc <$> getGblEnv
        ; updTcRef stWC (andWC lie)
601 602 603 604 605
        -- 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)
606
                                         (L loc (HsStatic fvs expr'))
Facundo Domínguez's avatar
Facundo Domínguez committed
607 608
        }

Austin Seipp's avatar
Austin Seipp committed
609 610 611
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
612
                Record construction and update
Austin Seipp's avatar
Austin Seipp committed
613 614 615
*                                                                      *
************************************************************************
-}
616

617 618
tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
                       , rcon_flds = rbinds }) res_ty
Matthew Pickering's avatar
Matthew Pickering committed
619
  = do  { con_like <- tcLookupConLike con_name
620

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
621
        -- Check for missing fields
Matthew Pickering's avatar
Matthew Pickering committed
622
        ; checkMissingFields con_like rbinds
623

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
624 625 626 627 628
        ; (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
629
        ; let arity = conLikeArity con_like
630
              Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
Matthew Pickering's avatar
Matthew Pickering committed
631 632 633
        ; 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
634 635
                  res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")
                                          (Just expr) actual_res_ty res_ty
Matthew Pickering's avatar
Matthew Pickering committed
636
                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
637 638 639 640 641 642
                ; 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' } } }
643

Austin Seipp's avatar
Austin Seipp committed
644
{-
645 646 647 648
Note [Type of a record update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The main complication with RecordUpd is that we need to explicitly
handle the *non-updated* fields.  Consider:
649

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
650 651 652 653 654 655
        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}
656

657 658
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
659
not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
660 661
NB that it's not good enough to look at just one constructor; we must
look at them all; cf Trac #3219
662

663
After all, upd should be equivalent to:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
664 665 666 667
        upd t x = case t of
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b
                        MkT3 d   -> error ...
668 669 670

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

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

Gabor Greif's avatar
Gabor Greif committed
677
Note [Implicit type sharing]
678 679
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We also take into account any "implicit" non-update fields.  For example
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
680
        data T a b where { MkT { f::a } :: T a a; ... }
681 682 683
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
684
        upd t x = t { f=x }
685
We infer the type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
686 687 688
        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 }
689
We can't give it the more general type
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
690
        upd :: T a b -> c -> T c b
691 692 693 694 695 696 697 698

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

700 701 702 703 704 705
The criterion we use is this:

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

706
NB: this is not (quite) the same as being a "naughty" record selector
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
707
(See Note [Naughty record selectors]) in TcTyClsDecls), at least
708 709 710 711 712 713 714
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.)

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