1 {-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-}
2 -----------------------------------------------------------------------------
4 -- Module : GHC.HetMet.GArrow
6 -- License : public domain
8 -- Maintainer : Adam Megacz <megacz@acm.org>
9 -- Stability : experimental
10 -- Portability : portable
12 module GHC.HetMet.GArrow (
22 GArrowLiteral(..), -- should be implemented, but never invoked, by user code
33 import Control.Category
35 ------------------------------------------------------------------------
36 -- The main GArrow class
38 class Category g => GArrow g (**) u | (**) -> u where
40 --comp :: g x y -> g y z -> g x z
41 ga_first :: g x y -> g (x ** z) (y ** z)
42 ga_second :: g x y -> g (z ** x) (z ** y)
43 ga_cancell :: g (u**x) x
44 ga_cancelr :: g (x**u) x
45 ga_uncancell :: g x (u**x)
46 ga_uncancelr :: g x (x**u)
47 ga_assoc :: g ((x** y)**z ) ( x**(y **z))
48 ga_unassoc :: g ( x**(y **z)) ((x** y)**z )
51 ------------------------------------------------------------------------
52 -- The three context-manipulation classes
54 class GArrow g (**) u => GArrowCopy g (**) u where
57 class GArrow g (**) u => GArrowDrop g (**) u where
60 class GArrow g (**) u => GArrowSwap g (**) u where
61 ga_swap :: g (x**y) (y**x)
64 ga_swap >>> ga_first f >>> ga_swap
65 -- implementation of ga_second for GArrowSwap
67 -- http://haskell.org/haskellwiki/Class_system_extension_proposal
68 -- "Allowing superclass methods to be overridden in derived classes";
69 -- if we had this we could do a better job here
73 ------------------------------------------------------------------------
74 -- Products, Coproducts, etc
77 class (GArrow g (**) u,
79 GArrowProd g (**) u (<*>) v where
80 ga_prod_copy :: g x (x<*>x)
83 class (GArrow g (**) u,
85 GArrowSum g (**) u (<+>) v where
86 ga_merge :: g (x<+>x) x
93 ------------------------------------------------------------------------
96 class GArrow g (**) u => GArrowLoop g (**) u where
97 ga_loopl :: g (x**z) (y**z) -> g x y
98 ga_loopr :: g (z**x) (z**y) -> g x y
101 ------------------------------------------------------------------------
102 -- Literal. Note that ga_literal should never appear in (unflattened)
103 -- Haskell programs, though the user may wish to write implementations
104 -- of this function (I haven't yet found a way to enforce this
105 -- restriction using exports)
107 class GArrow g (**) u => GArrowLiteral g (**) u t r where
108 ga_literal :: t -> g u r
113 ------------------------------------------------------------------------
114 -- Constant and Run, which are dual to each other
116 class GArrow g (**) u => GArrowEval g (**) u r t where
117 ga_eval :: g u r -> t
119 class GArrow g (**) u => GArrowConstant g (**) u t r where
120 ga_constant :: t -> g u r
124 ------------------------------------------------------------------------
125 -- Reify and Reflect, which are "curried" versions
127 -- If you have this for R the identity map on types, you're basically
128 -- a Control.Arrow; you can also define essentially all the other
129 -- methods of GArrow, GArrowDrop, GArrowCopy, etc in terms of this.
130 class GArrow g (**) u => GArrowReify g (**) u x y r q where
131 ga_reify :: (x -> y) -> g r q
133 class GArrow g (**) u => GArrowReflect g (**) u r q x y where
134 ga_reflect :: g r q -> (x -> y)
139 ------------------------------------------------------------------------
142 class GArrow g (**) u => GArrowApply g (**) u (~>) where
143 ga_applyl :: g (x**(x~>y) ) y
144 ga_applyr :: g ( (x~>y)**x) y
146 class GArrow g (**) u => GArrowCurry g (**) u (~>) where
147 ga_curryl :: g (x**y) z -> g x (y~>z)
148 ga_curryr :: g (x**y) z -> g y (x~>z)