GHC/HetMet/GArrow.hs

   1 {-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -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
  33   GArrowSTKC(..),
  34   GArrowSTLC(..),
  35   GArrowPCF(..)
  36
  37 ) where
  38 import Control.Category
  39
  40 ------------------------------------------------------------------------
  41 -- The main GArrow class
  42
  43 class Category g => GArrow g (**) u | (**) -> u, u -> (**) where
  44 --id           :: g x x
  45 --comp         :: g x y -> g y z -> g x z
  46   ga_first     :: g x y -> g (x ** z) (y ** z)
  47   ga_second    :: g x y -> g (z ** x) (z ** y)
  48   ga_cancell   :: g (u**x)         x
  49   ga_cancelr   :: g    (x**u)      x
  50   ga_uncancell :: g     x      (u**x)
  51   ga_uncancelr :: g     x         (x**u)
  52   ga_assoc     :: g ((x** y)**z ) ( x**(y **z))
  53   ga_unassoc   :: g ( x**(y **z)) ((x** y)**z )
  54
  55
  56 ------------------------------------------------------------------------
  57 -- The three context-manipulation classes
  58
  59 class GArrow g (**) u => GArrowCopy g (**) u where
  60   ga_copy      :: g x (x**x)
  61
  62 class GArrow g (**) u => GArrowDrop g (**) u where
  63   ga_drop      :: g x u
  64
  65 class GArrow g (**) u => GArrowSwap g (**) u where
  66   ga_swap      :: g (x**y) (y**x)
  67
  68 ga_swap_second f =
  69    ga_swap >>> ga_first f >>> ga_swap
  70    -- implementation of ga_second for GArrowSwap
  71    -- See also
  72    -- http://haskell.org/haskellwiki/Class_system_extension_proposal
  73    -- "Allowing superclass methods to be overridden in derived classes";
  74    -- if we had this we could do a better job here
  75
  76
  77
  78 ------------------------------------------------------------------------
  79 -- Products, Coproducts, etc
  80
  81
  82 class (GArrow     g (**)  u,
  83        GArrow     g (<*>) v) =>
  84        GArrowProd g (**)  u (<*>) v
  85
  86        -- fundep: in any given context, (<*>) may serve as the
  87        -- product for at most one GArrow
  88        | (**) -> (<*>),
  89          (<*>) -> v, v -> (<*>) where
  90   ga_prod_copy :: g x (x<*>x)
  91   ga_prod_drop :: g x  v
  92
  93 class (GArrow     g (**)  u,
  94        GArrow     g (<+>) v) =>
  95        GArrowSum  g (**)  u (<+>) v
  96
  97        -- fundep: in any given context, (<+>) may serve as the
  98        -- coproduct for at most one GArrow
  99        | (<+>) -> (**),
 100          (<+>) -> v, v -> (<+>) where
 101   ga_merge :: g (x<+>x) x
 102   ga_never :: g v       x
 103
 104 -- Note to self: do not remove this type declaration; it ensures that if
 105 -- I fiddle with the GArrowSum fundeps and get them wrong (i.e. insufficient)
 106 -- I'll find out about it when compiling the base library.
 107 ga_inl :: GArrowSum g (**) u (<+>) v => g x (x<+>y)
 108 ga_inl = ga_uncancelr >>> ga_second ga_never
 109
 110 ga_inr :: GArrowSum g (**) u (<+>) v => g x (y<+>x)
 111 ga_inr = ga_uncancell >>> ga_first  ga_never
 112
 113
 114 ------------------------------------------------------------------------
 115 -- Loop
 116
 117 class GArrow g (**) u => GArrowLoop g (**) u where
 118   ga_loopl    :: g (x**z) (y**z) -> g x y
 119   ga_loopr    :: g (z**x) (z**y) -> g x y
 120
 121
 122 ------------------------------------------------------------------------
 123 -- Literal.  Note that ga_literal should never appear in (unflattened)
 124 -- Haskell programs, though the user may wish to write implementations
 125 -- of this function (I haven't yet found a way to enforce this
 126 -- restriction using exports)
 127
 128 class GArrow g (**) u => GArrowLiteral g (**) u t r where
 129   ga_literal  :: t -> g u r
 130
 131
 132
 133
 134 ------------------------------------------------------------------------
 135 -- Constant and Run, which are dual to each other
 136
 137 class GArrow g (**) u => GArrowEval g (**) u r t where
 138   ga_eval      :: g u r -> t
 139
 140 class GArrow g (**) u => GArrowConstant g (**) u t r where
 141   ga_constant  :: t -> g u r
 142
 143
 144
 145 ------------------------------------------------------------------------
 146 -- Reify and Reflect, which are "curried" versions
 147
 148 -- If you have this for R the identity map on types, you're basically
 149 -- a Control.Arrow; you can also define essentially all the other
 150 -- methods of GArrow, GArrowDrop, GArrowCopy, etc in terms of this.
 151 class GArrow g (**) u => GArrowReify g (**) u x y r q where
 152   ga_reify     :: (x -> y) -> g r q
 153
 154 class GArrow g (**) u => GArrowReflect g (**) u r q x y where
 155   ga_reflect   :: g r q -> (x -> y)
 156
 157
 158
 159
 160 ------------------------------------------------------------------------
 161 -- Apply and Curry
 162
 163 class GArrow g (**) u => GArrowApply g (**) u (~>) where
 164   ga_applyl    :: g (x**(x~>y)   ) y
 165   ga_applyr    :: g (   (x~>y)**x) y
 166
 167 class GArrow g (**) u => GArrowCurry g (**) u (~>) where
 168   ga_curryl    :: g (x**y) z  ->  g x (y~>z)
 169   ga_curryr    :: g (x**y) z  ->  g y (x~>z)
 170
 171
 172
 173
 174 ------------------------------------------------------------------------
 175 -- Commonly Implemented Collections of Classes
 176
 177 --
 178 -- The simply typed KAPPA calculus; see Hasegawa, __Decomposing Typed
 179 -- Lambda Calculus into a Couple of Categorical Programming
 180 -- Languages__, http://dx.doi.org/10.1007/3-540-60164-3_28
 181 --
 182 class (GArrowDrop  g (**) u,
 183        GArrowCopy  g (**) u,
 184        GArrowSwap  g (**) u) =>
 185        GArrowSTKC  g (**) u
 186
 187 -- The simply typed LAMBDA calculus
 188 class (GArrowSTKC  g (**) u,
 189        GArrowCurry g (**) u (~>),
 190        GArrowApply g (**) u (~>)) =>
 191        GArrowSTLC  g (**) u (~>)
 192
 193 -- Programming Language for Computable Functions (w/o integers and booleans)
 194 class (GArrowSTLC  g (**) u (~>),
 195        GArrowLoop  g (**) u) =>
 196        GArrowPCF   g (**) u (~>)
 197
 198
 199
 200
 201
 202
 203
 204
 205