-- 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)
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
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 =
------------------------------------------------------------------------
+-- 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)
--- /dev/null
+{-# 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
+
+