c53e2f8d25e6711246ad196153df184abaeafb7c
[ghc-base.git] / GHC / HetMet / GArrow.hs
1 {-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module      :  GHC.HetMet.GArrow
5 -- Copyright   :  none
6 -- License     :  public domain
7 --
8 -- Maintainer  :  Adam Megacz <megacz@acm.org>
9 -- Stability   :  experimental
10 -- Portability :  portable
11
12 module GHC.HetMet.GArrow (
13   GArrow(..),
14   GArrowDrop(..),
15   GArrowCopy(..),
16   GArrowSwap(..),
17
18   GArrowLoop(..),
19
20   GArrowEval(..),
21   GArrowConstant(..),
22   GArrowLiteral(..),   -- should be implemented, but never invoked, by user code
23
24   GArrowSum(..),  ga_inl, ga_inr,
25   GArrowProd(..),
26
27   GArrowReify(..),
28   GArrowReflect(..),
29
30   GArrowCurry(..),
31   GArrowApply(..)
32 ) where
33 import Control.Category
34
35 ------------------------------------------------------------------------
36 -- The main GArrow class
37
38 class Category g => GArrow g (**) u | (**) -> u where
39 --id           :: g x x
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 )
49
50
51 ------------------------------------------------------------------------
52 -- The three context-manipulation classes
53
54 class GArrow g (**) u => GArrowCopy g (**) u where
55   ga_copy      :: g x (x**x)
56
57 class GArrow g (**) u => GArrowDrop g (**) u where
58   ga_drop      :: g x u
59
60 class GArrow g (**) u => GArrowSwap g (**) u where
61   ga_swap      :: g (x**y) (y**x)
62
63 ga_swap_second f =
64    ga_swap >>> ga_first f >>> ga_swap
65    -- implementation of ga_second for GArrowSwap
66    -- See also
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
70
71
72
73 ------------------------------------------------------------------------
74 -- Products, Coproducts, etc
75
76
77 class (GArrow     g (**)  u,
78        GArrow     g (<*>) v) =>
79        GArrowProd g (**)  u (<*>) v where
80   ga_prod_copy :: g x (x<*>x)
81   ga_prod_drop :: g x  v
82
83 class (GArrow     g (**)  u,
84        GArrow     g (<+>) v) => 
85        GArrowSum  g (**)  u (<+>) v where
86   ga_merge :: g (x<+>x) x
87   ga_never :: g v       x
88
89 ga_inl = ga_uncancelr >>> ga_second ga_never
90 ga_inr = ga_uncancell >>> ga_first  ga_never
91
92 ------------------------------------------------------------------------
93 -- Loop
94
95 class GArrow g (**) u => GArrowLoop g (**) u where
96   ga_loopl    :: g (x**z) (y**z) -> g x y
97   ga_loopr    :: g (z**x) (z**y) -> g x y
98
99
100 ------------------------------------------------------------------------
101 -- Literal.  Note that ga_literal should never appear in (unflattened)
102 -- Haskell programs, though the user may wish to write implementations
103 -- of this function (I haven't yet found a way to enforce this
104 -- restriction using exports)
105
106 class GArrow g (**) u => GArrowLiteral g (**) u t r where
107   ga_literal  :: t -> g u r
108
109
110
111
112 ------------------------------------------------------------------------
113 -- Constant and Run, which are dual to each other
114
115 class GArrow g (**) u => GArrowEval g (**) u r t where
116   ga_eval      :: g u r -> t
117
118 class GArrow g (**) u => GArrowConstant g (**) u t r where
119   ga_constant  :: t -> g u r
120
121
122
123 ------------------------------------------------------------------------
124 -- Reify and Reflect, which are "curried" versions
125
126 -- If you have this for R the identity map on types, you're basically
127 -- a Control.Arrow; you can also define essentially all the other
128 -- methods of GArrow, GArrowDrop, GArrowCopy, etc in terms of this.
129 class GArrow g (**) u => GArrowReify g (**) u x y r q where
130   ga_reify     :: (x -> y) -> g r q
131
132 class GArrow g (**) u => GArrowReflect g (**) u r q x y where
133   ga_reflect   :: g r q -> (x -> y)
134
135
136
137
138 ------------------------------------------------------------------------
139 -- Apply and Curry
140
141 class GArrow g (**) u => GArrowApply g (**) u (~>) where
142   ga_applyl    :: g (x**(x~>y)   ) y
143   ga_applyr    :: g (   (x~>y)**x) y
144
145 class GArrow g (**) u => GArrowCurry g (**) u (~>) where
146   ga_curryl    :: g (x**y) z  ->  g x (y~>z)
147   ga_curryr    :: g (x**y) z  ->  g y (x~>z)