[project @ 2002-07-09 08:19:14 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index e200bcf..cf12315 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -18,7 +18,7 @@ module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred,
 
 #include "HsVersions.h"
 
-import HsSyn           ( HsType(..), HsTyVarBndr(..),
+import HsSyn           ( HsType(..), HsTyVarBndr(..), HsTyOp(..),
                           Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames )
 import RnHsSyn         ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars )
 import TcHsSyn         ( TcId )
@@ -34,9 +34,9 @@ import TcMType                ( newKindVar, zonkKindEnv, tcInstType,
 import TcUnify         ( unifyKind, unifyOpenTypeKind )
 import TcType          ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
                          TcTyVar, TcKind, TcThetaType, TcTauType,
-                         mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
+                         mkTyVarTy, mkTyVarTys, mkFunTy, 
                          hoistForAllTys, zipFunTys, 
-                         mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, 
+                         mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
                          liftedTypeKind, unliftedTypeKind, mkArrowKind,
                          mkArrowKinds, tcSplitFunTy_maybe
                        )
@@ -45,7 +45,7 @@ import Inst           ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
 import Id              ( mkLocalId, idName, idType )
 import Var             ( TyVar, mkTyVar, tyVarKind )
 import ErrUtils                ( Message )
-import TyCon           ( TyCon, isSynTyCon, tyConKind )
+import TyCon           ( TyCon, tyConKind )
 import Class           ( classTyCon )
 import Name            ( Name )
 import NameSet
@@ -287,17 +287,25 @@ kcHsType (HsFunTy ty1 ty2)
     kcTypeType ty2     `thenTc_`
     returnTc liftedTypeKind
 
-kcHsType (HsNumTy _)           -- The unit type for generics
-  = returnTc liftedTypeKind
+kcHsType (HsOpTy ty1 HsArrow ty2)
+  = kcTypeType ty1     `thenTc_`
+    kcTypeType ty2     `thenTc_`
+    returnTc liftedTypeKind
 
-kcHsType ty@(HsOpTy ty1 op ty2)
+kcHsType ty@(HsOpTy ty1 (HsTyOp op) ty2)
   = kcTyVar op                         `thenTc` \ op_kind ->
     kcHsType ty1                       `thenTc` \ ty1_kind ->
     kcHsType ty2                       `thenTc` \ ty2_kind ->
     tcAddErrCtxt (appKindCtxt (ppr ty))        $
     kcAppKind op_kind  ty1_kind                `thenTc` \ op_kind' ->
     kcAppKind op_kind' ty2_kind
+
+kcHsType (HsParTy ty)          -- Skip parentheses markers
+  = kcHsType ty
    
+kcHsType (HsNumTy _)           -- The unit type for generics
+  = returnTc liftedTypeKind
+
 kcHsType (HsPredTy pred)
   = kcHsPred pred              `thenTc_`
     returnTc liftedTypeKind
@@ -426,15 +434,23 @@ tc_type (HsFunTy ty1 ty2)
     tc_type ty2                        `thenTc` \ tau_ty2 ->
     returnTc (mkFunTy tau_ty1 tau_ty2)
 
-tc_type (HsNumTy n)
-  = ASSERT(n== 1)
-    returnTc (mkTyConApp genUnitTyCon [])
+tc_type (HsOpTy ty1 HsArrow ty2)
+  = tc_type ty1 `thenTc` \ tau_ty1 ->
+    tc_type ty2 `thenTc` \ tau_ty2 ->
+    returnTc (mkFunTy tau_ty1 tau_ty2)
 
-tc_type (HsOpTy ty1 op ty2)
+tc_type (HsOpTy ty1 (HsTyOp op) ty2)
   = tc_type ty1 `thenTc` \ tau_ty1 ->
     tc_type ty2 `thenTc` \ tau_ty2 ->
     tc_fun_type op [tau_ty1,tau_ty2]
 
+tc_type (HsParTy ty)           -- Remove the parentheses markers
+  = tc_type ty
+
+tc_type (HsNumTy n)
+  = ASSERT(n== 1)
+    returnTc (mkTyConApp genUnitTyCon [])
+
 tc_type (HsAppTy ty1 ty2) = tc_app ty1 [ty2]
 
 tc_type (HsPredTy pred)
@@ -480,9 +496,7 @@ tc_fun_type name arg_tys
     case thing of
        ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
 
-       AGlobal (ATyCon tc)
-               | isSynTyCon tc ->  returnTc (mkSynTy tc arg_tys)
-               | otherwise     ->  returnTc (mkTyConApp tc arg_tys)
+       AGlobal (ATyCon tc) -> returnTc (mkGenTyConApp tc arg_tys)
 
        other -> failWithTc (wrongThingErr "type constructor" thing name)
 \end{code}