X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHetMet%2FGArrow.hs;h=9f8aab10145218ad2a584880334422a38ce7e4f6;hb=b77972bb8793136b82db08061fc2b1703499880a;hp=9b151163ab59bbe9e26c6512b708ac8de911f67a;hpb=f827975d749073dbc8224fe74a3ee39393b26640;p=ghc-base.git

diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs
index 9b15116..9f8aab1 100644
--- a/GHC/HetMet/GArrow.hs
+++ b/GHC/HetMet/GArrow.hs
@@ -14,40 +14,50 @@ module GHC.HetMet.GArrow (
   GArrowDrop(..),
   GArrowCopy(..),
   GArrowSwap(..),
+
   GArrowLoop(..),
+
+  GArrowEval(..),
   GArrowConstant(..),
-  GArrowRun(..),
+  GArrowLiteral(..),   -- should be implemented, but never invoked, by user code
+
+  GArrowSum(..),
+  GArrowProd(..),
+
   GArrowReify(..),
-  GArrowReflect(..)
+  GArrowReflect(..),
+
+  GArrowCurry(..),
+  GArrowApply(..)
 ) where
 import Control.Category
 
 ------------------------------------------------------------------------
 -- The main GArrow class
 
-class Category g => GArrow g (**) | g -> (**) where
+class Category g => GArrow g (**) 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)
   ga_second    :: g x y -> g (z ** x) (z ** y)
-  ga_cancell   :: g (()**x) x
-  ga_cancelr   :: g (x**()) x
-  ga_uncancell :: g x       (()**x)
-  ga_uncancelr :: g x       (x**())
-  ga_assoc     :: g ((x**y)**z) (x**(y**z))
-  ga_unassoc   :: g (x**(y**z)) ((x**y)**z)
+  ga_cancell   :: g (u**x)         x
+  ga_cancelr   :: g    (x**u)      x
+  ga_uncancell :: g     x      (u**x)
+  ga_uncancelr :: g     x         (x**u)
+  ga_assoc     :: g ((x** y)**z ) ( x**(y **z))
+  ga_unassoc   :: g ( x**(y **z)) ((x** y)**z )
 
 
 ------------------------------------------------------------------------
 -- The three context-manipulation classes
 
-class GArrow g (**) => GArrowCopy g (**) where
+class GArrow g (**) u => GArrowCopy g (**) u where
   ga_copy      :: g x (x**x)
 
-class GArrow g (**) => GArrowDrop g (**) where
-  ga_drop      :: g x ()
+class GArrow g (**) u => GArrowDrop g (**) u where
+  ga_drop      :: g x u
 
-class GArrow g (**) => GArrowSwap g (**) where
+class GArrow g (**) u => GArrowSwap g (**) u where
   ga_swap      :: g (x**y) (y**x)
 
 ga_swap_second f =
@@ -61,34 +71,78 @@ ga_swap_second f =
 
 
 ------------------------------------------------------------------------
+-- Products, Coproducts, etc
+
+
+class (GArrow     g (**)  u,
+       GArrow     g (<*>) u) =>
+       GArrowProd g (**)  u (<*>) where
+  ga_prod_copy :: g x (x<*>x)
+  ga_prod_drop :: g x  u
+
+class (GArrow     g (**)  u,
+       GArrow     g (<+>) v) => 
+       GArrowSum  g (**)  u v (<+>) where
+  ga_merge :: g (x<+>x) x
+  ga_never :: g v       x
+      
+
+
+
+
+------------------------------------------------------------------------
 -- Loop
 
-class GArrow g (**) => GArrowLoop g (**) where
-  ga_loop      :: g (x**z) (y**z) -> g x y
+class GArrow g (**) u => GArrowLoop g (**) u where
+  ga_loopl    :: g (x**z) (y**z) -> g x y
+  ga_loopr    :: g (z**x) (z**y) -> g x y
+
+
+------------------------------------------------------------------------
+-- Literal.  Note that ga_literal should never appear in (unflattened)
+-- Haskell programs, though the user may wish to write implementations
+-- of this function (I haven't yet found a way to enforce this
+-- restriction using exports)
+
+class GArrow g (**) u => GArrowLiteral g (**) u t r where
+  ga_literal  :: t -> g u r
+
 
 
 
 ------------------------------------------------------------------------
 -- Constant and Run, which are dual to each other
 
-class GArrow g (**) => GArrowConstant g (**) where
-  ga_constant  :: a -> g () a
+class GArrow g (**) u => GArrowEval g (**) u r t where
+  ga_eval      :: g u r -> t
 
--- the dual of GArrowConstant
-class GArrow g (**) => GArrowRun g (**) where
-  ga_run       :: g () a -> a
+class GArrow g (**) u => GArrowConstant g (**) u t r where
+  ga_constant  :: t -> g u r
 
 
 
 ------------------------------------------------------------------------
 -- Reify and Reflect, which are "curried" versions
 
--- Not sure -- subject to change.  If you have this, you're basically
+-- If you have this for R the identity map on types, you're basically
 -- a Control.Arrow; you can also define essentially all the other
 -- methods of GArrow, GArrowDrop, GArrowCopy, etc in terms of this.
-class GArrow g (**) => GArrowReify g (**) where
-  ga_reify     :: (x -> y) -> g x y
+class GArrow g (**) u => GArrowReify g (**) u x y r q where
+  ga_reify     :: (x -> y) -> g r q
+
+class GArrow g (**) u => GArrowReflect g (**) u r q x y where
+  ga_reflect   :: g r q -> (x -> y)
+
+
+
+
+------------------------------------------------------------------------
+-- Apply and Curry
+
+class GArrow g (**) u => GArrowApply g (**) u (~>) where
+  ga_applyl    :: g (x**(x~>y)   ) y
+  ga_applyr    :: g (   (x~>y)**x) y
 
--- not sure -- subject to change
-class GArrow g (**) => GArrowReflect g (**) where
-  ga_reflect   :: g x y -> (x -> y)
+class GArrow g (**) u => GArrowCurry g (**) u (~>) where
+  ga_curryl    :: g (x**y) z  ->  g x (y~>z)
+  ga_curryr    :: g (x**y) z  ->  g y (x~>z)