[project @ 2000-09-28 16:49:36 by simonpj]

Another wibble

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 51f8de5..e23f703 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, 
-                   tcHsConSigType, tcContext, tcClassContext,
+                   tcContext, tcClassContext,
 
                        -- Kind checking
                    kcHsTyVar, kcHsTyVars, mkTyClTyVars,
@@ -188,13 +188,14 @@ kcHsType (HsTupleTy (HsTupCon _ Boxed) tys)
   = mapTc kcBoxedType tys      `thenTc_` 
     returnTc boxedTypeKind
 
-kcHsType (HsTupleTy (HsTupCon _ Unboxed) tys)
-  = mapTc kcTypeType tys       `thenTc_` 
-    returnTc unboxedTypeKind
+kcHsType ty@(HsTupleTy (HsTupCon _ Unboxed) tys)
+  = failWithTc (unboxedTupleErr ty)
+       -- Unboxed tuples are illegal everywhere except
+       -- just after a function arrow (see kcFunResType)
 
 kcHsType (HsFunTy ty1 ty2)
   = kcTypeType ty1     `thenTc_`
-    kcTypeType ty2     `thenTc_`
+    kcFunResType ty2   `thenTc_`
     returnTc boxedTypeKind
 
 kcHsType (HsPredTy pred)
@@ -219,17 +220,27 @@ kcHsType (HsForAllTy (Just tv_names) context ty)
   = kcHsTyVars tv_names                        `thenNF_Tc` \ kind_env ->
     tcExtendKindEnv kind_env           $
     kcHsContext context                `thenTc_`
-    kcHsType ty                        `thenTc` \ kind ->
  
-               -- Context behaves like a function type
-               -- This matters.  Return-unboxed-tuple analysis can
-               -- give overloaded functions like
-               --      f :: forall a. Num a => (# a->a, a->a #)
-               -- And we want these to get through the type checker
-    returnTc (if null context then
-                kind
-             else
-                 boxedTypeKind)
+       -- Context behaves like a function type
+       -- This matters.  Return-unboxed-tuple analysis can
+       -- give overloaded functions like
+       --      f :: forall a. Num a => (# a->a, a->a #)
+       -- And we want these to get through the type checker
+    if null context then
+       kcHsType ty
+    else
+       kcFunResType ty         `thenTc_`
+       returnTc boxedTypeKind
+
+kcFunResType :: RenamedHsType -> TcM s TcKind
+-- The only place an unboxed tuple type is allowed
+-- is at the right hand end of an arrow
+kcFunResType (HsTupleTy (HsTupCon _ Unboxed) tys)
+  = mapTc kcTypeType tys       `thenTc_` 
+    returnTc unboxedTypeKind
+
+kcFunResType ty = kcHsType ty
+
 
 ---------------------------
 kcHsContext ctxt = mapTc_ kcHsPred ctxt
@@ -281,14 +292,6 @@ tcHsBoxedSigType ty
   = kcBoxedType ty     `thenTc_`
     tcHsType ty                `thenTc` \ ty' ->
     returnTc (hoistForAllTys ty')
-
-tcHsConSigType :: RenamedHsType -> TcM s Type
--- Used for constructor arguments, which must not
--- be unboxed tuples
-tcHsConSigType ty
-   = kcTypeType ty     `thenTc_`
-     tcHsArgType ty    `thenTc` \ ty' ->
-     returnTc (hoistForAllTys ty')
 \end{code}
 
 
@@ -296,17 +299,6 @@ tcHsType, the main work horse
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-tcHsArgType :: RenamedHsType -> TcM s TcType
--- Used the for function and constructor arguments, 
--- which are not allowed to be unboxed tuples
--- This is a bit ad hoc; we don't have a separate kind
--- for unboxed tuples
-tcHsArgType ty
-  = tcHsType ty                                `thenTc` \ tau_ty ->
-    checkTc (not (isUnboxedTupleType tau_ty))
-           (unboxedTupleErr ty)        `thenTc_`
-    returnTc tau_ty
-
 tcHsType :: RenamedHsType -> TcM s Type
 tcHsType ty@(HsTyVar name)
   = tc_app ty []
@@ -320,7 +312,7 @@ tcHsType (HsTupleTy (HsTupCon _ boxity) tys)
     returnTc (mkTupleTy boxity (length tys) tau_tys)
 
 tcHsType (HsFunTy ty1 ty2)
-  = tcHsArgType ty1    `thenTc` \ tau_ty1 ->
+  = tcHsType ty1       `thenTc` \ tau_ty1 ->
     tcHsType ty2       `thenTc` \ tau_ty2 ->
     returnTc (mkFunTy tau_ty1 tau_ty2)
 
@@ -352,7 +344,7 @@ tcHsType (HsUsgForAllTy uv_name ty)
 
 tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty)
   = kcTyVarScope tv_names 
-                (kcHsContext ctxt `thenTc_` kcHsType ty)  `thenTc` \ tv_kinds ->
+                (kcHsContext ctxt `thenTc_` kcFunResType ty)  `thenTc` \ tv_kinds ->
     let
        forall_tyvars = mkImmutTyVars tv_kinds
     in

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index a16fb0f..f0518d3 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -128,7 +128,7 @@ tcGroup unf_env scc
            rec_details = mkNameEnv rec_details_list
 
            tyclss, all_tyclss :: [(Name, TyThing)]
-           tyclss      = map (buildTyConOrClass is_rec kind_env rec_vrcs rec_details) decls
+           tyclss = map (buildTyConOrClass is_rec kind_env rec_vrcs rec_details) decls
 
                -- Add the tycons that come from the classes
                -- We want them in the environment because 
@@ -145,7 +145,7 @@ tcGroup unf_env scc
        mapTc (tcTyClDecl1 unf_env) decls       `thenTc` \ tycls_details ->
        tcGetEnv                                `thenNF_Tc` \ env -> 
        returnTc (tycls_details, env)
-    )                                                          `thenTc` \ (_, env) ->
+    )                                          `thenTc` \ (_, env) ->
     returnTc env
   where
     is_rec = case scc of

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 8e9a9ee..16d1845 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -20,7 +20,7 @@ import RnHsSyn                ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
 import TcHsSyn         ( TcMonoBinds, idsToMonoBinds )
 import BasicTypes      ( NewOrData(..) )
 
-import TcMonoType      ( tcHsType, tcHsConSigType, tcHsBoxedSigType, kcTyVarScope, tcClassContext,
+import TcMonoType      ( tcHsType, tcHsSigType, tcHsBoxedSigType, kcTyVarScope, tcClassContext,
                          kcHsContext, kcHsSigType, mkImmutTyVars
                        )
 import TcEnv           ( tcExtendTyVarEnv, tcLookupTy, tcLookupValueByKey, TyThing(..), TyThingDetails(..) )
@@ -154,7 +154,7 @@ tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt de
        RecCon fields      -> tc_rec_con ex_tyvars ex_theta fields
   where
     tc_sig_type = case new_or_data of
-                   DataType -> tcHsConSigType
+                   DataType -> tcHsSigType
                    NewType  -> tcHsBoxedSigType
            -- Can't allow an unboxed type here, because we're effectively
            -- going to remove the constructor while coercing it to a boxed type.

diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs
index 193f8fc..53e282c 100644 (file)
--- a/ghc/compiler/types/TypeRep.lhs
+++ b/ghc/compiler/types/TypeRep.lhs
@@ -202,7 +202,7 @@ boxity :: BX = *    -- Boxed
 There's a little subtyping at the kind level:  
        forall b. Type b <: OpenKind
 
-That is, a type of kind (Type b) OK in a context requiring an AnyBox.
+That is, a type of kind (Type b) is OK in a context requiring an OpenKind
 
 OpenKind, written '?', is used as the kind for certain type variables,
 in two situations: