From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Wed, 20 Sep 2006 18:37:42 +0000 (+0000)
Subject: Fixed bug in coercion for indexed data types
X-Git-Tag: After_FC_branch_merge~26
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a7a32655a398d0bad611314f0f73c0dcbf2588f4

Fixed bug in coercion for indexed data types
Mon Sep 18 19:12:51 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Fixed bug in coercion for indexed data types
  Fri Aug 25 16:45:29 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Fixed bug in coercion for indexed data types
    - Significant examples are starting to work; eg, generic finite maps:

    class GMapKey k where
      data GMap k :: * -> *
      empty       :: GMap k v
      lookup      :: k -> GMap k v -> Maybe v
      insert      :: k -> v -> GMap k v -> GMap k v

    instance GMapKey Int where
      data GMap Int v        = GMapInt (Map.Map Int v)
      empty                  = GMapInt Map.empty
      lookup k (GMapInt m)   = Map.lookup k m
      insert k v (GMapInt m) = GMapInt (Map.insert k v m)

    instance GMapKey Char where
      data GMap Char v        = GMapChar (GMap Int v)
      empty                   = GMapChar empty
      lookup k (GMapChar m)   = lookup (ord k) m
      insert k v (GMapChar m) = GMapChar (insert (ord k) v m)

    instance GMapKey () where
      data GMap () v           = GMapUnit (Maybe v)
      empty                    = GMapUnit Nothing
      lookup () (GMapUnit v)   = v
      insert () v (GMapUnit _) = GMapUnit $ Just v

    instance (GMapKey a, GMapKey b) => GMapKey (a, b) where
      data GMap (a, b) v            = GMapPair (GMap a (GMap b v))
      empty		                = GMapPair empty
      lookup (a, b) (GMapPair gm)   = lookup a gm >>= lookup b
      insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of
    				    Nothing  -> insert a (insert b v empty) gm
    				    Just gm2 -> insert a (insert b v gm2  ) gm

    instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where
      data GMap (Either a b) v                = GMapEither (GMap a v) (GMap b v)
      empty                                   = GMapEither empty empty
      lookup (Left  a) (GMapEither gm1  _gm2) = lookup a gm1
      lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2
      insert (Left  a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2
      insert (Right a) v (GMapEither gm1 gm2) = GMapEither gm1 (insert a v gm2)
---

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 3e1d071..fb91a0d 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -340,10 +340,10 @@ mkDataInstCoercion name tvs family instTys rep_tycon
   where
     coArity = length tvs
 
-    rule args = (substTyWith tvs tys $		      -- with sigma = [tys/tvs]
-		   TyConApp family instTys,	      --       sigma (F ts)
-		 TyConApp rep_tycon (mkTyVarTys tvs), --   :=: R tys
-		 rest)				      -- surplus arguments
+    rule args = (substTyWith tvs tys $		     -- with sigma = [tys/tvs],
+		   TyConApp family instTys,	     --       sigma (F ts)
+		 TyConApp rep_tycon tys,	     --   :=: R tys
+		 rest)				     -- surplus arguments
       where
         tys  = take coArity args
         rest = drop coArity args