X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBuildTyCl.lhs;h=534bc5f4f1e2df7a22a090a692140a645d25bf50;hb=7eb5e29b4a7b6fef55512bc7bf3308e712ca3eba;hp=333d8084ce4a301144cadb1ddcde85b41ef3c47c;hpb=6777144f7522d8db5935737e12fa451ca3211e6d;p=ghc-hetmet.git

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 333d808..534bc5f 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -4,6 +4,13 @@
 %
 
 \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,
@@ -29,6 +36,9 @@ import TyCon
 import Type
 import Coercion
 
+import TcRnMonad
+import Outputable
+
 import Data.List
 \end{code}
 	
@@ -132,22 +142,26 @@ mkNewTyConRhs tycon_name tycon con
 		          = Just co_tycon
                 	  | otherwise              
                 	  = Nothing
+	; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
 	; return (NewTyCon { data_con    = con, 
 		       	     nt_rhs      = rhs_ty,
 		       	     nt_etad_rhs = (etad_tvs, etad_rhs),
- 		       	     nt_co 	 = cocon_maybe, 
+ 		       	     nt_co 	 = cocon_maybe } ) }
                              -- Coreview looks through newtypes with a Nothing
                              -- for nt_co, or uses explicit coercions otherwise
-		       	     nt_rep = mkNewTyConRep tycon rhs_ty }) }
   where
         -- If all_coercions is True then we use coercions for all newtypes
         -- otherwise we use coercions for recursive newtypes and look through
         -- non-recursive newtypes
     all_coercions = True
     tvs    = tyConTyVars tycon
-    rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs))
+    rhs_ty = ASSERT(not (null (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs)))) 
+	     -- head (dataConInstOrigArgTys con (mkTyVarTys tvs))
+	     head (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))
 	-- Instantiate the data con with the 
 	-- type variables from the tycon
+	-- NB: a newtype DataCon has no existentials; hence the
+	--     call to dataConInstOrigArgTys has the right type args
 
     etad_tvs :: [TyVar]	-- Matched lazily, so that mkNewTypeCoercion can
     etad_rhs :: Type	-- return a TyCon without pulling on rhs_ty
@@ -165,42 +179,6 @@ mkNewTyConRhs tycon_name tycon con
     eta_reduce tvs ty = (reverse tvs, ty)
 				
 
-mkNewTyConRep :: TyCon		-- The original type constructor
-	      -> Type		-- The arg type of its constructor
-	      -> Type		-- Chosen representation type
--- The "representation type" is guaranteed not to be another newtype
--- at the outermost level; but it might have newtypes in type arguments
-
--- Find the representation type for this newtype TyCon
--- Remember that the representation type is the *ultimate* representation
--- type, looking through other newtypes.
--- 
--- splitTyConApp_maybe no longer looks through newtypes, so we must
--- deal explicitly with this case
--- 
--- The trick is to to deal correctly with recursive newtypes
--- such as	newtype T = MkT T
-
-mkNewTyConRep tc rhs_ty
-  | null (tyConDataCons tc) = unitTy
-	-- External Core programs can have newtypes with no data constructors
-  | otherwise		    = go [tc] rhs_ty
-  where
-	-- Invariant: tcs have been seen before
-    go tcs rep_ty 
-	= case splitTyConApp_maybe rep_ty of
-	    Just (tc, tys)
-		| tc `elem` tcs -> unitTy	-- Recursive loop
-		| isNewTyCon tc -> 
-                    if isRecursiveTyCon tc then
-			go (tc:tcs) (substTyWith tvs tys rhs_ty)
-                    else
-                        substTyWith tvs tys rhs_ty
-		where
-		  (tvs, rhs_ty) = newTyConRhs tc
-
-	    other -> rep_ty 
-
 ------------------------------------------------------
 buildDataCon :: Name -> Bool
 	    -> [StrictnessMark] 
@@ -272,44 +250,48 @@ buildClass :: Name -> [TyVar] -> ThetaType
 	   -> TcRnIf m n Class
 
 buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
-  = do	{ tycon_name <- newImplicitBinder class_name mkClassTyConOcc
+  = do	{ traceIf (text "buildClass")
+	; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 	; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
 		-- The class name is the 'parent' for this datacon, not its tycon,
 		-- because one should import the class to get the binding for 
 		-- the datacon
-	; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) 
-				[1..length sc_theta]
-	      -- We number off the superclass selectors, 1, 2, 3 etc so that we 
-	      -- 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!)
 
 	; fixM (\ rec_clas -> do {	-- Only name generation inside loop
 
-	  let { rec_tycon 	   = classTyCon rec_clas
-	      ; op_tys		   = [ty | (_,_,ty) <- sig_stuff]
-	      ; sc_tys		   = mkPredTys sc_theta
-	      ;	dict_component_tys = sc_tys ++ op_tys
-	      ; sc_sel_ids	   = [mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names]
-	      ; op_items = [ (mkDictSelId op_name rec_clas, dm_info)
-			   | (op_name, dm_info, _) <- sig_stuff ] }
+	  let { rec_tycon  = classTyCon rec_clas
+	      ; op_tys	   = [ty | (_,_,ty) <- sig_stuff]
+	      ; op_items   = [ (mkDictSelId op_name rec_clas, dm_info)
+			     | (op_name, dm_info, _) <- sig_stuff ] }
 	  		-- Build the selector id and default method id
 
 	; dict_con <- buildDataCon datacon_name
 				   False 	-- Not declared infix
-				   (map (const NotMarkedStrict) dict_component_tys)
+				   (map (const NotMarkedStrict) op_tys)
 				   [{- No labelled fields -}]
 				   tvs [{- no existentials -}]
-                                   [{- No equalities -}] [{-No context-}] 
-                                   dict_component_tys 
+                                   [{- No GADT equalities -}] sc_theta 
+                                   op_tys
 				   rec_tycon
 
-	; rhs <- case dict_component_tys of
-			    [rep_ty] -> mkNewTyConRhs tycon_name rec_tycon dict_con
-			    other    -> return (mkDataTyConRhs [dict_con])
+	; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) 
+				[1..length (dataConDictTheta dict_con)]
+	      -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
+	      -- 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:
+		-- 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
+		 then mkNewTyConRhs tycon_name rec_tycon dict_con
+		 else return (mkDataTyConRhs [dict_con])
 
 	; let {	clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 
@@ -324,10 +306,13 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
 		-- newtype like a synonym, but that will lead to an infinite
 		-- type]
 	      ; atTyCons = [tycon | ATyCon tycon <- ats]
+
+	      ; result = mkClass class_name tvs fds 
+			         sc_theta sc_sel_ids atTyCons
+				 op_items tycon
 	      }
-	; return (mkClass class_name tvs fds 
-		       sc_theta sc_sel_ids atTyCons op_items
-		       tycon)
+	; traceIf (text "buildClass" <+> ppr tycon) 
+	; return result
 	})}
 \end{code}