From: Adam Megacz <megacz@cs.berkeley.edu>
Date: Thu, 14 Apr 2011 21:41:20 +0000 (-0700)
Subject: add more fundeps for GArrow clases, remove -XFlexibleInstances
X-Git-Url: http://git.megacz.com/?p=ghc-base.git;a=commitdiff_plain;h=aacbf981df184f572660fab36530b2fe372cab27

add more fundeps for GArrow clases, remove -XFlexibleInstances
---

diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs
index 3b64d90..e981d9b 100644
--- a/GHC/HetMet/GArrow.hs
+++ b/GHC/HetMet/GArrow.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-}
+{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFunctionalDependencies #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.HetMet.GArrow
@@ -40,7 +40,7 @@ import Control.Category
 ------------------------------------------------------------------------
 -- The main GArrow class
 
-class Category g => GArrow g (**) u | (**) -> u where
+class Category g => GArrow g (**) u | (**) -> u, u -> (**) where
 --id           :: g x x
 --comp         :: g x y -> g y z -> g x z
   ga_first     :: g x y -> g (x ** z) (y ** z)
@@ -81,19 +81,36 @@ ga_swap_second f =
 
 class (GArrow     g (**)  u,
        GArrow     g (<*>) v) =>
-       GArrowProd g (**)  u (<*>) v where
+       GArrowProd g (**)  u (<*>) v
+
+       -- fundep: in any given context, (<*>) may serve as the 
+       -- product for at most one GArrow
+       | (**) -> (<*>),
+         (<*>) -> v, v -> (<*>) where
   ga_prod_copy :: g x (x<*>x)
   ga_prod_drop :: g x  v
 
 class (GArrow     g (**)  u,
        GArrow     g (<+>) v) => 
-       GArrowSum  g (**)  u (<+>) v where
+       GArrowSum  g (**)  u (<+>) v
+
+       -- fundep: in any given context, (<+>) may serve as the 
+       -- coproduct for at most one GArrow
+       | (<+>) -> (**),
+         (<+>) -> v, v -> (<+>) where
   ga_merge :: g (x<+>x) x
   ga_never :: g v       x
 
+-- Note to self: do not remove this type declaration; it ensures that if
+-- I fiddle with the GArrowSum fundeps and get them wrong (i.e. insufficient)
+-- I'll find out about it when compiling the base library.
+ga_inl :: GArrowSum g (**) u (<+>) v => g x (x<+>y)
 ga_inl = ga_uncancelr >>> ga_second ga_never
+
+ga_inr :: GArrowSum g (**) u (<+>) v => g x (y<+>x)
 ga_inr = ga_uncancell >>> ga_first  ga_never
 
+
 ------------------------------------------------------------------------
 -- Loop
 
diff --git a/GHC/HetMet/GArrowInstances.hs b/GHC/HetMet/GArrowInstances.hs
index 0292d38..f301a95 100644
--- a/GHC/HetMet/GArrowInstances.hs
+++ b/GHC/HetMet/GArrowInstances.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-}
+{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFunctionalDependencies #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.HetMet.GArrowInstances