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
  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 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 where
  85   ga_prod_copy :: g x (x<*>x)
  86   ga_prod_drop :: g x  v
  87
  88 class (GArrow     g (**)  u,
  89        GArrow     g (<+>) v) =>
  90        GArrowSum  g (**)  u (<+>) v where
  91   ga_merge :: g (x<+>x) x
  92   ga_never :: g v       x
  93
  94 ga_inl = ga_uncancelr >>> ga_second ga_never
  95 ga_inr = ga_uncancell >>> ga_first  ga_never
  96
  97 ------------------------------------------------------------------------
  98 -- Loop
  99
 100 class GArrow g (**) u => GArrowLoop g (**) u where
 101   ga_loopl    :: g (x**z) (y**z) -> g x y
 102   ga_loopr    :: g (z**x) (z**y) -> g x y
 103
 104
 105 ------------------------------------------------------------------------
 106 -- Literal.  Note that ga_literal should never appear in (unflattened)
 107 -- Haskell programs, though the user may wish to write implementations
 108 -- of this function (I haven't yet found a way to enforce this
 109 -- restriction using exports)
 110
 111 class GArrow g (**) u => GArrowLiteral g (**) u t r where
 112   ga_literal  :: t -> g u r
 113
 114
 115
 116
 117 ------------------------------------------------------------------------
 118 -- Constant and Run, which are dual to each other
 119
 120 class GArrow g (**) u => GArrowEval g (**) u r t where
 121   ga_eval      :: g u r -> t
 122
 123 class GArrow g (**) u => GArrowConstant g (**) u t r where
 124   ga_constant  :: t -> g u r
 125
 126
 127
 128 ------------------------------------------------------------------------
 129 -- Reify and Reflect, which are "curried" versions
 130
 131 -- If you have this for R the identity map on types, you're basically
 132 -- a Control.Arrow; you can also define essentially all the other
 133 -- methods of GArrow, GArrowDrop, GArrowCopy, etc in terms of this.
 134 class GArrow g (**) u => GArrowReify g (**) u x y r q where
 135   ga_reify     :: (x -> y) -> g r q
 136
 137 class GArrow g (**) u => GArrowReflect g (**) u r q x y where
 138   ga_reflect   :: g r q -> (x -> y)
 139
 140
 141
 142
 143 ------------------------------------------------------------------------
 144 -- Apply and Curry
 145
 146 class GArrow g (**) u => GArrowApply g (**) u (~>) where
 147   ga_applyl    :: g (x**(x~>y)   ) y
 148   ga_applyr    :: g (   (x~>y)**x) y
 149
 150 class GArrow g (**) u => GArrowCurry g (**) u (~>) where
 151   ga_curryl    :: g (x**y) z  ->  g x (y~>z)
 152   ga_curryr    :: g (x**y) z  ->  g y (x~>z)
 153
 154
 155
 156
 157 ------------------------------------------------------------------------
 158 -- Commonly Implemented Collections of Classes
 159
 160 --
 161 -- The simply typed KAPPA calculus; see Hasegawa, __Decomposing Typed
 162 -- Lambda Calculus into a Couple of Categorical Programming
 163 -- Languages__, http://dx.doi.org/10.1007/3-540-60164-3_28
 164 --
 165 class (GArrowDrop  g (**) u,
 166        GArrowCopy  g (**) u,
 167        GArrowSwap  g (**) u) =>
 168        GArrowSTKC  g (**) u
 169
 170 -- The simply typed LAMBDA calculus
 171 class (GArrowSTKC  g (**) u,
 172        GArrowCurry g (**) u (~>),
 173        GArrowApply g (**) u (~>)) =>
 174        GArrowSTLC  g (**) u (~>)
 175
 176 -- Programming Language for Computable Functions (w/o integers and booleans)
 177 class (GArrowSTLC  g (**) u (~>),
 178        GArrowLoop  g (**) u) =>
 179        GArrowPCF   g (**) u (~>)
 180
 181
 182
 183
 184
 185
 186
 187
 188