1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE Safe #-}
4{-# LANGUAGE DeriveGeneric      #-}
5#ifndef __HADDOCK__
6#ifdef __GLASGOW_HASKELL__
7{-# LANGUAGE TypeOperators      #-}
8#endif
9#endif
10
11#if MIN_VERSION_base(4,9,0)
12#define LIFTED_FUNCTOR_CLASSES 1
13#else
14#if MIN_VERSION_transformers(0,5,0)
15#define LIFTED_FUNCTOR_CLASSES 1
16#else
17#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)
18#define LIFTED_FUNCTOR_CLASSES 1
19#endif
20#endif
21#endif
22
23-----------------------------------------------------------------------------
24-- |
25--
26-- The strict variant of the standard Haskell pairs and the corresponding
27-- variants of the functions from "Data.Tuple".
28--
29-- Note that unlike regular Haskell pairs, @(x :*: _|_) = (_|_ :*: y) = _|_@
30--
31-----------------------------------------------------------------------------
32
33module Data.Strict.Tuple (
34    Pair(..)
35#ifndef __HADDOCK__
36#ifdef __GLASGOW_HASKELL__
37  , (:!:)
38#endif
39#endif
40  , fst
41  , snd
42  , curry
43  , uncurry
44  , Data.Strict.Tuple.swap -- disambiguate
45  , zip
46  , unzip
47) where
48
49-- import parts explicitly, helps with compatibility
50import           Prelude (Functor (..), Eq (..), Ord (..), Show (..), Read (..), (.), Bounded, map, ($)
51                         , (&&), showParen, showString, readParen, lex, return)
52import           Control.Applicative ((<$>), (<*>))
53import           Data.Monoid (Monoid (..))
54import           Data.Semigroup (Semigroup (..))
55import           Data.Foldable (Foldable (..))
56import           Data.Traversable (Traversable (..))
57
58-- Lazy variants
59import qualified Prelude             as L
60
61import           Control.DeepSeq     (NFData (..))
62import           Data.Bifoldable     (Bifoldable (..))
63import           Data.Bifunctor      (Bifunctor (..))
64import           Data.Binary         (Binary (..))
65import           Data.Bitraversable  (Bitraversable (..))
66import           Data.Hashable       (Hashable(..))
67import           Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..))
68import           Data.Ix             (Ix (..))
69import           GHC.Generics        (Generic)
70import           Data.Data           (Data (..), Typeable)
71
72#if __GLASGOW_HASKELL__ >= 706
73import           GHC.Generics        (Generic1)
74#endif
75
76#if MIN_VERSION_deepseq(1,4,3)
77import Control.DeepSeq (NFData1 (..), NFData2 (..))
78#endif
79
80#ifdef MIN_VERSION_assoc
81import           Data.Bifunctor.Assoc (Assoc (..))
82import           Data.Bifunctor.Swap  (Swap (..))
83#endif
84
85#ifdef LIFTED_FUNCTOR_CLASSES
86import Data.Functor.Classes
87       (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Read1 (..), Read2 (..),
88       Show1 (..), Show2 (..))
89#else
90import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..))
91#endif
92
93#if __HADDOCK__
94import Data.Tuple ()
95#endif
96
97-- $setup
98-- >>> import Prelude (Char, String)
99-- >>> import Data.Functor.Classes (readsPrec2)
100
101infix 2 :!:
102
103-- | The type of strict pairs.
104data Pair a b = !a :!: !b
105  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Bounded, Ix
106#if __GLASGOW_HASKELL__ >= 706
107    , Generic1
108#endif
109    )
110
111#ifndef __HADDOCK__
112#ifdef __GLASGOW_HASKELL__
113-- This gives a nicer syntax for the type but only works in GHC for now.
114type (:!:) = Pair
115#endif
116#endif
117
118toStrict :: (a, b) -> Pair a b
119toStrict (a, b) = a :!: b
120
121toLazy :: Pair a b -> (a, b)
122toLazy (a :!: b) = (a, b)
123
124-- | Extract the first component of a strict pair.
125fst :: Pair a b -> a
126fst (x :!: _) = x
127
128-- | Extract the second component of a strict pair.
129snd :: Pair a b -> b
130snd (_ :!: y) = y
131
132-- | Curry a function on strict pairs.
133curry :: (Pair a b -> c) -> a -> b -> c
134curry f x y = f (x :!: y)
135
136-- | Convert a curried function to a function on strict pairs.
137uncurry :: (a -> b -> c) -> Pair a b -> c
138uncurry f (x :!: y) = f x y
139
140-- | Analagous to 'L.swap' from "Data.Tuple"
141swap :: Pair a b -> Pair b a
142swap (a :!: b) = b :!: a
143
144-- | Zip for strict pairs (defined with zipWith).
145zip :: [a] -> [b] -> [Pair a b]
146zip x y = L.zipWith (:!:) x y
147
148-- | Unzip for stict pairs into a (lazy) pair of lists.
149unzip :: [Pair a b] -> ([a], [b])
150unzip x = ( map fst x
151          , map snd x
152          )
153
154-- Instances
155------------
156
157instance Functor (Pair e) where
158    fmap f = toStrict . fmap f . toLazy
159
160instance Foldable (Pair e) where
161  foldMap f (_ :!: x) = f x
162
163instance Traversable (Pair e) where
164  traverse f (e :!: x) = (:!:) e <$> f x
165
166instance (Semigroup a, Semigroup b) => Semigroup (Pair a b) where
167  (x1 :!: y1) <> (x2 :!: y2) = (x1 <> x2) :!: (y1 <> y2)
168
169instance (Monoid a, Monoid b) => Monoid (Pair a b) where
170  mempty                            = mempty :!: mempty
171  (x1 :!: y1) `mappend` (x2 :!: y2) = (x1 `mappend` x2) :!: (y1 `mappend` y2)
172
173-- deepseq
174instance (NFData a, NFData b) => NFData (Pair a b) where
175  rnf = rnf . toLazy
176
177#if MIN_VERSION_deepseq(1,4,3)
178instance (NFData a) => NFData1 (Pair a) where
179  liftRnf rnfA = liftRnf rnfA . toLazy
180
181instance NFData2 Pair where
182  liftRnf2 rnfA rnfB = liftRnf2 rnfA rnfB . toLazy
183#endif
184
185-- binary
186instance (Binary a, Binary b) => Binary (Pair a b) where
187  put = put . toLazy
188  get = toStrict <$> get
189
190-- bifunctors
191instance Bifunctor Pair where
192  bimap f g (a :!: b) = f a :!: g b
193  first f (a :!: b) = f a :!: b
194  second g (a :!: b) = a :!: g b
195
196instance Bifoldable Pair where
197  bifold (a :!: b) = a `mappend` b
198  bifoldMap f g (a :!: b) = f a `mappend` g b
199  bifoldr f g c (a :!: b) = g b (f a c)
200  bifoldl f g c (a :!: b) = g (f c a) b
201
202instance Bitraversable Pair where
203  bitraverse f g (a :!: b) = (:!:) <$> f a <*> g b
204
205-- hashable
206instance (Hashable a, Hashable b) => Hashable (Pair a b) where
207  hashWithSalt salt = hashWithSalt salt . toLazy
208
209instance (Hashable a) => Hashable1 (Pair a) where
210  liftHashWithSalt hashA salt = liftHashWithSalt hashA salt . toLazy
211
212instance Hashable2 Pair where
213  liftHashWithSalt2 hashA hashB salt = liftHashWithSalt2 hashA hashB salt . toLazy
214
215-- assoc
216#ifdef MIN_VERSION_assoc
217instance Assoc Pair where
218    assoc ((a :!: b) :!: c) = (a :!: (b :!: c))
219    unassoc (a :!: (b :!: c)) = ((a :!: b) :!: c)
220
221instance Swap Pair where
222    swap = Data.Strict.Tuple.swap
223#endif
224
225-- Data.Functor.Classes
226#ifdef LIFTED_FUNCTOR_CLASSES
227instance Eq2 Pair where
228  liftEq2 f g (a :!: b) (a' :!: b')  = f a a' && g b b'
229
230instance Eq a => Eq1 (Pair a) where
231  liftEq = liftEq2 (==)
232
233instance Ord2 Pair where
234  liftCompare2 f g (a :!: b) (a' :!: b') = f a a' `mappend` g b b'
235
236instance Ord a => Ord1 (Pair a) where
237  liftCompare = liftCompare2 compare
238
239instance Show a => Show1 (Pair a) where
240  liftShowsPrec = liftShowsPrec2 showsPrec showList
241
242instance Show2 Pair where
243  liftShowsPrec2 sa _ sb _ d (a :!: b) = showParen (d > 3)
244    -- prints extra parens
245    $ sa 3 a
246    . showString " :!: "
247    . sb 3 b
248
249-- |
250--
251-- >>> readsPrec2 0 "'a' :!: ('b' :!: 'c')" :: [(Pair Char (Pair Char Char), String)]
252-- [('a' :!: ('b' :!: 'c'),"")]
253--
254-- >>> readsPrec2 0 "('a' :!: 'b') :!: 'c'" :: [(Pair (Pair Char Char) Char, String)]
255-- [(('a' :!: 'b') :!: 'c',"")]
256--
257instance Read2 Pair where
258  liftReadsPrec2 ra _ rb _ d = readParen (d > 3) $ \s -> cons s where
259    cons s0 = do
260      (a,     s1) <- ra 3 s0
261      (":!:", s2) <- lex s1
262      (b,     s3) <- rb 3 s2
263      return (a :!: b, s3)
264
265
266instance Read a => Read1 (Pair a) where
267  liftReadsPrec = liftReadsPrec2 readsPrec readList
268#else
269instance Eq a   => Eq1   (Pair a) where eq1        = (==)
270instance Ord a  => Ord1  (Pair a) where compare1   = compare
271instance Show a => Show1 (Pair a) where showsPrec1 = showsPrec
272instance Read a => Read1 (Pair a) where readsPrec1 = readsPrec
273#endif
274