GHC/HetMet/Arrow.hs

   1 {-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies -XEmptyDataDecls #-}
   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 type Id a = a
  24
  25 instance Arrow a => GArrow a (,) () where
  26   ga_first     =  first
  27   ga_second    =  second
  28   ga_cancell   =  arr (\((),x) -> x)
  29   ga_cancelr   =  arr (\(x,()) -> x)
  30   ga_uncancell =  arr (\x -> ((),x))
  31   ga_uncancelr =  arr (\x -> (x,()))
  32   ga_assoc     =  arr (\((x,y),z) -> (x,(y,z)))
  33   ga_unassoc   =  arr (\(x,(y,z)) -> ((x,y),z))
  34
  35 instance Arrow a => GArrowDrop a (,) () where
  36   ga_drop      =  arr (\x -> ())
  37
  38 instance Arrow a => GArrowCopy a (,) () where
  39   ga_copy      =  arr (\x -> (x,x))
  40
  41 instance Arrow a => GArrowSwap a (,) () where
  42   ga_swap      =  arr (\(x,y) -> (y,x))
  43
  44 instance Arrow a => GArrowConstant a (,) () t t where
  45   ga_constant x = arr (\() -> x)
  46
  47 instance Arrow a => GArrowReify a (,) () x y x y where
  48   ga_reify     =  arr
  49
  50 instance ArrowLoop a => GArrowLoop a (,) () where
  51   ga_loopl     =  loop
  52   ga_loopr  f  =  loop (ga_swap >>> f >>> ga_swap)
  53
  54 instance ArrowApply a => GArrowApply a (,) () a where
  55   ga_applyl    = ga_swap >>> app
  56   ga_applyr    = app
  57
  58 instance Arrow a => GArrowProd a (,) () (,) () where
  59   ga_prod_drop  = arr (\x -> ())
  60   ga_prod_copy  = arr (\x -> (x,x))
  61
  62 -- The uninhabited type
  63 data Void
  64
  65 -- In Coq we could simply prove that these cases are impossible; in Haskell we need to have some faith.
  66 voidImpossible :: Void -> a
  67 voidImpossible = error "this is impossible; you have a bug in your compiler"
  68
  69 instance ArrowChoice a => GArrow a Either Void where
  70   ga_first     =  left
  71   ga_second    =  right
  72   ga_uncancell =  arr Right
  73   ga_uncancelr =  arr Left
  74   ga_cancell   =  arr unVoidLeft
  75                    where
  76                     unVoidLeft  (Left  v) = voidImpossible v
  77                     unVoidRight (Right x) = x
  78   ga_cancelr   =  arr unVoidRight
  79                    where
  80                     unVoidRight (Left  x) = x
  81                     unVoidRight (Right v) = voidImpossible v
  82   ga_assoc     =  arr eitherAssoc
  83                    where
  84                     eitherAssoc (Left (Left  x)) = Left         x
  85                     eitherAssoc (Left (Right y)) = Right (Left  y)
  86                     eitherAssoc (Right       z ) = Right (Right z)
  87   ga_unassoc   =  arr eitherUnAssoc
  88                    where
  89                     eitherUnAssoc (Left         x ) = Left  (Left  x)
  90                     eitherUnAssoc (Right (Left  y)) = Left  (Right y)
  91                     eitherUnAssoc (Right (Right z)) = Right        z
  92
  93 instance ArrowChoice a => GArrowSum a (,) () Void Either where
  94   ga_never = arr voidImpossible
  95   ga_merge = arr merge
  96               where
  97                merge (Left  x) = x
  98                merge (Right x) = x
  99
 100
 101