1{-# LANGUAGE CPP                        #-}
2{-# LANGUAGE EmptyDataDecls             #-}
3{-# LANGUAGE FlexibleContexts           #-}
4{-# LANGUAGE DeriveTraversable          #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE ScopedTypeVariables        #-}
7{-# LANGUAGE TypeFamilies               #-}
8
9#if __GLASGOW_HASKELL__ >= 702
10{-# LANGUAGE DeriveGeneric              #-}
11#endif
12
13#include "bifunctors-common.h"
14#ifndef MIN_VERSION_semigroups
15#define MIN_VERSION_semigroups(x,y,z) 0
16#endif
17
18-----------------------------------------------------------------------------
19-- |
20-- Copyright   :  (C) 2008-2016 Edward Kmett
21-- License     :  BSD-style (see the file LICENSE)
22--
23-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
24-- Stability   :  provisional
25-- Portability :  portable
26--
27----------------------------------------------------------------------------
28module Data.Bifunctor.Biap
29 ( Biap(..)
30 ) where
31
32import Control.Applicative
33import Control.Monad
34import qualified Control.Monad.Fail as Fail (MonadFail)
35import Data.Biapplicative
36import Data.Bifoldable
37import Data.Bitraversable
38import Data.Functor.Classes
39
40#if __GLASGOW_HASKELL__ >= 702
41import GHC.Generics
42#endif
43
44#if !(MIN_VERSION_base(4,8,0))
45import Data.Foldable
46import Data.Monoid
47import Data.Traversable
48#endif
49
50#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2)
51import qualified Data.Semigroup as S
52#endif
53
54-- | Pointwise lifting of a class over two arguments, using
55-- 'Biapplicative'.
56--
57-- Classes that can be lifted include 'Monoid', 'Num' and
58-- 'Bounded'. Each method of those classes can be defined as lifting
59-- themselves over each argument of 'Biapplicative'.
60--
61-- @
62-- mempty        = bipure mempty          mempty
63-- minBound      = bipure minBound        minBound
64-- maxBound      = bipure maxBound        maxBound
65-- fromInteger n = bipure (fromInteger n) (fromInteger n)
66--
67-- negate = bimap negate negate
68--
69-- (+)  = biliftA2 (+)  (+)
70-- (<>) = biliftA2 (<>) (<>)
71-- @
72--
73-- 'Biap' is to 'Biapplicative' as 'Data.Monoid.Ap' is to
74-- 'Applicative'.
75--
76-- 'Biap' can be used with @DerivingVia@ to derive a numeric instance
77-- for pairs:
78--
79-- @
80-- newtype Numpair a = Np (a, a)
81--  deriving (S.Semigroup, Monoid, Num, Bounded)
82--  via Biap (,) a a
83-- @
84--
85newtype Biap bi a b = Biap { getBiap :: bi a b }
86 deriving ( Eq
87          , Ord
88          , Show
89          , Read
90          , Enum
91          , Functor
92          , Foldable
93          , Traversable
94          , Alternative
95          , Applicative
96#if __GLASGOW_HASKELL__ >= 702
97          , Generic
98#endif
99#if __GLASGOW_HASKELL__ >= 706
100          , Generic1
101#endif
102          , Monad
103          , Fail.MonadFail
104          , MonadPlus
105          , Eq1
106          , Ord1
107
108          , Bifunctor
109          , Biapplicative
110          , Bifoldable
111#if LIFTED_FUNCTOR_CLASSES
112          , Eq2
113          , Ord2
114#endif
115          )
116
117instance Bitraversable bi => Bitraversable (Biap bi) where
118 bitraverse f g (Biap as) = Biap <$> bitraverse f g as
119
120instance (Biapplicative bi, S.Semigroup a, S.Semigroup b) => S.Semigroup (Biap bi a b) where
121  (<>) = biliftA2 (S.<>) (S.<>)
122
123instance (Biapplicative bi, Monoid a, Monoid b) => Monoid (Biap bi a b) where
124  mempty = bipure mempty mempty
125#if !(MIN_VERSION_base(4,11,0))
126  mappend = biliftA2 mappend mappend
127#endif
128
129instance (Biapplicative bi, Bounded a, Bounded b) => Bounded (Biap bi a b) where
130  minBound = bipure minBound minBound
131  maxBound = bipure maxBound maxBound
132
133instance ( Biapplicative bi, Num a, Num b
134#if !(MIN_VERSION_base(4,5,0))
135           -- Old versions of Num have Eq and Show as superclasses. Sigh.
136         , Eq (bi a b), Show (bi a b)
137#endif
138         ) => Num (Biap bi a b) where
139  (+) = biliftA2 (+) (+)
140  (*) = biliftA2 (*) (*)
141
142  negate = bimap negate negate
143  abs    = bimap abs    abs
144  signum = bimap signum signum
145
146  fromInteger n = bipure (fromInteger n) (fromInteger n)
147
148#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706
149data BiapMetaData
150data BiapMetaCons
151data BiapMetaSel
152
153instance Datatype BiapMetaData where
154    datatypeName = const "Biap"
155    moduleName = const "Data.Bifunctor.Wrapped"
156
157instance Constructor BiapMetaCons where
158    conName = const "Biap"
159    conIsRecord = const True
160
161instance Selector BiapMetaSel where
162    selName = const "getBiap"
163
164instance Generic1 (Biap p a) where
165    type Rep1 (Biap p a) = D1 BiapMetaData
166        (C1 BiapMetaCons
167            (S1 BiapMetaSel (Rec1 (p a))))
168    from1 = M1 . M1 . M1 . Rec1 . getBiap
169    to1 = Biap . unRec1 . unM1 . unM1 . unM1
170#endif
171