/
Coproduct.purs
91 lines (72 loc) · 3.15 KB
/
Coproduct.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
module Data.Functor.Coproduct where
import Prelude
import Control.Extend (class Extend, extend)
import Control.Comonad (class Comonad, extract)
import Data.Bifunctor (bimap)
import Data.Either (Either(..))
import Data.Eq (class Eq1, eq1)
import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.Newtype (class Newtype)
import Data.Ord (class Ord1, compare1)
import Data.Traversable (class Traversable, traverse, sequence)
-- | `Coproduct f g` is the coproduct of two functors `f` and `g`
newtype Coproduct f g a = Coproduct (Either (f a) (g a))
-- | Left injection
left :: forall f g a. f a -> Coproduct f g a
left fa = Coproduct (Left fa)
-- | Right injection
right :: forall f g a. g a -> Coproduct f g a
right ga = Coproduct (Right ga)
-- | Eliminate a coproduct by providing eliminators for the left and
-- | right components
coproduct :: forall f g a b. (f a -> b) -> (g a -> b) -> Coproduct f g a -> b
coproduct f _ (Coproduct (Left a)) = f a
coproduct _ g (Coproduct (Right b)) = g b
-- | Change the underlying functors in a coproduct
bihoistCoproduct
:: forall f g h i
. (f ~> h)
-> (g ~> i)
-> Coproduct f g
~> Coproduct h i
bihoistCoproduct natF natG (Coproduct e) = Coproduct (bimap natF natG e)
derive instance newtypeCoproduct :: Newtype (Coproduct f g a) _
instance eqCoproduct :: (Eq1 f, Eq1 g, Eq a) => Eq (Coproduct f g a) where
eq = eq1
instance eq1Coproduct :: (Eq1 f, Eq1 g) => Eq1 (Coproduct f g) where
eq1 (Coproduct x) (Coproduct y) =
case x, y of
Left fa, Left ga -> eq1 fa ga
Right fa, Right ga -> eq1 fa ga
_, _ -> false
instance ordCoproduct :: (Ord1 f, Ord1 g, Ord a) => Ord (Coproduct f g a) where
compare = compare1
instance ord1Coproduct :: (Ord1 f, Ord1 g) => Ord1 (Coproduct f g) where
compare1 (Coproduct x) (Coproduct y) =
case x, y of
Left fa, Left ga -> compare1 fa ga
Left _, _ -> LT
_, Left _ -> GT
Right fa, Right ga -> compare1 fa ga
instance showCoproduct :: (Show (f a), Show (g a)) => Show (Coproduct f g a) where
show (Coproduct (Left fa)) = "(left " <> show fa <> ")"
show (Coproduct (Right ga)) = "(right " <> show ga <> ")"
instance functorCoproduct :: (Functor f, Functor g) => Functor (Coproduct f g) where
map f (Coproduct e) = Coproduct (bimap (map f) (map f) e)
instance extendCoproduct :: (Extend f, Extend g) => Extend (Coproduct f g) where
extend f = Coproduct <<< coproduct
(Left <<< extend (f <<< Coproduct <<< Left))
(Right <<< extend (f <<< Coproduct <<< Right))
instance comonadCoproduct :: (Comonad f, Comonad g) => Comonad (Coproduct f g) where
extract = coproduct extract extract
instance foldableCoproduct :: (Foldable f, Foldable g) => Foldable (Coproduct f g) where
foldr f z = coproduct (foldr f z) (foldr f z)
foldl f z = coproduct (foldl f z) (foldl f z)
foldMap f = coproduct (foldMap f) (foldMap f)
instance traversableCoproduct :: (Traversable f, Traversable g) => Traversable (Coproduct f g) where
traverse f = coproduct
(map (Coproduct <<< Left) <<< traverse f)
(map (Coproduct <<< Right) <<< traverse f)
sequence = coproduct
(map (Coproduct <<< Left) <<< sequence)
(map (Coproduct <<< Right) <<< sequence)