final revision to GArrow classes

diff --git a/GHC/HetMet/Arrow.hs b/GHC/HetMet/Arrow.hs
index 8352c78..5bead2c 100644 (file)
--- a/GHC/HetMet/Arrow.hs
+++ b/GHC/HetMet/Arrow.hs
@@ -20,7 +20,9 @@ import Control.Category
 -- algorithm often creates overlapping or even undecidable
 -- instance-search problems
 
-instance Arrow a => GArrow a (,) where
+type Id a = a
+
+instance Arrow a => GArrow a (,) () where
   ga_first     =  first
   ga_second    =  second
   ga_cancell   =  arr (\((),x) -> x)
@@ -30,24 +32,28 @@ instance Arrow a => GArrow a (,) where
   ga_assoc     =  arr (\((x,y),z) -> (x,(y,z)))
   ga_unassoc   =  arr (\(x,(y,z)) -> ((x,y),z))
   
-instance Arrow a => GArrowDrop a (,) where
+instance Arrow a => GArrowDrop a (,) () where
   ga_drop      =  arr (\x -> ())
 
-instance Arrow a => GArrowCopy a (,) where
+instance Arrow a => GArrowCopy a (,) () where
   ga_copy      =  arr (\x -> (x,x))
 
-instance Arrow a => GArrowSwap a (,) where
+instance Arrow a => GArrowSwap a (,) () where
   ga_swap      =  arr (\(x,y) -> (y,x))
 
-instance Arrow a => GArrowConstant a (,) where
+instance Arrow a => GArrowConstant a (,) () t t where
   ga_constant x = arr (\() -> x)
 
-instance Arrow a => GArrowReify a (,) where
+instance Arrow a => GArrowReify a (,) () x y x y where
   ga_reify     =  arr
 
-instance ArrowLoop a => GArrowLoop a (,) where
-  ga_loop      =  loop
+instance ArrowLoop a => GArrowLoop a (,) () where
+  ga_loopl     =  loop
+  ga_loopr  f  =  loop (ga_swap >>> f >>> ga_swap)
 
+instance ArrowApply a => GArrowApply a (,) () a where
+  ga_applyl    = ga_swap >>> app
+  ga_applyr    = app
 
 
 

diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs
index 9b15116..d55a807 100644 (file)
--- 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**(x~>y)   )
+  ga_curryr    :: g x (   (x~>y)**y)

diff --git a/GHC/HetMet/GArrowInstances.hs b/GHC/HetMet/GArrowInstances.hs
new file mode 100644 (file)
index 0000000..0292d38
--- /dev/null
+++ b/GHC/HetMet/GArrowInstances.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.HetMet.GArrowInstances
+-- Copyright   :  none
+-- License     :  public domain
+--
+-- Maintainer  :  Adam Megacz <megacz@acm.org>
+-- Stability   :  experimental
+-- Portability :  portable
+
+module GHC.HetMet.GArrowInstances (
+) where
+import Control.Category
+import GHC.HetMet.GArrow
+
+-- Various GArrow instances which may confuse the instance-inference
+-- mechanism if imported wholesale
+
+
+-- If a GArrow offers constants, then Haskell literals can be used to
+-- accomplish a GArrowLiteral implementation (the converse is not
+-- true!)
+--instance GArrowConstant g (**) u r t => GArrowLiteral g (**) u r t where
+--  ga_literal = ga_constant
+
+

diff --git a/base.cabal b/base.cabal
index 80a0dbc..8e49e32 100644 (file)
--- a/base.cabal
+++ b/base.cabal
@@ -59,6 +59,7 @@ Library {
             GHC.HetMet,
             GHC.HetMet.CodeTypes,
             GHC.HetMet.GArrow,
+            GHC.HetMet.GArrowInstances,
             GHC.HetMet.Arrow,
             GHC.MVar,
             GHC.IO,