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(..),
  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 (<*>) u) =>
  79        GArrowProd g (**)  u (<*>) where
  80   ga_prod_copy :: g x (x<*>x)
  81   ga_prod_drop :: g x  u
  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
  90
  91
  92
  93 ------------------------------------------------------------------------
  94 -- Loop
  95
  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
  99
 100
 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)
 106
 107 class GArrow g (**) u => GArrowLiteral g (**) u t r where
 108   ga_literal  :: t -> g u r
 109
 110
 111
 112
 113 ------------------------------------------------------------------------
 114 -- Constant and Run, which are dual to each other
 115
 116 class GArrow g (**) u => GArrowEval g (**) u r t where
 117   ga_eval      :: g u r -> t
 118
 119 class GArrow g (**) u => GArrowConstant g (**) u t r where
 120   ga_constant  :: t -> g u r
 121
 122
 123
 124 ------------------------------------------------------------------------
 125 -- Reify and Reflect, which are "curried" versions
 126
 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
 132
 133 class GArrow g (**) u => GArrowReflect g (**) u r q x y where
 134   ga_reflect   :: g r q -> (x -> y)
 135
 136
 137
 138
 139 ------------------------------------------------------------------------
 140 -- Apply and Curry
 141
 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
 145
 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)