X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBuildTyCl.lhs;h=6f56d4f4e14b8d09f63aa7180e9297402f9dd2b4;hb=9bcd95bad83ee937c178970e8b729732e680fe1e;hp=ef75d7f31a0c8c902c7f28af749afdc0be53986b;hpb=1fa3580c54985d73178d1d396b897176a57cd7f3;p=ghc-hetmet.git

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index ef75d7f..6f56d4f 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -93,7 +93,7 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
 --
 -- (1) create a coercion that identifies the family instance type and the
 --     representation type from Step (1); ie, it is of the form 
---	   `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
+--	   `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion,
 --	   `F' the family tycon and `R' the (derived) representation tycon,
 --	   and
 -- (2) produce a `TyConParent' value containing the parent and coercion
@@ -148,13 +148,16 @@ mkNewTyConRhs tycon_name tycon con
         -- non-recursive newtypes
     all_coercions = True
     tvs    = tyConTyVars tycon
-    rhs_ty = ASSERT(not (null (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs)))) 
-	     -- head (dataConInstOrigArgTys con (mkTyVarTys tvs))
-	     head (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))
+    inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
+    rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
 	-- 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
+	-- NB: a newtype DataCon has a type that must look like
+	--        forall tvs.  <arg-ty> -> T tvs
+	-- Note that we *can't* use dataConInstOrigArgTys here because
+	-- the newtype arising from   class Foo a => Bar a where {}
+  	-- has a single argument (Foo a) that is a *type class*, so
+	-- dataConInstOrigArgTys returns [].
 
     etad_tvs :: [TyVar]	-- Matched lazily, so that mkNewTypeCoercion can
     etad_rhs :: Type	-- return a TyCon without pulling on rhs_ty
@@ -180,14 +183,15 @@ buildDataCon :: Name -> Bool
             -> [(TyVar,Type)]           -- Equality spec
 	    -> ThetaType		-- Does not include the "stupid theta"
 					-- or the GADT equalities
-	    -> [Type] -> TyCon
+	    -> [Type] -> Type		-- Argument and result types
+	    -> TyCon			-- Rep tycon
 	    -> TcRnIf m n DataCon
 -- A wrapper for DataCon.mkDataCon that
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --	allocating its unique (hence monadic)
 buildDataCon src_name declared_infix arg_stricts field_lbls
-	     univ_tvs ex_tvs eq_spec ctxt arg_tys tycon
+	     univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
   = do	{ wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
 	; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
 	-- This last one takes the name of the data constructor in the source
@@ -195,11 +199,11 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
 	-- space, and puts it into the VarName name space
 
 	; let
-		stupid_ctxt = mkDataConStupidTheta tycon arg_tys univ_tvs
+		stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
 		data_con = mkDataCon src_name declared_infix
 				     arg_stricts field_lbls
 				     univ_tvs ex_tvs eq_spec ctxt
-				     arg_tys tycon
+				     arg_tys res_ty rep_tycon
 				     stupid_ctxt dc_ids
 		dc_ids = mkDataConIds wrap_name work_name data_con
 
@@ -268,7 +272,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 				   [{- No labelled fields -}]
 				   tvs [{- no existentials -}]
                                    [{- No GADT equalities -}] sc_theta 
-                                   op_tys
+                                   op_tys 
+				   (mkTyConApp rec_tycon (mkTyVarTys tvs))
 				   rec_tycon
 
 	; let n_value_preds   = count (not . isEqPred) sc_theta