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