GHC/HetMet/Arrow.hs

   1 {-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  GHC.HetMet.Arrow
   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.Arrow where
  13 import GHC.HetMet.GArrow
  14 import Control.Arrow
  15 import Control.Category
  16
  17 ------------------------------------------------------------------------------
  18 -- GArrow instances for Control.Arrow; this is kept in a separate
  19 -- module because having it available to GHC's instance-search
  20 -- algorithm often creates overlapping or even undecidable
  21 -- instance-search problems
  22
  23 instance Arrow a => GArrow a (,) where
  24   ga_first     =  first
  25   ga_second    =  second
  26   ga_cancell   =  arr (\((),x) -> x)
  27   ga_cancelr   =  arr (\(x,()) -> x)
  28   ga_uncancell =  arr (\x -> ((),x))
  29   ga_uncancelr =  arr (\x -> (x,()))
  30   ga_assoc     =  arr (\((x,y),z) -> (x,(y,z)))
  31   ga_unassoc   =  arr (\(x,(y,z)) -> ((x,y),z))
  32
  33 instance Arrow a => GArrowDrop a (,) where
  34   ga_drop      =  arr (\x -> ())
  35
  36 instance Arrow a => GArrowCopy a (,) where
  37   ga_copy      =  arr (\x -> (x,x))
  38
  39 instance Arrow a => GArrowSwap a (,) where
  40   ga_swap      =  arr (\(x,y) -> (y,x))
  41
  42 instance Arrow a => GArrowConstant a (,) where
  43   ga_constant x = arr (\() -> x)
  44
  45 instance Arrow a => GArrowReify a (,) where
  46   ga_reify     =  arr
  47
  48 instance ArrowLoop a => GArrowLoop a (,) where
  49   ga_loop      =  loop
  50
  51
  52
  53
  54
  55
  56