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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Data.Functor.Sum
-- Copyright : (c) Ross Paterson 2014
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : R.Paterson@city.ac.uk
-- Stability : experimental
-- Portability : portable
--
-- Sums, lifted to functors.
-----------------------------------------------------------------------------
module Data.Functor.Sum (
Sum(..),
) where
import Control.Applicative
#if __GLASGOW_HASKELL__ >= 708
import Data.Data
#endif
import Data.Foldable (Foldable(foldMap))
import Data.Functor.Classes
#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif
import Data.Monoid (mappend)
import Data.Traversable (Traversable(traverse))
#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics
#endif
-- | Lifted sum of functors.
data Sum f g a = InL (f a) | InR (g a)
#if __GLASGOW_HASKELL__ >= 702
deriving instance Generic (Sum f g a)
instance Generic1 (Sum f g) where
type Rep1 (Sum f g) =
D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f))
:+: C1 MCInR (S1 NoSelector (Rec1 g)))
from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f))))
from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g))))
to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f)
to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g)
data MDSum
data MCInL
data MCInR
instance Datatype MDSum where
datatypeName _ = "Sum"
moduleName _ = "Data.Functor.Sum"
instance Constructor MCInL where
conName _ = "InL"
instance Constructor MCInR where
conName _ = "InR"
#endif
#if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable Sum
deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)
=> Data (Sum (f :: * -> *) (g :: * -> *) (a :: *))
#endif
instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where
liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2
liftEq _ (InL _) (InR _) = False
liftEq _ (InR _) (InL _) = False
liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2
instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where
liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2
liftCompare _ (InL _) (InR _) = LT
liftCompare _ (InR _) (InL _) = GT
liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2
instance (Read1 f, Read1 g) => Read1 (Sum f g) where
liftReadsPrec rp rl = readsData $
readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend`
readsUnaryWith (liftReadsPrec rp rl) "InR" InR
instance (Show1 f, Show1 g) => Show1 (Sum f g) where
liftShowsPrec sp sl d (InL x) =
showsUnaryWith (liftShowsPrec sp sl) "InL" d x
liftShowsPrec sp sl d (InR y) =
showsUnaryWith (liftShowsPrec sp sl) "InR" d y
instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where
(==) = eq1
instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where
compare = compare1
instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where
readsPrec = readsPrec1
instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where
showsPrec = showsPrec1
instance (Functor f, Functor g) => Functor (Sum f g) where
fmap f (InL x) = InL (fmap f x)
fmap f (InR y) = InR (fmap f y)
instance (Foldable f, Foldable g) => Foldable (Sum f g) where
foldMap f (InL x) = foldMap f x
foldMap f (InR y) = foldMap f y
instance (Traversable f, Traversable g) => Traversable (Sum f g) where
traverse f (InL x) = InL <$> traverse f x
traverse f (InR y) = InR <$> traverse f y
#if MIN_VERSION_base(4,12,0)
instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where
contramap f (InL xs) = InL (contramap f xs)
contramap f (InR ys) = InR (contramap f ys)
#endif
|
