make Control.Category a superclass of GArrow

[ghc-base.git] / GHC / HetMet / GArrow.hs

diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs
index d31436c..9853637 100644 (file)
--- a/GHC/HetMet/GArrow.hs
+++ b/GHC/HetMet/GArrow.hs
@@ -1,4 +1,14 @@
-{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators #-}
+{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.HetMet.GArrow
+-- Copyright   :  none
+-- License     :  public domain
+--
+-- Maintainer  :  Adam Megacz <megacz@acm.org>
+-- Stability   :  experimental
+-- Portability :  portable
+
 module GHC.HetMet.GArrow (
   GArrow(..),
   GArrowDrop(..),
@@ -8,10 +18,10 @@ module GHC.HetMet.GArrow (
   GArrowReify(..),
   GArrowReflect(..)
 ) where
+import Control.Arrow
+import Control.Category
 
-class GArrow g (**) where
-  ga_id        :: g x x
-  ga_comp      :: g x y -> g y z -> g x z
+class Category g => GArrow g (**) | g -> (**) where
   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
@@ -28,8 +38,10 @@ class GArrow g (**) => GArrowCopy g (**) where
   ga_copy      :: g x (x**x)
 
 class GArrow g (**) => GArrowSwap g (**) where
-  ga_swap      :: g (x**y) (y**x)
-  --ga_second  f =  ga_comp (ga_comp ga_swap (ga_first f)) ga_swap
+  ga_swap          :: g (x**y) (y**x)
+
+-- implementation of ga_second for GArrowSwap instances
+ga_swap_second f = ga_swap >>> ga_first f >>> ga_swap
 
 class GArrow g (**) => GArrowLoop g (**) where
   ga_loop      :: g (x**z) (y**z) -> g x y
@@ -37,12 +49,47 @@ class GArrow g (**) => GArrowLoop g (**) where
 class GArrow g (**) => GArrowLiteral g (**) a where
   ga_literal   :: a -> g () a
 
--- not sure
+-- not sure -- subject to change
 class GArrow g (**) => GArrowReify g (**) where
   ga_reify     :: (x -> y) -> g x y
 
--- not sure
+-- not sure -- subject to change
 class GArrow g (**) => GArrowReflect g (**) where
   ga_reflect   :: g x y -> (x -> y)
 
 
+
+------------------------------------------------------------------------------
+-- GArrow instances for Control.Arrow
+
+instance Arrow a => GArrow a (,) where
+  ga_first     =  first
+  ga_second    =  second
+  ga_cancell   =  arr (\((),x) -> x)
+  ga_cancelr   =  arr (\(x,()) -> x)
+  ga_uncancell =  arr (\x -> ((),x))
+  ga_uncancelr =  arr (\x -> (x,()))
+  ga_assoc     =  arr (\((x,y),z) -> (x,(y,z)))
+  ga_unassoc   =  arr (\(x,(y,z)) -> ((x,y),z))
+  
+instance Arrow a => GArrowDrop a (,) where
+  ga_drop      =  arr (\x -> ())
+
+instance Arrow a => GArrowCopy a (,) where
+  ga_copy      =  arr (\x -> (x,x))
+
+instance Arrow a => GArrowSwap a (,) where
+  ga_swap      =  arr (\(x,y) -> (y,x))
+
+instance Arrow a => GArrowLiteral a (,) b where
+  ga_literal x =  arr (\() -> x)
+
+instance Arrow a => GArrowReify a (,) where
+  ga_reify     =  arr
+
+instance ArrowLoop a => GArrowLoop a (,) where
+  ga_loop      =  loop
+
+
+
+