X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHetMet%2FGArrow.hs;h=88f84fbaa5fa1d0eb3df44010c7dd943aa1c9b90;hb=1c5d86f9ab468292f9a52b079e25578ac83d07e2;hp=9853637c0a00752e32ca367c4bef110b60490237;hpb=8a1129a742003ddacb0fa331309434b5e2953cd8;p=ghc-base.git diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs index 9853637..88f84fb 100644 --- a/GHC/HetMet/GArrow.hs +++ b/GHC/HetMet/GArrow.hs @@ -14,82 +14,135 @@ module GHC.HetMet.GArrow ( GArrowDrop(..), GArrowCopy(..), GArrowSwap(..), + GArrowLoop(..), + + GArrowEval(..), + GArrowConstant(..), + GArrowLiteral(..), -- should be implemented, but never invoked, by user code + + GArrowSum(..), + GArrowProd(..), + GArrowReify(..), - GArrowReflect(..) + GArrowReflect(..), + + GArrowCurry(..), + GArrowApply(..) ) where -import Control.Arrow import Control.Category -class Category g => GArrow g (**) | g -> (**) where +------------------------------------------------------------------------ +-- The main GArrow class + +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 ) -class GArrow g (**) => GArrowDrop g (**) where - ga_drop :: g x () -class GArrow g (**) => GArrowCopy g (**) where +------------------------------------------------------------------------ +-- The three context-manipulation classes + +class GArrow g (**) u => GArrowCopy g (**) u where ga_copy :: g x (x**x) -class GArrow g (**) => GArrowSwap g (**) where - ga_swap :: g (x**y) (y**x) +class GArrow g (**) u => GArrowDrop g (**) u where + ga_drop :: g x u + +class GArrow g (**) u => GArrowSwap g (**) u where + ga_swap :: g (x**y) (y**x) + +ga_swap_second f = + ga_swap >>> ga_first f >>> ga_swap + -- implementation of ga_second for GArrowSwap + -- See also + -- http://haskell.org/haskellwiki/Class_system_extension_proposal + -- "Allowing superclass methods to be overridden in derived classes"; + -- if we had this we could do a better job here + + + +------------------------------------------------------------------------ +-- 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 (**) 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) --- implementation of ga_second for GArrowSwap instances -ga_swap_second f = ga_swap >>> ga_first f >>> ga_swap +class GArrow g (**) u => GArrowLiteral g (**) u t r where + ga_literal :: t -> g u r -class GArrow g (**) => GArrowLoop g (**) where - ga_loop :: g (x**z) (y**z) -> g x y -class GArrow g (**) => GArrowLiteral g (**) a where - ga_literal :: a -> g () a --- not sure -- subject to change -class GArrow g (**) => GArrowReify g (**) where - ga_reify :: (x -> y) -> g x y --- not sure -- subject to change -class GArrow g (**) => GArrowReflect g (**) where - ga_reflect :: g x y -> (x -> y) +------------------------------------------------------------------------ +-- Constant and Run, which are dual to each other +class GArrow g (**) u => GArrowEval g (**) u r t where + ga_eval :: g u r -> t +class GArrow g (**) u => GArrowConstant g (**) u t r where + ga_constant :: t -> g u r ------------------------------------------------------------------------------- --- 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)) +------------------------------------------------------------------------ +-- Reify and Reflect, which are "curried" versions -instance Arrow a => GArrowSwap a (,) where - ga_swap = arr (\(x,y) -> (y,x)) +-- 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 (**) u => GArrowReify g (**) u x y r q where + ga_reify :: (x -> y) -> g r q -instance Arrow a => GArrowLiteral a (,) b where - ga_literal x = arr (\() -> x) +class GArrow g (**) u => GArrowReflect g (**) u r q x y where + ga_reflect :: g r q -> (x -> y) -instance Arrow a => GArrowReify a (,) where - ga_reify = arr -instance ArrowLoop a => GArrowLoop a (,) where - ga_loop = loop +------------------------------------------------------------------------ +-- 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 +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)