GHC/HetMet/GArrow.hs

   1 {-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances #-}
   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   GArrowLoop(..),
  18   GArrowReify(..),
  19   GArrowReflect(..)
  20 ) where
  21 import Control.Arrow
  22 import Control.Category
  23
  24 class GArrow g (**) where
  25   ga_id        :: g x x
  26   ga_comp      :: g x y -> g y z -> g x z
  27   ga_first     :: g x y -> g (x ** z) (y ** z)
  28   ga_second    :: g x y -> g (z ** x) (z ** y)
  29   ga_cancell   :: g (()**x) x
  30   ga_cancelr   :: g (x**()) x
  31   ga_uncancell :: g x       (()**x)
  32   ga_uncancelr :: g x       (x**())
  33   ga_assoc     :: g ((x**y)**z) (x**(y**z))
  34   ga_unassoc   :: g (x**(y**z)) ((x**y)**z)
  35
  36 class GArrow g (**) => GArrowDrop g (**) where
  37   ga_drop      :: g x ()
  38
  39 class GArrow g (**) => GArrowCopy g (**) where
  40   ga_copy      :: g x (x**x)
  41
  42 class GArrow g (**) => GArrowSwap g (**) where
  43   ga_swap          :: g (x**y) (y**x)
  44
  45 -- implementation of ga_second for GArrowSwap instances
  46 ga_swap_second f = ga_comp (ga_comp ga_swap (ga_first f)) ga_swap
  47
  48 class GArrow g (**) => GArrowLoop g (**) where
  49   ga_loop      :: g (x**z) (y**z) -> g x y
  50
  51 class GArrow g (**) => GArrowLiteral g (**) a where
  52   ga_literal   :: a -> g () a
  53
  54 -- not sure -- subject to change
  55 class GArrow g (**) => GArrowReify g (**) where
  56   ga_reify     :: (x -> y) -> g x y
  57
  58 -- not sure -- subject to change
  59 class GArrow g (**) => GArrowReflect g (**) where
  60   ga_reflect   :: g x y -> (x -> y)
  61
  62
  63
  64 ------------------------------------------------------------------------------
  65 -- GArrow instances for Control.Arrow
  66
  67 instance Arrow a => GArrow a (,) where
  68   ga_id        =  arr Prelude.id
  69   ga_comp      =  (>>>)
  70   ga_first     =  first
  71   ga_second    =  second
  72   ga_cancell   =  arr (\((),x) -> x)
  73   ga_cancelr   =  arr (\(x,()) -> x)
  74   ga_uncancell =  arr (\x -> ((),x))
  75   ga_uncancelr =  arr (\x -> (x,()))
  76   ga_assoc     =  arr (\((x,y),z) -> (x,(y,z)))
  77   ga_unassoc   =  arr (\(x,(y,z)) -> ((x,y),z))
  78
  79 instance Arrow a => GArrowDrop a (,) where
  80   ga_drop      =  arr (\x -> ())
  81
  82 instance Arrow a => GArrowCopy a (,) where
  83   ga_copy      =  arr (\x -> (x,x))
  84
  85 instance Arrow a => GArrowSwap a (,) where
  86   ga_swap      =  arr (\(x,y) -> (y,x))
  87
  88 instance Arrow a => GArrowLiteral a (,) where
  89   ga_literal x =  arr (\() -> x)
  90
  91 instance Arrow a => GArrowReify a (,) where
  92   ga_reify     =  arr
  93
  94 instance ArrowLoop a => GArrowLoop a (,) where
  95   ga_loop      =  loop
  96
  97
  98
  99
 100 ------------------------------------------------------------------------------
 101 -- Category instance for GArrow
 102
 103 instance GArrow g => Category g where
 104   id   = ga_id
 105   x .y = ga_comp y x
 106
 107
 108