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