ghc/compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcExpr]{TcExpr}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcExpr (
  10         tcExpr
  11 #ifdef DPH
  12         , tcExprs
  13 #endif
  14     ) where
  15
  16 import TcMonad          -- typechecking monad machinery
  17 import TcMonadFns       ( newPolyTyVarTy, newOpenTyVarTy,
  18                           newDict, newMethod, newOverloadedLit,
  19                           applyTcSubstAndCollectTyVars,
  20                           mkIdsWithPolyTyVarTys
  21                         )
  22 import AbsSyn           -- the stuff being typechecked
  23
  24
  25 import AbsPrel          ( intPrimTy, charPrimTy, doublePrimTy,
  26                           floatPrimTy, addrPrimTy, addrTy,
  27                           boolTy, charTy, stringTy, mkFunTy, mkListTy,
  28                           mkTupleTy, mkPrimIoTy
  29 #ifdef DPH
  30                          ,mkProcessorTy, mkPodTy,toPodId,
  31                           processorClass,pidClass
  32 #endif {- Data Parallel Haskell -}
  33                         )
  34 import AbsUniType
  35 import E
  36 import CE               ( lookupCE )
  37
  38 import Errors
  39 import GenSpecEtc       ( checkSigTyVars )
  40 import Id               ( mkInstId, getIdUniType, Id )
  41 import Inst
  42 import LIE              ( nullLIE, unitLIE, plusLIE, unMkLIE, mkLIE, LIE )
  43 import ListSetOps       ( unionLists )
  44 import Maybes           ( Maybe(..) )
  45 import TVE              ( nullTVE, TVE(..) )
  46 import Spec             ( specId, specTy )
  47 import TcBinds          ( tcLocalBindsAndThen )
  48 import TcMatches        ( tcMatchesCase, tcMatch )
  49 import TcPolyType       ( tcPolyType )
  50 import TcQuals          ( tcQuals )
  51 import TcSimplify       ( tcSimplifyAndCheck, tcSimplifyRank2 )
  52 #ifdef DPH
  53 import TcParQuals
  54 #endif {- Data Parallel Haskell -}
  55 import Unify            ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
  56 import UniqFM           ( emptyUFM ) -- profiling, pragmas only
  57 import Unique           -- *Key stuff
  58 import Util
  59
  60 tcExpr :: E -> RenamedExpr -> TcM (TypecheckedExpr, LIE, UniType)
  61 \end{code}
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection{The TAUT rules for variables}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 tcExpr e (Var name)
  71   = specId (lookupE_Value e name) `thenNF_Tc` \ stuff@(expr, lie, ty) ->
  72
  73         -- Check that there's no lurking rank-2 polymorphism
  74         -- isTauTy is over-paranoid, because we don't expect
  75         -- any submerged polymorphism other than rank-2 polymorphism
  76
  77     getSrcLocTc                   `thenNF_Tc` \ loc ->
  78     checkTc (not (isTauTy ty)) (lurkingRank2Err name ty loc) `thenTc_`
  79
  80     returnTc stuff
  81 \end{code}
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection{Literals}
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 Overloaded literals.
  90
  91 \begin{code}
  92 tcExpr e (Lit lit@(IntLit i))
  93   = getSrcLocTc                 `thenNF_Tc` \ loc ->
  94     newPolyTyVarTy              `thenNF_Tc` \ ty ->
  95     let
  96         from_int     = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
  97         from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
  98     in
  99     newOverloadedLit (LiteralOrigin lit loc)
 100                      (OverloadedIntegral i from_int from_integer)
 101                      ty
 102                                 `thenNF_Tc` \ over_lit ->
 103
 104     returnTc (Var (mkInstId over_lit), unitLIE over_lit, ty)
 105
 106 tcExpr e (Lit lit@(FracLit f))
 107   = getSrcLocTc                 `thenNF_Tc` \ loc ->
 108     newPolyTyVarTy              `thenNF_Tc` \ ty ->
 109     let
 110         from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational")
 111     in
 112     newOverloadedLit (LiteralOrigin lit loc)
 113                      (OverloadedFractional f from_rational)
 114                      ty
 115                                 `thenNF_Tc` \ over_lit ->
 116
 117     returnTc (Var (mkInstId over_lit), unitLIE over_lit, ty)
 118
 119 tcExpr e (Lit lit@(LitLitLitIn s))
 120   = getSrcLocTc                 `thenNF_Tc` \ loc ->
 121     let
 122         -- Get the callable class.  Rather turgid and a HACK (ToDo).
 123         ce               = getE_CE e
 124         cCallableClass   = lookupCE ce (PreludeClass cCallableClassKey   bottom)
 125         bottom           = panic "tcExpr:LitLitLit"
 126     in
 127     newPolyTyVarTy              `thenNF_Tc` \ ty ->
 128
 129     newDict (LitLitOrigin loc (_UNPK_ s)) cCallableClass ty `thenNF_Tc` \ dict ->
 130
 131     returnTc (Lit (LitLitLit s ty), mkLIE [dict], ty)
 132 \end{code}
 133
 134 Primitive literals:
 135
 136 \begin{code}
 137 tcExpr e (Lit (CharPrimLit c))
 138   = returnTc (Lit (CharPrimLit c), nullLIE, charPrimTy)
 139
 140 tcExpr e (Lit (StringPrimLit s))
 141   = returnTc (Lit (StringPrimLit s), nullLIE, addrPrimTy)
 142
 143 tcExpr e (Lit (IntPrimLit i))
 144   = returnTc (Lit (IntPrimLit i), nullLIE, intPrimTy)
 145
 146 tcExpr e (Lit (FloatPrimLit f))
 147   = returnTc (Lit (FloatPrimLit f), nullLIE, floatPrimTy)
 148
 149 tcExpr e (Lit (DoublePrimLit d))
 150   = returnTc (Lit (DoublePrimLit d), nullLIE, doublePrimTy)
 151 \end{code}
 152
 153 Unoverloaded literals:
 154
 155 \begin{code}
 156 tcExpr e (Lit (CharLit c))
 157   = returnTc (Lit (CharLit c), nullLIE, charTy)
 158
 159 tcExpr e (Lit (StringLit str))
 160   = returnTc (Lit (StringLit str), nullLIE, stringTy)
 161 \end{code}
 162
 163 %************************************************************************
 164 %*                                                                      *
 165 \subsection{Other expression forms}
 166 %*                                                                      *
 167 %************************************************************************
 168
 169 \begin{code}
 170 tcExpr e (Lam match)
 171   = tcMatch e match     `thenTc` \ (match',lie,ty) ->
 172     returnTc (Lam match',lie,ty)
 173
 174 tcExpr e (App e1 e2) = accum e1 [e2]
 175         where
 176           accum (App e1 e2) args = accum e1 (e2:args)
 177           accum fun         args = tcApp (foldl App) e fun args
 178
 179 -- equivalent to (op e1) e2:
 180 tcExpr e (OpApp e1 op e2)
 181   = tcApp (\fun [arg1,arg2] -> OpApp arg1 fun arg2) e op [e1,e2]
 182 \end{code}
 183
 184 Note that the operators in sections are expected to be binary, and
 185 a type error will occur if they aren't.
 186
 187 \begin{code}
 188 -- equivalent to
 189 --      \ x -> e op x,
 190 -- or
 191 --      \ x -> op e x,
 192 -- or just
 193 --      op e
 194
 195 tcExpr e (SectionL expr op)
 196   = tcApp (\ fun [arg] -> SectionL arg fun) e op [expr]
 197
 198 -- equivalent to \ x -> x op expr, or
 199 --      \ x -> op x expr
 200
 201 tcExpr e (SectionR op expr)
 202   = tcExpr e op                 `thenTc`    \ (op',  lie1, op_ty) ->
 203     tcExpr e expr               `thenTc`    \ (expr',lie2, expr_ty) ->
 204     newOpenTyVarTy              `thenNF_Tc` \ ty1 ->
 205     newOpenTyVarTy              `thenNF_Tc` \ ty2 ->
 206     let
 207         result_ty = mkFunTy ty1 ty2
 208     in
 209     unifyTauTy op_ty (mkFunTy ty1 (mkFunTy expr_ty ty2))
 210                      (SectionRAppCtxt op expr) `thenTc_`
 211
 212     returnTc (SectionR op' expr', plusLIE lie1 lie2, result_ty)
 213 \end{code}
 214
 215 The interesting thing about @ccall@ is that it is just a template
 216 which we instantiate by filling in details about the types of its
 217 argument and result (ie minimal typechecking is performed).  So, the
 218 basic story is that we allocate a load of type variables (to hold the
 219 arg/result types); unify them with the args/result; and store them for
 220 later use.
 221
 222 \begin{code}
 223 tcExpr e (CCall lbl args may_gc is_asm ignored_fake_result_ty)
 224   = getSrcLocTc                                         `thenNF_Tc` \ src_loc ->
 225     let
 226         -- Get the callable and returnable classes.  Rather turgid (ToDo).
 227         ce               = getE_CE e
 228         cCallableClass   = lookupCE ce (PreludeClass cCallableClassKey   bottom)
 229         cReturnableClass = lookupCE ce (PreludeClass cReturnableClassKey bottom)
 230         bottom           = panic "tcExpr:CCall"
 231
 232         new_arg_dict (arg, arg_ty) = newDict (CCallOrigin src_loc (_UNPK_ lbl) (Just arg))
 233                                              cCallableClass arg_ty
 234
 235         result_origin = CCallOrigin src_loc (_UNPK_ lbl) Nothing {- Not an arg -}
 236     in
 237
 238         -- Arguments
 239     tcExprs e args                      `thenTc` \ (args', args_lie, arg_tys) ->
 240
 241         -- The argument types can be unboxed or boxed; the result
 242         -- type must, however, be boxed since it's an argument to the PrimIO
 243         -- type constructor.
 244     newPolyTyVarTy                                      `thenNF_Tc` \ result_ty ->
 245
 246         -- Construct the extra insts, which encode the
 247         -- constraints on the argument and result types.
 248     mapNF_Tc new_arg_dict (args `zip` arg_tys)                  `thenNF_Tc` \ arg_dicts ->
 249     newDict result_origin cReturnableClass result_ty            `thenNF_Tc` \ res_dict ->
 250
 251     returnTc (CCall lbl args' may_gc is_asm result_ty,
 252               args_lie `plusLIE` mkLIE (res_dict : arg_dicts),
 253               mkPrimIoTy result_ty)
 254 \end{code}
 255
 256 \begin{code}
 257 tcExpr e (SCC label expr)
 258   = tcExpr e expr               `thenTc` \ (expr', lie, expr_ty) ->
 259          -- No unification. Give SCC the type of expr
 260     returnTc (SCC label expr', lie, expr_ty)
 261
 262 tcExpr e (Let binds expr)
 263   = tcLocalBindsAndThen e
 264         Let                             -- The combiner
 265         binds                           -- Bindings to check
 266         (\ e -> tcExpr e expr)          -- Typechecker for the expression
 267
 268 tcExpr e (Case expr matches)
 269   = tcExpr e expr               `thenTc`    \ (expr',lie1,expr_ty) ->
 270     tcMatchesCase e matches     `thenTc`    \ (matches',lie2,match_ty) ->
 271     newOpenTyVarTy              `thenNF_Tc` \ result_ty ->
 272
 273     unifyTauTy (mkFunTy expr_ty result_ty) match_ty
 274                 (CaseCtxt expr matches) `thenTc_`
 275
 276     returnTc (Case expr' matches', plusLIE lie1 lie2, result_ty)
 277
 278 tcExpr e (If pred b1 b2)
 279   = tcExpr e pred               `thenTc`    \ (pred',lie1,predTy) ->
 280
 281     unifyTauTy predTy boolTy (PredCtxt pred) `thenTc_`
 282
 283     tcExpr e b1                 `thenTc`    \ (b1',lie2,result_ty) ->
 284     tcExpr e b2                 `thenTc`    \ (b2',lie3,b2Ty) ->
 285
 286     unifyTauTy result_ty b2Ty (BranchCtxt b1 b2) `thenTc_`
 287
 288     returnTc (If pred' b1' b2', plusLIE lie1 (plusLIE lie2 lie3), result_ty)
 289
 290 tcExpr e (ListComp expr quals)
 291   = mkIdsWithPolyTyVarTys binders       `thenNF_Tc` \ lve ->
 292          -- Binders of a list comprehension must be boxed.
 293     let
 294         new_e = growE_LVE e lve
 295     in
 296     tcQuals new_e quals                 `thenTc` \ (quals',lie1) ->
 297     tcExpr  new_e expr                  `thenTc` \ (expr', lie2, ty) ->
 298     returnTc (ListComp expr' quals', plusLIE lie1 lie2, mkListTy ty)
 299   where
 300     binders = collectQualBinders quals
 301 \end{code}
 302
 303 \begin{code}
 304 tcExpr e (ExplicitList [])
 305   = newPolyTyVarTy                      `thenNF_Tc` \ tyvar_ty ->
 306     returnTc (ExplicitListOut tyvar_ty [], nullLIE, mkListTy tyvar_ty)
 307
 308
 309 tcExpr e (ExplicitList exprs)           -- Non-empty list
 310   = tcExprs e exprs                     `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
 311     unifyTauTyList tys (ListCtxt exprs) `thenTc_`
 312     returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
 313
 314 tcExpr e (ExplicitTuple exprs)
 315   = tcExprs e exprs                     `thenTc` \ (exprs', lie, tys) ->
 316     returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
 317
 318 tcExpr e (ArithSeqIn seq@(From expr))
 319   = getSrcLocTc                 `thenNF_Tc` \ loc ->
 320     tcExpr e expr               `thenTc`    \ (expr', lie, ty) ->
 321     let
 322         enum_from_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFrom")
 323     in
 324     newMethod (ArithSeqOrigin seq loc)
 325               enum_from_id [ty] `thenNF_Tc` \ enum_from ->
 326
 327     returnTc (ArithSeqOut (Var (mkInstId enum_from)) (From expr'),
 328               plusLIE (unitLIE enum_from) lie,
 329                mkListTy ty)
 330
 331 tcExpr e (ArithSeqIn seq@(FromThen expr1 expr2))
 332   = getSrcLocTc                 `thenNF_Tc` \ loc ->
 333     tcExpr e expr1              `thenTc`    \ (expr1',lie1,ty1) ->
 334     tcExpr e expr2              `thenTc`    \ (expr2',lie2,ty2) ->
 335
 336     unifyTauTyList [ty1, ty2] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
 337     let
 338         enum_from_then_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromThen")
 339     in
 340     newMethod (ArithSeqOrigin seq loc)
 341               enum_from_then_id [ty1]   `thenNF_Tc` \ enum_from_then ->
 342
 343     returnTc (ArithSeqOut (Var (mkInstId enum_from_then))
 344                            (FromThen expr1' expr2'),
 345              (unitLIE enum_from_then) `plusLIE` lie1 `plusLIE` lie2,
 346               mkListTy ty1)
 347
 348 tcExpr e (ArithSeqIn seq@(FromTo expr1 expr2))
 349   = getSrcLocTc                 `thenNF_Tc` \ loc ->
 350     tcExpr e expr1              `thenTc`    \ (expr1',lie1,ty1) ->
 351     tcExpr e expr2              `thenTc`    \ (expr2',lie2,ty2) ->
 352
 353     unifyTauTyList [ty1,ty2] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
 354     let
 355         enum_from_to_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromTo")
 356     in
 357     newMethod (ArithSeqOrigin seq loc)
 358               enum_from_to_id [ty1]      `thenNF_Tc` \ enum_from_to ->
 359     returnTc (ArithSeqOut (Var (mkInstId enum_from_to))
 360                            (FromTo expr1' expr2'),
 361               (unitLIE enum_from_to) `plusLIE` lie1 `plusLIE` lie2,
 362                mkListTy ty1)
 363
 364 tcExpr e (ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
 365   = getSrcLocTc                 `thenNF_Tc` \ loc ->
 366     tcExpr e expr1              `thenTc`    \ (expr1',lie1,ty1) ->
 367     tcExpr e expr2              `thenTc`    \ (expr2',lie2,ty2) ->
 368     tcExpr e expr3              `thenTc`    \ (expr3',lie3,ty3) ->
 369
 370     unifyTauTyList [ty1,ty2,ty3] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
 371     let
 372         enum_from_then_to_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromThenTo")
 373     in
 374     newMethod (ArithSeqOrigin seq loc)
 375               enum_from_then_to_id [ty1] `thenNF_Tc` \ enum_from_then_to ->
 376
 377     returnTc (ArithSeqOut (Var (mkInstId enum_from_then_to))
 378                            (FromThenTo expr1' expr2' expr3'),
 379               (unitLIE enum_from_then_to) `plusLIE` lie1 `plusLIE` lie2 `plusLIE` lie3,
 380                mkListTy ty1)
 381 \end{code}
 382
 383 %************************************************************************
 384 %*                                                                      *
 385 \subsection{Expressions type signatures}
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 \begin{code}
 390 tcExpr e (ExprWithTySig expr poly_ty)
 391  = tcExpr e expr                                        `thenTc` \ (texpr, lie, tau_ty) ->
 392    babyTcMtoTcM (tcPolyType (getE_CE e) (getE_TCE e) nullTVE poly_ty)   `thenTc` \ sigma_sig ->
 393
 394         -- Check the tau-type part
 395    specTy SignatureOrigin sigma_sig     `thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau) ->
 396    unifyTauTy tau_ty sig_tau (ExprSigCtxt expr sig_tau) `thenTc_`
 397
 398         -- Check the type variables of the signature
 399    applyTcSubstAndCollectTyVars (tvOfE e) `thenNF_Tc` \ env_tyvars ->
 400    checkSigTyVars env_tyvars sig_tyvars sig_tau tau_ty (ExprSigCtxt expr sig_tau)
 401                                         `thenTc`    \ sig_tyvars' ->
 402
 403         -- Check overloading constraints
 404    tcSimplifyAndCheck
 405         False {- Not top level -}
 406         env_tyvars sig_tyvars'
 407         sig_dicts (unMkLIE lie)
 408         (ExprSigCtxt expr sigma_sig)            `thenTc_`
 409
 410         -- If everything is ok, return the stuff unchanged, except for
 411         -- the effect of any substutions etc.  We simply discard the
 412         -- result of the tcSimplifyAndCheck, except for any default
 413         -- resolution it may have done, which is recorded in the
 414         -- substitution.
 415    returnTc (texpr, lie, tau_ty)
 416 \end{code}
 417
 418 %************************************************************************
 419 %*                                                                      *
 420 \subsection{Data Parallel Expressions (DPH only)}
 421 %*                                                                      *
 422 %************************************************************************
 423
 424 Constraints enforced by the Static semantics for ParallelZF
 425 $exp_1$ = << $exp_2$ | quals >>
 426
 427 \begin{enumerate}
 428 \item The type of the expression $exp_1$ is <<$exp_2$>>
 429 \item The type of $exp_2$ must be in the class {\tt Processor}
 430 \end{enumerate}
 431
 432 \begin{code}
 433 #ifdef DPH
 434 tcExpr e (ParallelZF expr quals)
 435  = let binders = collectParQualBinders quals        in
 436    mkIdsWithPolyTyVarTys binders        `thenNF_Tc` (\ lve              ->
 437    let e'      = growE_LVE e lve                    in
 438    tcParQuals e' quals                  `thenTc`    (\ (quals',lie1)    ->
 439    tcExpr e' expr                       `thenTc`    (\ (expr', lie2,ty) ->
 440    getSrcLocTc                          `thenNF_Tc` (\ src_loc          ->
 441    if (isProcessorTy ty) then
 442       returnTc (ParallelZF expr' quals',
 443                  plusLIE lie1 lie2 ,
 444                  mkPodTy ty)
 445    else
 446       failTc (podCompLhsError ty src_loc)
 447    ))))
 448 #endif {- Data Parallel Haskell -}
 449 \end{code}
 450
 451 Constraints enforced by the Static semantics for Explicit Pods
 452 exp = << $exp_1$ ... $exp_n$>>  (where $n >= 0$)
 453
 454 \begin{enumerate}
 455 \item The type of the all the expressions in the Pod must be the same.
 456 \item The type of an expression in a POD must be in class {\tt Processor}
 457 \end{enumerate}
 458
 459 \begin{code}
 460 #ifdef DPH
 461 tcExpr e (ExplicitPodIn exprs)
 462  = panic "Ignoring explicit PODs for the time being"
 463 {-
 464  = tcExprs e exprs                      `thenTc`    (\ (exprs',lie,tys) ->
 465    newPolyTyVarTy                       `thenNF_Tc` (\ elt_ty ->
 466    newDict processorClass elt_ty        `thenNF_Tc` (\ procDict ->
 467    let
 468       procLie = mkLIEFromDicts procDict
 469    in
 470    unifyTauTyList (elt_ty:tys) (PodCtxt exprs) `thenTc_`
 471
 472    returnTc ((App
 473                 (DictApp
 474                    (TyApp (Var toPodId) [elt_ty])
 475                    procDict)
 476                 (ExplicitListOut elt_ty exprs')),
 477              plusLIE procLie lie,
 478              mkPodTy elt_ty)
 479    ))) -}
 480 #endif {- Data Parallel Haskell -}
 481 \end{code}
 482
 483 \begin{code}
 484 #ifdef DPH
 485 tcExpr e (ExplicitProcessor exprs expr)
 486  = tcPidExprs e exprs           `thenTc`        (\ (exprs',lie1,tys) ->
 487    tcExpr  e expr               `thenTc`        (\ (expr',lie2,ty)   ->
 488    returnTc (ExplicitProcessor exprs' expr',
 489              plusLIE lie1 lie2,
 490              mkProcessorTy tys ty)
 491    ))
 492 #endif {- Data Parallel Haskell -}
 493 \end{code}
 494
 495 %************************************************************************
 496 %*                                                                      *
 497 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 ToDo: Possibly find a version of a listTc TcM which would pass the
 502 appropriate functions for the LIE.
 503
 504 \begin{code}
 505 tcExprs :: E -> [RenamedExpr] -> TcM ([TypecheckedExpr],LIE,[TauType])
 506
 507 tcExprs e [] = returnTc ([], nullLIE, [])
 508 tcExprs e (expr:exprs)
 509  = tcExpr e expr                        `thenTc` \ (expr',  lie1, ty) ->
 510    tcExprs e exprs                      `thenTc` \ (exprs', lie2, tys) ->
 511    returnTc (expr':exprs', plusLIE lie1 lie2, ty:tys)
 512 \end{code}
 513
 514
 515 %************************************************************************
 516 %*                                                                      *
 517 \subsection{@tcApp@ typchecks an application}
 518 %*                                                                      *
 519 %************************************************************************
 520
 521 \begin{code}
 522 tcApp   :: (TypecheckedExpr -> [TypecheckedExpr] -> TypecheckedExpr)    -- Result builder
 523         -> E
 524         -> RenamedExpr
 525         -> [RenamedExpr]
 526         -> TcM (TypecheckedExpr, LIE, UniType)
 527
 528 tcApp build_result_expression e orig_fun arg_exprs
 529   = tcExpr' e orig_fun (length arg_exprs)
 530                         `thenTc` \ (fun', lie_fun, fun_ty) ->
 531     unify_fun 1 fun' lie_fun arg_exprs fun_ty
 532  where
 533     -- Used only in the error message
 534     maybe_fun_id = case orig_fun of
 535                         Var name -> Just (lookupE_Value e name)
 536                         other    -> Nothing
 537
 538     unify_args  :: Int                  -- Current argument number
 539                 -> TypecheckedExpr      -- Current rebuilt expression
 540                 -> LIE                  -- Corresponding LIE
 541                 -> [RenamedExpr]        -- Remaining args
 542                 -> [TauType]            -- Remaining arg types
 543                 -> TauType              -- result type
 544                 -> TcM (TypecheckedExpr, LIE, UniType)
 545
 546     unify_args arg_no fun lie (arg:args) (arg_ty:arg_tys) fun_res_ty
 547       = tcExpr e arg            `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 548
 549         -- These applyTcSubstToTy's are just to improve the error message...
 550         applyTcSubstToTy actual_arg_ty  `thenNF_Tc` \ actual_arg_ty' ->
 551         applyTcSubstToTy arg_ty         `thenNF_Tc` \ arg_ty' ->
 552         let
 553             err_ctxt = FunAppCtxt orig_fun maybe_fun_id arg arg_ty' actual_arg_ty' arg_no
 554         in
 555         matchArgTy e arg_ty' arg' lie_arg actual_arg_ty' err_ctxt
 556                                         `thenTc` \ (arg'', lie_arg') ->
 557
 558         unify_args (arg_no+1) (App fun arg'') (lie `plusLIE` lie_arg') args arg_tys fun_res_ty
 559
 560     unify_args arg_no fun lie [] arg_tys fun_res_ty
 561       = -- We've run out of actual arguments.  Check that none of
 562         -- arg_tys has a for-all at the top. For example, "build" on
 563         -- its own is no good; it must be applied to something.
 564         let
 565            result_ty = glueTyArgs arg_tys fun_res_ty
 566         in
 567         getSrcLocTc     `thenNF_Tc` \ loc ->
 568         checkTc (not (isTauTy result_ty))
 569                 (underAppliedTyErr result_ty loc) `thenTc_`
 570         returnTc (fun, lie, result_ty)
 571
 572     -- When we run out of arg_tys we go back to unify_fun in the hope
 573     -- that our unification work may have shown up some more arguments
 574     unify_args arg_no fun lie args [] fun_res_ty
 575       = unify_fun arg_no fun lie args fun_res_ty
 576
 577
 578     unify_fun   :: Int                  -- Current argument number
 579                 -> TypecheckedExpr      -- Current rebuilt expression
 580                 -> LIE                  -- Corresponding LIE
 581                 -> [RenamedExpr]        -- Remaining args
 582                 -> TauType              -- Remaining function type
 583                 -> TcM (TypecheckedExpr, LIE, UniType)
 584
 585     unify_fun arg_no fun lie args fun_ty
 586       =         -- Find out as much as possible about the function
 587         applyTcSubstToTy fun_ty         `thenNF_Tc` \ fun_ty' ->
 588
 589                 -- Now see whether it has any arguments
 590         case (splitTyArgs fun_ty') of
 591
 592           ([], _) ->            -- Function has no arguments left
 593
 594                 newOpenTyVarTy          `thenNF_Tc` \ result_ty ->
 595                 tcExprs e args          `thenTc`    \ (args', lie_args, arg_tys) ->
 596
 597                 -- At this point, a unification error must mean the function is
 598                 -- being applied to too many arguments.
 599                 unifyTauTy fun_ty' (glueTyArgs arg_tys result_ty)
 600                                 (TooManyArgsCtxt orig_fun) `thenTc_`
 601
 602                 returnTc (build_result_expression fun args',
 603                           lie `plusLIE` lie_args,
 604                           result_ty)
 605
 606           (fun_arg_tys, fun_res_ty) ->  -- Function has non-empty list of argument types
 607
 608                 unify_args arg_no fun lie args fun_arg_tys fun_res_ty
 609 \end{code}
 610
 611 \begin{code}
 612 matchArgTy :: E
 613          -> UniType             -- Expected argument type
 614          -> TypecheckedExpr     -- Type checked argument
 615          -> LIE                 -- Actual argument LIE
 616          -> UniType             -- Actual argument type
 617          -> UnifyErrContext
 618          -> TcM (TypecheckedExpr,       -- The incoming type checked arg,
 619                                         --  possibly wrapped in a big lambda
 620                  LIE)                   -- Possibly reduced somewhat
 621
 622 matchArgTy e expected_arg_ty arg_expr actual_arg_lie actual_arg_ty err_ctxt
 623   | isForAllTy expected_arg_ty
 624   = -- Ha!  The argument type of the function is a for-all type,
 625     -- An example of rank-2 polymorphism.
 626
 627     -- This applyTcSubstToTy is just to improve the error message..
 628
 629     applyTcSubstToTy actual_arg_ty              `thenNF_Tc` \ actual_arg_ty' ->
 630
 631     -- Instantiate the argument type
 632     -- ToDo: give this a real origin
 633     specTy UnknownOrigin expected_arg_ty        `thenNF_Tc` \ (arg_tyvars, arg_lie, arg_tau) ->
 634
 635     if not (null arg_lie) then
 636             -- Paranoia check
 637             panic "Non-null overloading in tcApp"
 638     else
 639             -- Assert: arg_lie = []
 640
 641     unifyTauTy arg_tau actual_arg_ty' err_ctxt  `thenTc_`
 642
 643         -- Check that the arg_tyvars havn't been constrained
 644         -- The interesting bit here is that we must include the free variables
 645         -- of the expected arg ty.  Here's an example:
 646         --       runST (newVar True)
 647         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 648         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 649         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 650         -- So now s' isn't unconstrained because it's linked to a.
 651         -- Conclusion: include the free vars of the expected arg type in the
 652         -- list of "free vars" for the signature check.
 653     applyTcSubstAndCollectTyVars
 654         (tvOfE e        `unionLists`
 655          extractTyVarsFromTy expected_arg_ty)    `thenNF_Tc` \ free_tyvars ->
 656     checkSigTyVars free_tyvars arg_tyvars arg_tau actual_arg_ty rank2_err_ctxt
 657                                             `thenTc` \ arg_tyvars' ->
 658
 659         -- Check that there's no overloading involved
 660         -- Even if there isn't, there may be some Insts which mention the arg_tyvars,
 661         -- but which, on simplification, don't actually need a dictionary involving
 662         -- the tyvar.  So we have to do a proper simplification right here.
 663     let insts = unMkLIE actual_arg_lie
 664     in
 665     applyTcSubstToInsts insts            `thenNF_Tc` \ insts' ->
 666
 667     tcSimplifyRank2 arg_tyvars' insts' rank2_err_ctxt   `thenTc` \ (free_insts, inst_binds) ->
 668
 669         -- This Let binds any Insts which came out of the simplification.
 670         -- It's a bit out of place here, but using AbsBind involves inventing
 671         -- a couple of new names which seems worse.
 672     returnTc (TyLam arg_tyvars' (Let (mk_binds inst_binds) arg_expr), mkLIE free_insts)
 673
 674   | otherwise
 675   =     -- The ordinary, non-rank-2 polymorphic case
 676     unifyTauTy expected_arg_ty actual_arg_ty err_ctxt   `thenTc_`
 677     returnTc (arg_expr, actual_arg_lie)
 678
 679   where
 680     rank2_err_ctxt = Rank2ArgCtxt arg_expr expected_arg_ty
 681
 682     mk_binds []                      = EmptyBinds
 683     mk_binds ((inst,rhs):inst_binds) = (SingleBind (NonRecBind (VarMonoBind (mkInstId inst) rhs)))
 684                                             `ThenBinds`
 685                                             mk_binds inst_binds
 686 \end{code}
 687
 688 This version only does not check for 2nd order if it is applied.
 689
 690 \begin{code}
 691 tcExpr' :: E -> RenamedExpr -> Int -> TcM (TypecheckedExpr,LIE,UniType)
 692
 693 tcExpr' e v@(Var name) n
 694       | n > 0 = specId (lookupE_Value e name)   `thenNF_Tc` \ (expr, lie, ty) ->
 695     returnTc (expr, lie, ty)
 696 tcExpr' e exp n = tcExpr e exp
 697 \end{code}