towards newtype deriving dicts

Mon Sep 18 14:27:57 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * towards newtype deriving dicts
  Sat Aug  5 21:21:13 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * towards newtype deriving dicts
    Fri Jul  7 09:26:44 EDT 2006  kevind@bu.edu

4 files changed, 58 insertions, 35 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index d1d7a020a7..d36c94e1c6 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -316,7 +316,7 @@ mkDataConIds wrap_name wkr_name data_con
 			Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
 
 		MarkedUnboxed
-		   -> case splitProductType "do_unbox" (idType arg) of
+		   ->case splitProductType "do_unbox" (idType arg) of
 			   (tycon, tycon_args, con, tys) ->
 				   Case (Var arg) arg result_ty  
 					[(DataAlt con, 
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index fdf78cf0a4..b77796831a 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -314,6 +314,28 @@ or} has just one data constructor (e.g., tuples).
 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
 all those.
 
+Note [Newtype deriving superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The 'tys' here come from the partial application
+in the deriving clause. The last arg is the new
+instance type.
+
+We must pass the superclasses; the newtype might be an instance
+of them in a different way than the representation type
+E.g.		newtype Foo a = Foo a deriving( Show, Num, Eq )
+Then the Show instance is not done via isomorphism; it shows
+	Foo 3 as "Foo 3"
+The Num instance is derived via isomorphism, but the Show superclass
+dictionary must the Show instance for Foo, *not* the Show dictionary
+gotten from the Num dictionary. So we must build a whole new dictionary
+not just use the Num one.  The instance we want is something like:
+     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
+     	(+) = ((+)@a)
+     	...etc...
+There's no 'corece' needed because after the type checker newtypes
+are transparent.
+
 \begin{code}
 makeDerivEqns :: OverlapFlag
 	      -> [LTyClDecl Name] 
@@ -368,7 +390,7 @@ makeDerivEqns overlap_flag tycl_decls
 	   traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)	`thenM_`
        	   new_dfun_name clas tycon  		`thenM` \ dfun_name ->
 	   returnM (Nothing, Just (InstInfo { iSpec  = mk_inst_spec dfun_name,
-					      iBinds = NewTypeDerived (newTyConCo tycon) rep_tys }))
+					      iBinds = NewTypeDerived tycon rep_tys }))
       | std_class gla_exts clas
       = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys	-- Go via bale-out route
 
@@ -430,26 +452,11 @@ makeDerivEqns overlap_flag tycl_decls
 	rep_pred = mkClassPred clas rep_tys
 		-- rep_pred is the representation dictionary, from where
 		-- we are gong to get all the methods for the newtype dictionary
+        -- here we are figuring out what superclass dictionaries to use
+        -- see Note [Newtype deriving superclasses] above
 
 	inst_tys = (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)])
-		-- The 'tys' here come from the partial application
-		-- in the deriving clause. The last arg is the new
-		-- instance type.
-
-		-- We must pass the superclasses; the newtype might be an instance
-		-- of them in a different way than the representation type
-		-- E.g.		newtype Foo a = Foo a deriving( Show, Num, Eq )
-		-- Then the Show instance is not done via isomorphism; it shows
-		-- 	Foo 3 as "Foo 3"
-		-- The Num instance is derived via isomorphism, but the Show superclass
-		-- dictionary must the Show instance for Foo, *not* the Show dictionary
-		-- gotten from the Num dictionary. So we must build a whole new dictionary
-		-- not just use the Num one.  The instance we want is something like:
-		--	instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
-		--		(+) = ((+)@a)
-		--		...etc...
-		-- There's no 'corece' needed because after the type checker newtypes
-		-- are transparent.
+
 
 	sc_theta = substTheta (zipOpenTvSubst clas_tyvars inst_tys)
 			      (classSCTheta clas)
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 936ec5b5ac..b3e0d7fdea 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -566,7 +566,7 @@ data InstBindings
 				-- specialised instances
 
   | NewTypeDerived 		
-        (Maybe TyCon)           -- maybe a coercion for the newtype
+        TyCon                   -- tycon for the newtype
                                 -- Used for deriving instances of newtypes, where the
 	[Type]			-- witness dictionary is identical to the argument 
 				-- dictionary.  Hence no bindings, no pragmas
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 3e5584475f..50640a37fd 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -305,9 +305,13 @@ First comes the easy case of a non-local instance decl.
 tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
 -- Returns a binding for the dfun
 
-		** Explain superclass stuff ***
-
+--
 -- Derived newtype instances
+--
+-- We need to make a copy of the dictionary we are deriving from
+-- because we may need to change some of the superclass dictionaries
+-- see Note [Newtype deriving superclasses] in TcDeriv.lhs
+--
 -- In the case of a newtype, things are rather easy
 -- 	class Show a => Foo a b where ...
 -- 	newtype T a = MkT (Tree [a]) deriving( Foo Int )
@@ -316,23 +320,35 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
 --
 -- So all need is to generate a binding looking like
 -- 	dfunFooT :: forall a. (Show (T a), Foo Int (Tree [a]) => Foo Int (T a)
---	dfunFooT = /\a. \(ds:Show (T a) (df:Foo (Tree [a])).
+--	dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
 --		  case df `cast` (Foo Int (CoT a)) of
 --		     Foo _ op1 .. opn -> Foo ds op1 .. opn
 
 tcInstDecl2 (InstInfo { iSpec = ispec, 
-			iBinds = NewTypeDerived rep_tys })
-  = do	{ let dfun_id = instanceDFunId ispec 
-	      rigid_info = InstSkol dfun_id
-	      origin	 = SigOrigin rigid_info
-	      inst_ty    = idType dfun_id
+			iBinds = NewTypeDerived tycon rep_tys })
+  = do	{ let dfun_id      = instanceDFunId ispec 
+	      rigid_info   = InstSkol dfun_id
+	      origin	   = SigOrigin rigid_info
+	      inst_ty      = idType dfun_id
+              maybe_co_con = newTyConCo tycon
 	; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
-	; ASSERT( isSingleton theta )	-- Always the case for NewTypeDerived
-	  rep_dict <- newDict origin (head theta)
-
-	; let rep_dict_id = instToId rep_dict
-	      cast = 
-	      co_fn = CoTyLams tvs <.> CoLams [rep_dict_id] <.> ExprCoFn cast
+	; rep_dict <- newDict origin (head theta)
+        ; if isSingleton theta then
+              return (unitBag (VarBind dfun_id $
+                case maybe_co_con of
+                  Nothing -> rep_dict
+                  Just co_con -> mkCoerce rep_dict $
+                                 mkAppCoercion (mkAppsCoercion tycon rep_tys) 
+                                               (mkTyConApp co_con tvs)))
+          else do
+	  let rep_dict_id  = instToId rep_dict
+              coerced_dict = case maybe_co_con of
+                               Nothing -> rep_dict_id
+                               Just co_con -> mkCoerce rep_dict_id $
+                                 mkAppCoercion (mkAppsCoercion tycon rep_tys) 
+                                               (mkTyConApp co_con tvs)
+        ; return (unitBag (VarBind dfun_id 
+          co_fn = CoTyLams tvs <.> CoLams [rep_dict_id] <.> ExprCoFn cast
 
 	; return (unitBag (VarBind dfun_id (HsCoerce co_fn (HsVar rep_dict_id))))