From: simonpj <unknown>
Date: Wed, 27 Mar 2002 12:09:02 +0000 (+0000)
Subject: [project @ 2002-03-27 12:09:00 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~2215
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=95581e0c3b2d4d6edd33fdd6e135aa3917072c4c;p=ghc-hetmet.git

[project @ 2002-03-27 12:09:00 by simonpj]
More validity checking, esp for existential ctxt on data cons
---

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 186a5b8..08403bc 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -4,7 +4,7 @@
 \section[TcClassDcl]{Typechecking class declarations}
 
 \begin{code}
-module TcClassDcl ( tcClassDecl1, checkValidClass, tcClassDecls2, 
+module TcClassDcl ( tcClassDecl1, tcClassDecls2, 
 		    tcMethodBind, mkMethodBind, badMethodErr
 		  ) where
 
@@ -39,7 +39,7 @@ import TcType		( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
 			  tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitSigmaTy
 			)
 import TcMonad
-import Generics		( mkGenericRhs, validGenericMethodType )
+import Generics		( mkGenericRhs )
 import PrelInfo		( nO_METHOD_BINDING_ERROR_ID )
 import Class		( classTyVars, classBigSig, classTyCon, className,
 			  Class, ClassOpItem, DefMeth (..) )
@@ -238,52 +238,6 @@ tcClassSig clas clas_tyvars maybe_dm_env
     returnTc (local_ty, (sel_id, dm_info))
 \end{code}
 
-checkValidClass is called once the mutually-recursive knot has been
-tied, so we can look at things freely.
-
-\begin{code}
-checkValidClass :: Class -> TcM ()
-checkValidClass cls
-  = 	-- CHECK ARITY 1 FOR HASKELL 1.4
-    doptsTc Opt_GlasgowExts				`thenTc` \ gla_exts ->
-
-    	-- Check that the class is unary, unless GlaExs
-    checkTc (not (null tyvars))		(nullaryClassErr cls)	`thenTc_`
-    checkTc (gla_exts || unary) (classArityErr cls)	`thenTc_`
-
-   	-- Check the super-classes
-    checkValidTheta (ClassSCCtxt (className cls)) theta	`thenTc_`
-
-	-- Check the class operations
-    mapTc_ check_op op_stuff		`thenTc_`
-
-  	-- Check that if the class has generic methods, then the
-	-- class has only one parameter.  We can't do generic
-	-- multi-parameter type classes!
-    checkTc (unary || no_generics) (genericMultiParamErr cls)
-
-  where
-    (tyvars, theta, _, op_stuff) = classBigSig cls
-    unary 	= isSingleton tyvars
-    no_generics = null [() | (_, GenDefMeth) <- op_stuff]
-
-    check_op (sel_id, dm) 
-	= checkValidTheta SigmaCtxt (tail theta) 	`thenTc_`
-		-- The 'tail' removes the initial (C a) from the
-		-- class itself, leaving just the method type
-
-	  checkValidType (FunSigCtxt op_name) tau	`thenTc_`
-
-		-- Check that for a generic method, the type of 
-		-- the method is sufficiently simple
-	  checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
-		  (badGenericMethodType op_name op_ty)
-	where
-	  op_name = idName sel_id
-	  op_ty   = idType sel_id
-	  (_,theta,tau) = tcSplitSigmaTy op_ty
-\end{code}
-
 
 %************************************************************************
 %*									*
@@ -633,13 +587,6 @@ find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
 Contexts and errors
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}
-nullaryClassErr cls
-  = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
-
-classArityErr cls
-  = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
-	  parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
-
 defltMethCtxt clas
   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
 
@@ -653,11 +600,6 @@ badMethodErr clas op
 omittedMethodWarn sel_id
   = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
 
-badGenericMethodType op op_ty
-  = hang (ptext SLIT("Generic method type is too complex"))
-       4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
-		ptext SLIT("You can only use type variables, arrows, and tuples")])
-
 badGenericInstance sel_id
   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 	 ptext SLIT("because the instance declaration is not for a simple type (T a b c)"),
@@ -665,8 +607,4 @@ badGenericInstance sel_id
 
 mixedGenericErr op
   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
-
-genericMultiParamErr clas
-  = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> 
-    ptext SLIT("cannot have generic methods")
 \end{code}
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index e766564..1e21034 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -81,6 +81,10 @@ tcExpr :: RenamedHsExpr		-- Expession to type check
 	-> TcM (TcExpr, LIE)	-- Generalised expr with expected type, and LIE
 
 tcExpr expr expected_ty 
+  = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenNF_Tc_`
+    tc_expr' expr expected_ty
+
+tc_expr' expr expected_ty
   | not (isSigmaTy expected_ty)  -- Monomorphic case
   = tcMonoExpr expr expected_ty
 
diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 451e3fc..6f97acb 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -27,6 +27,7 @@ module TcMType (
   -- Checking type validity
   Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt,
   SourceTyCtxt(..), checkValidTheta, 
+  checkValidTyCon, checkValidClass, 
   checkValidInstHead, instTypeErr, checkAmbiguity,
 
   --------------------------------
@@ -64,13 +65,17 @@ import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			)
 import qualified Type	( splitFunTys )
 import Subst		( Subst, mkTopTyVarSubst, substTy )
-import Class		( Class, classArity, className )
+import Class		( Class, DefMeth(..), classArity, className, classBigSig )
 import TyCon		( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon, 
-			  tyConArity, tyConName, tyConKind )
+			  tyConArity, tyConName, tyConKind, tyConTheta, 
+			  getSynTyConDefn, tyConDataCons )
+import DataCon		( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
+import FieldLabel	( fieldLabelName, fieldLabelType )
 import PrimRep		( PrimRep(VoidRep) )
-import Var		( TyVar, tyVarKind, tyVarName, isTyVar, mkTyVar, isMutTyVar )
+import Var		( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar, mkTyVar, isMutTyVar )
 
 -- others:
+import Generics		( validGenericMethodType )
 import TcMonad          -- TcType, amongst others
 import TysWiredIn	( voidTy, listTyCon, tupleTyCon )
 import PrelNames	( cCallableClassKey, cReturnableClassKey, hasKey )
@@ -86,7 +91,7 @@ import CmdLineOpts	( dopt, DynFlag(..) )
 import Unique		( Uniquable(..) )
 import SrcLoc		( noSrcLoc )
 import Util		( nOfThem, isSingleton, equalLength )
-import ListSetOps	( removeDups )
+import ListSetOps	( equivClasses, removeDups )
 import Outputable
 \end{code}
 
@@ -944,6 +949,133 @@ checkThetaCtxt ctxt theta
 
 %************************************************************************
 %*									*
+\subsection{Validity check for TyCons}
+%*									*
+%************************************************************************
+
+checkValidTyCon is called once the mutually-recursive knot has been
+tied, so we can look at things freely.
+
+\begin{code}
+checkValidTyCon :: TyCon -> TcM ()
+checkValidTyCon tc
+  | isSynTyCon tc = checkValidType (TySynCtxt name) syn_rhs
+  | otherwise
+  = 	-- Check the context on the data decl
+    checkValidTheta (DataTyCtxt name) (tyConTheta tc)	`thenTc_` 
+	
+	-- Check arg types of data constructors
+    mapTc_ checkValidDataCon data_cons			`thenTc_`
+
+	-- Check that fields with the same name share a type
+    mapTc_ check_fields groups
+
+  where
+    name         = tyConName tc
+    (_, syn_rhs) = getSynTyConDefn tc
+    data_cons    = tyConDataCons tc
+
+    fields = [field | con <- data_cons, field <- dataConFieldLabels con]
+    groups = equivClasses cmp_name fields
+    cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
+
+    check_fields fields@(first_field_label : other_fields)
+	-- These fields all have the same name, but are from
+	-- different constructors in the data type
+	= 	-- Check that all the fields in the group have the same type
+		-- NB: this check assumes that all the constructors of a given
+		-- data type use the same type variables
+	  checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
+	where
+	    field_ty   = fieldLabelType first_field_label
+	    field_name = fieldLabelName first_field_label
+	    other_tys  = map fieldLabelType other_fields
+
+checkValidDataCon :: DataCon -> TcM ()
+checkValidDataCon con
+  = checkValidType ctxt (idType (dataConWrapId con))	`thenTc_`
+		-- This checks the argument types and
+		-- ambiguity of the existential context (if any)
+    tcAddErrCtxt (existentialCtxt con)
+		 (checkFreeness ex_tvs ex_theta)
+  where
+    ctxt = ConArgCtxt (dataConName con) 
+    (_, _, ex_tvs, ex_theta, _, _) = dataConSig con
+
+
+fieldTypeMisMatch field_name
+  = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
+
+existentialCtxt con = ptext SLIT("When checking the existential context of constructor") 
+		      <+> ppr con
+\end{code}
+
+
+checkValidClass is called once the mutually-recursive knot has been
+tied, so we can look at things freely.
+
+\begin{code}
+checkValidClass :: Class -> TcM ()
+checkValidClass cls
+  = 	-- CHECK ARITY 1 FOR HASKELL 1.4
+    doptsTc Opt_GlasgowExts				`thenTc` \ gla_exts ->
+
+    	-- Check that the class is unary, unless GlaExs
+    checkTc (not (null tyvars))		(nullaryClassErr cls)	`thenTc_`
+    checkTc (gla_exts || unary) (classArityErr cls)	`thenTc_`
+
+   	-- Check the super-classes
+    checkValidTheta (ClassSCCtxt (className cls)) theta	`thenTc_`
+
+	-- Check the class operations
+    mapTc_ check_op op_stuff		`thenTc_`
+
+  	-- Check that if the class has generic methods, then the
+	-- class has only one parameter.  We can't do generic
+	-- multi-parameter type classes!
+    checkTc (unary || no_generics) (genericMultiParamErr cls)
+
+  where
+    (tyvars, theta, _, op_stuff) = classBigSig cls
+    unary 	= isSingleton tyvars
+    no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+
+    check_op (sel_id, dm) 
+	= checkValidTheta SigmaCtxt (tail theta) 	`thenTc_`
+		-- The 'tail' removes the initial (C a) from the
+		-- class itself, leaving just the method type
+
+	  checkValidType (FunSigCtxt op_name) tau	`thenTc_`
+
+		-- Check that for a generic method, the type of 
+		-- the method is sufficiently simple
+	  checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
+		  (badGenericMethodType op_name op_ty)
+	where
+	  op_name = idName sel_id
+	  op_ty   = idType sel_id
+	  (_,theta,tau) = tcSplitSigmaTy op_ty
+
+nullaryClassErr cls
+  = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
+
+classArityErr cls
+  = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
+	  parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
+
+genericMultiParamErr clas
+  = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> 
+    ptext SLIT("cannot have generic methods")
+
+badGenericMethodType op op_ty
+  = hang (ptext SLIT("Generic method type is too complex"))
+       4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
+		ptext SLIT("You can only use type variables, arrows, and tuples")])
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Checking for a decent instance head type}
 %*									*
 %************************************************************************
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index affa0ca..27476db 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -25,11 +25,11 @@ import TcMonad
 import TcEnv		( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
 			  tcExtendKindEnv, tcLookup, tcExtendGlobalEnv,
 			  isLocalThing )
-import TcTyDecls	( tcTyDecl, kcConDetails, checkValidTyCon )
-import TcClassDcl	( tcClassDecl1, checkValidClass )
+import TcTyDecls	( tcTyDecl, kcConDetails )
+import TcClassDcl	( tcClassDecl1 )
 import TcInstDcls	( tcAddDeclCtxt )
 import TcMonoType	( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
-import TcMType		( newKindVar, zonkKindEnv )
+import TcMType		( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )
 import TcUnify		( unifyKind )
 import TcType		( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
 import Type		( splitTyConApp_maybe )
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 0ed2fef..636e67b 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -4,7 +4,7 @@
 \section[TcTyDecls]{Typecheck type declarations}
 
 \begin{code}
-module TcTyDecls ( tcTyDecl, checkValidTyCon, kcConDetails ) where
+module TcTyDecls ( tcTyDecl, kcConDetails ) where
 
 #include "HsVersions.h"
 
@@ -22,21 +22,19 @@ import TcEnv		( tcExtendTyVarEnv,
 			  TyThingDetails(..), RecTcEnv
 			)
 import TcType		( tcEqType, tyVarsOfTypes, tyVarsOfPred, ThetaType )
-import TcMType		( checkValidType, UserTypeCtxt(..), checkValidTheta, SourceTyCtxt(..) )
 import TcMonad
 
-import DataCon		( DataCon, mkDataCon, dataConFieldLabels, dataConWrapId, dataConName )
+import DataCon		( DataCon, mkDataCon, dataConFieldLabels )
+import FieldLabel	( fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel )
 import MkId		( mkDataConId, mkDataConWrapId, mkRecordSelId )
-import FieldLabel
-import Var		( TyVar, idType )
+import Var		( TyVar )
 import Name		( Name, NamedThing(..) )
 import Outputable
 import TyCon		( TyCon, DataConDetails(..), visibleDataCons,
-			  tyConName, tyConTheta, getSynTyConDefn, 
-			  tyConTyVars, tyConDataCons, isSynTyCon )
+			  tyConName, tyConTheta, 
+			  tyConTyVars, isSynTyCon )
 import VarSet		( intersectVarSet, isEmptyVarSet )
 import PrelNames	( unpackCStringName, unpackCStringUtf8Name )
-import ListSetOps	( equivClasses )
 import List		( nubBy )
 \end{code}
 
@@ -89,58 +87,6 @@ mkRecordSelectors unf_env tycon data_cons
 
 %************************************************************************
 %*									*
-\subsection{Validity check}
-%*									*
-%************************************************************************
-
-checkValidTyCon is called once the mutually-recursive knot has been
-tied, so we can look at things freely.
-
-\begin{code}
-checkValidTyCon :: TyCon -> TcM ()
-checkValidTyCon tc
-  | isSynTyCon tc = checkValidType (TySynCtxt name) syn_rhs
-  | otherwise
-  = 	-- Check the context on the data decl
-    checkValidTheta (DataTyCtxt name) (tyConTheta tc)	`thenTc_` 
-	
-	-- Check arg types of data constructors
-    mapTc_ check_data_con data_cons			`thenTc_`
-
-	-- Check that fields with the same name share a type
-    mapTc_ check_fields groups
-
-  where
-    name         = tyConName tc
-    (_, syn_rhs) = getSynTyConDefn tc
-    data_cons    = tyConDataCons tc
-
-    fields = [field | con <- data_cons, field <- dataConFieldLabels con]
-    groups = equivClasses cmp_name fields
-    cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
-
-    check_data_con con = checkValidType (ConArgCtxt (dataConName con)) 
-					(idType (dataConWrapId con))
-				-- This checks the argument types and
-				-- the existential context (if any)			 
-
-    check_fields fields@(first_field_label : other_fields)
-	-- These fields all have the same name, but are from
-	-- different constructors in the data type
-	= 	-- Check that all the fields in the group have the same type
-		-- NB: this check assumes that all the constructors of a given
-		-- data type use the same type variables
-	  checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
-	where
-	    field_ty   = fieldLabelType first_field_label
-	    field_name = fieldLabelName first_field_label
-	    other_tys  = map fieldLabelType other_fields
-\end{code}
-
-
-
-%************************************************************************
-%*									*
 \subsection{Kind and type check constructors}
 %*									*
 %************************************************************************
@@ -231,9 +177,6 @@ thinContext arg_tys ctxt
 
 
 \begin{code}
-fieldTypeMisMatch field_name
-  = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
-
 exRecConErr name
   = ptext SLIT("Can't combine named fields with locally-quantified type variables")
     $$