1 {-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies -XEmptyDataDecls #-}
2 -----------------------------------------------------------------------------
4 -- Module : GHC.HetMet.Arrow
6 -- License : public domain
8 -- Maintainer : Adam Megacz <megacz@acm.org>
9 -- Stability : experimental
10 -- Portability : portable
12 module GHC.HetMet.Arrow where
13 import GHC.HetMet.GArrow
15 import Control.Category
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
25 instance Arrow a => GArrow a (,) () where
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))
35 instance Arrow a => GArrowDrop a (,) () where
36 ga_drop = arr (\x -> ())
38 instance Arrow a => GArrowCopy a (,) () where
39 ga_copy = arr (\x -> (x,x))
41 instance Arrow a => GArrowSwap a (,) () where
42 ga_swap = arr (\(x,y) -> (y,x))
44 instance Arrow a => GArrowConstant a (,) () t t where
45 ga_constant x = arr (\() -> x)
47 instance Arrow a => GArrowReify a (,) () x y x y where
50 instance ArrowLoop a => GArrowLoop a (,) () where
52 ga_loopr f = loop (ga_swap >>> f >>> ga_swap)
54 instance ArrowApply a => GArrowApply a (,) () a where
55 ga_applyl = ga_swap >>> app
58 instance Arrow a => GArrowProd a (,) () where
60 -- The uninhabited type
63 -- In Coq we could simply prove that these cases are impossible; in Haskell we need to have some faith.
64 voidImpossible :: Void -> a
65 voidImpossible = error "this is impossible; you have a bug in your compiler"
67 instance ArrowChoice a => GArrow a Either Void where
70 ga_uncancell = arr Right
71 ga_uncancelr = arr Left
72 ga_cancell = arr unVoidLeft
74 unVoidLeft (Left v) = voidImpossible v
75 unVoidRight (Right x) = x
76 ga_cancelr = arr unVoidRight
78 unVoidRight (Left x) = x
79 unVoidRight (Right v) = voidImpossible v
80 ga_assoc = arr eitherAssoc
82 eitherAssoc (Left (Left x)) = Left x
83 eitherAssoc (Left (Right y)) = Right (Left y)
84 eitherAssoc (Right z ) = Right (Right z)
85 ga_unassoc = arr eitherUnAssoc
87 eitherUnAssoc (Left x ) = Left (Left x)
88 eitherUnAssoc (Right (Left y)) = Left (Right y)
89 eitherUnAssoc (Right (Right z)) = Right z
91 instance ArrowChoice a => GArrowSum a Either Void where
92 ga_never = arr voidImpossible