X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBuildTyCl.lhs;h=8459edf98ad5ec54933f884af52260d3f8fb7dfd;hb=a08b4f85df5fbebc237bb7798cabe3812500e921;hp=66cb64506ce73a3c78f17232f24a14804fabfc4e;hpb=93ed9b8d722f093aea5fa0508ed1efb6e407a81a;p=ghc-hetmet.git

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 66cb645..8459edf 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -4,13 +4,6 @@
 %
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module BuildTyCl (
 	buildSynTyCon, buildAlgTyCon, buildDataCon,
 	buildClass,
@@ -21,12 +14,10 @@ module BuildTyCl (
 #include "HsVersions.h"
 
 import IfaceEnv
-import TcRnMonad
 
 import DataCon
 import Var
 import VarSet
-import TysWiredIn
 import BasicTypes
 import Name
 import OccName
@@ -37,6 +28,7 @@ import Type
 import Coercion
 
 import TcRnMonad
+import Util		( count )
 import Outputable
 
 import Data.List
@@ -217,6 +209,7 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
 -- the type variables mentioned in the arg_tys
 -- ToDo: Or functionally dependent on?  
 --	 This whole stupid theta thing is, well, stupid.
+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
 mkDataConStupidTheta tycon arg_tys univ_tvs
   | null stupid_theta = []	-- The common case
   | otherwise 	      = filter in_arg_tys stupid_theta
@@ -242,14 +235,17 @@ mkTyConSelIds tycon rhs
 
 ------------------------------------------------------
 \begin{code}
-buildClass :: Name -> [TyVar] -> ThetaType
+buildClass :: Bool			-- True <=> do not include unfoldings 
+					--	    on dict selectors
+					-- Used when importing a class without -O
+	   -> Name -> [TyVar] -> ThetaType
 	   -> [FunDep TyVar]		-- Functional dependencies
 	   -> [TyThing]			-- Associated types
 	   -> [(Name, DefMeth, Type)]	-- Method info
 	   -> RecFlag			-- Info for type constructor
 	   -> TcRnIf m n Class
 
-buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
+buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
   = do	{ traceIf (text "buildClass")
 	; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 	; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
@@ -261,7 +257,7 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
 
 	  let { rec_tycon  = classTyCon rec_clas
 	      ; op_tys	   = [ty | (_,_,ty) <- sig_stuff]
-	      ; op_items   = [ (mkDictSelId op_name rec_clas, dm_info)
+	      ; op_items   = [ (mkDictSelId no_unf op_name rec_clas, dm_info)
 			     | (op_name, dm_info, _) <- sig_stuff ] }
 	  		-- Build the selector id and default method id
 
@@ -274,22 +270,31 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
                                    op_tys
 				   rec_tycon
 
-	; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) 
-				[1..length (dataConDictTheta dict_con)]
+	; let n_value_preds   = count (not . isEqPred) sc_theta
+	      all_value_preds = n_value_preds == length sc_theta
+	      -- We only make selectors for the *value* superclasses, 
+	      -- not equality predicates 
+
+	; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc) 
+				[1..n_value_preds]
+        ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names]
 	      -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
-	      -- can construct names for the selectors.  Thus
+	      -- can construct names for the selectors. Thus
 	      --      class (C a, C b) => D a b where ...
 	      -- gives superclass selectors
 	      --      D_sc1, D_sc2
 	      -- (We used to call them D_C, but now we can have two different
 	      --  superclasses both called C!)
-        ; let sc_sel_ids = [mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names]
-
-		-- Use a newtype if the class constructor has exactly one field:
+	      --
+	
+	; let use_newtype = (n_value_preds + length sig_stuff == 1) && all_value_preds
+		-- Use a newtype if the data constructor has 
+		-- 	(a) exactly one value field
+		--	(b) no existential or equality-predicate fields
 		-- i.e. exactly one operation or superclass taken together
-		-- Watch out: the sc_theta includes equality predicates,
-		-- 	      which don't count for this purpose; hence dataConDictTheta
-	; rhs <- if ((length $ dataConDictTheta dict_con) + length sig_stuff) == 1
+		-- See note [Class newtypes and equality predicates]
+
+	; rhs <- if use_newtype
 		 then mkNewTyConRhs tycon_name rec_tycon dict_con
 		 else return (mkDataTyConRhs [dict_con])
 
@@ -316,4 +321,19 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
 	})}
 \end{code}
 
+Note [Class newtypes and equality predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+	class (a ~ F b) => C a b where
+	  op :: a -> b
+
+We cannot represent this by a newtype, even though it's not
+existential, and there's only one value field, because we do
+capture an equality predicate:
+
+	data C a b where
+	  MkC :: forall a b. (a ~ F b) => (a->b) -> C a b
+
+We need to access this equality predicate when we get passes a C
+dictionary.  See Trac #2238