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