[project @ 2000-07-14 08:17:36 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcExpr.lhs

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index e556db1..6497221 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -32,7 +32,7 @@ import TcEnv          ( tcInstId,
                          tcLookupValue, tcLookupClassByKey,
                          tcLookupValueByKey,
                          tcExtendGlobalTyVars, tcLookupValueMaybe,
-                         tcLookupTyCon, tcLookupDataCon
+                         tcLookupTyConByKey, tcLookupDataCon
                        )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcStmts )
 import TcMonoType      ( tcHsSigType, checkSigTyVars, sigCtxt )
@@ -42,9 +42,8 @@ import TcImprove      ( tcImprove )
 import TcType          ( TcType, TcTauType,
                          tcInstTyVars,
                          tcInstTcType, tcSplitRhoTy,
-                         newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
+                         newTyVarTy, newTyVarTys, zonkTcType )
 
-import Class           ( Class )
 import FieldLabel      ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
 import Id              ( idType, recordSelectorFieldLabel, isRecordSelector,
                          Id, mkVanillaId
@@ -60,7 +59,7 @@ import Type           ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
                          splitRhoTy,
                          isTauTy, tyVarsOfType, tyVarsOfTypes, 
                          isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
-                         boxedTypeKind, mkArrowKind,
+                         boxedTypeKind, openTypeKind, mkArrowKind,
                          tidyOpenType
                        )
 import TyCon           ( TyCon, tyConTyVars )
@@ -72,13 +71,11 @@ import TysPrim              ( intPrimTy, charPrimTy, doublePrimTy,
                          floatPrimTy, addrPrimTy
                        )
 import TysWiredIn      ( boolTy, charTy, stringTy )
-import PrelInfo                ( ioTyCon_NAME )
-import TcUnify         ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
-                         unifyUnboxedTupleTy )
+import TcUnify         ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
 import Unique          ( cCallableClassKey, cReturnableClassKey, 
                          enumFromClassOpKey, enumFromThenClassOpKey,
                          enumFromToClassOpKey, enumFromThenToClassOpKey,
-                         thenMClassOpKey, failMClassOpKey, returnMClassOpKey
+                         thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey
                        )
 import Outputable
 import Maybes          ( maybeToBool, mapMaybe )
@@ -359,7 +356,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
   =    -- Get the callable and returnable classes.
     tcLookupClassByKey cCallableClassKey       `thenNF_Tc` \ cCallableClass ->
     tcLookupClassByKey cReturnableClassKey     `thenNF_Tc` \ cReturnableClass ->
-    tcLookupTyCon ioTyCon_NAME                 `thenNF_Tc` \ ioTyCon ->
+    tcLookupTyConByKey ioTyConKey              `thenNF_Tc` \ ioTyCon ->
     let
        new_arg_dict (arg, arg_ty)
          = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
@@ -374,7 +371,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
        tv_idxs | n_args == 0 = []
                | otherwise   = [1..n_args]
     in
-    mapNF_Tc (\ _ -> newTyVarTy_OpenKind) tv_idxs      `thenNF_Tc` \ arg_tys ->
+    newTyVarTys (length tv_idxs) openTypeKind          `thenNF_Tc` \ arg_tys ->
     tcMonoExprs args arg_tys                           `thenTc`    \ (args', args_lie) ->
 
        -- The argument types can be unboxed or boxed; the result
@@ -462,15 +459,12 @@ tcMonoExpr in_expr@(ExplicitList exprs) res_ty    -- Non-empty list
       = tcAddErrCtxt (listCtxt expr) $
        tcMonoExpr expr elt_ty
 
-tcMonoExpr (ExplicitTuple exprs boxed) res_ty
-  = (if boxed
-       then unifyTupleTy (length exprs) res_ty
-       else unifyUnboxedTupleTy (length exprs) res_ty
-                                               ) `thenTc` \ arg_tys ->
+tcMonoExpr (ExplicitTuple exprs boxity) res_ty
+  = unifyTupleTy boxity (length exprs) res_ty  `thenTc` \ arg_tys ->
     mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
                (exprs `zip` arg_tys) -- we know they're of equal length.
                                                        `thenTc` \ (exprs', lies) ->
-    returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
+    returnTc (ExplicitTuple exprs' boxity, plusLIEs lies)
 
 tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
   = tcAddErrCtxt (recordConCtxt expr)          $
@@ -753,7 +747,7 @@ tcMonoExpr (HsWith expr binds) res_ty
        revBinds b = b
 
 tcIPBinds ((name, expr) : binds)
-  = newTyVarTy_OpenKind                `thenTc` \ ty ->
+  = newTyVarTy openTypeKind    `thenTc` \ ty ->
     tcGetSrcLoc                        `thenTc` \ loc ->
     let id = ipToId name ty loc in
     tcMonoExpr expr ty         `thenTc` \ (expr', lie) ->
@@ -788,7 +782,7 @@ tcExpr_id id_expr
  = case id_expr of
        HsVar name -> tcId name                 `thenNF_Tc` \ stuff -> 
                      returnTc stuff
-       other      -> newTyVarTy_OpenKind       `thenNF_Tc` \ id_ty ->
+       other      -> newTyVarTy openTypeKind   `thenNF_Tc` \ id_ty ->
                      tcMonoExpr id_expr id_ty  `thenTc`    \ (id_expr', lie_id) ->
                      returnTc (id_expr', lie_id, id_ty) 
 \end{code}
@@ -897,11 +891,11 @@ tcId name
     tcLookupValueMaybe name    `thenNF_Tc` \ maybe_local ->
 
     case maybe_local of
-      Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id))
+      Just tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (unannotTy (idType tc_id))
 
       Nothing ->    tcLookupValue name         `thenNF_Tc` \ id ->
                    tcInstId id                 `thenNF_Tc` \ (tyvars, theta, tau) ->
-                   instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau
+                   instantiate_it2 (OccurrenceOf id) id tyvars theta tau
 
   where
        -- The instantiate_it loop runs round instantiating the Id.
@@ -917,7 +911,7 @@ tcId name
 
     instantiate_it2 orig fun tyvars theta tau
       = if null theta then     -- Is it overloaded?
-               returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau)
+               returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
        else
                -- Yes, it's overloaded
        instOverloadedFun orig fun arg_tys theta tau    `thenNF_Tc` \ (fun', lie1) ->