1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE TypeOperators #-} 4#if __GLASGOW_HASKELL__ >= 704 5{-# LANGUAGE Safe #-} 6#elif __GLASGOW_HASKELL__ >= 702 7{-# LANGUAGE Trustworthy #-} 8#endif 9#if MIN_VERSION_base(4,7,0) 10{-# LANGUAGE EmptyCase #-} 11#endif 12 13----------------------------------------------------------------------------- 14-- | 15-- Copyright : (C) 2021 Edward Kmett 16-- License : BSD-style (see the file LICENSE) 17-- 18-- Maintainer : Edward Kmett <ekmett@gmail.com> 19-- Stability : provisional 20-- Portability : portable 21-- 22---------------------------------------------------------------------------- 23module Data.Functor.Contravariant.Decide ( 24 Decide(..) 25 , decided 26 ) where 27 28import Control.Applicative.Backwards 29import Control.Monad.Trans.Identity 30import Control.Monad.Trans.Maybe 31import qualified Control.Monad.Trans.RWS.Lazy as Lazy 32import qualified Control.Monad.Trans.RWS.Strict as Strict 33import Control.Monad.Trans.Reader 34import qualified Control.Monad.Trans.State.Lazy as Lazy 35import qualified Control.Monad.Trans.State.Strict as Strict 36import qualified Control.Monad.Trans.Writer.Lazy as Lazy 37import qualified Control.Monad.Trans.Writer.Strict as Strict 38 39import Data.Functor.Apply 40import Data.Functor.Compose 41import Data.Functor.Contravariant 42import Data.Functor.Contravariant.Divise 43import Data.Functor.Contravariant.Divisible 44import Data.Functor.Product 45import Data.Functor.Reverse 46 47#if !(MIN_VERSION_transformers(0,6,0)) 48import Control.Arrow 49import Control.Monad.Trans.List 50import Data.Either 51#endif 52 53#if MIN_VERSION_base(4,8,0) 54import Data.Monoid (Alt(..)) 55#endif 56 57#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) 58import Data.Proxy 59#endif 60 61#ifdef MIN_VERSION_StateVar 62import Data.StateVar 63#endif 64 65#if __GLASGOW_HASKELL__ >= 702 66#define GHC_GENERICS 67import GHC.Generics 68#endif 69 70-- | The contravariant analogue of 'Alt'. 71-- 72-- If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one 73-- to handle the consumption of a value by choosing to handle it via 74-- exactly one of two independent consumers. It redirects the input 75-- completely into one of two consumers. 76-- 77-- 'decide' takes the \"decision\" method and the two potential consumers, 78-- and returns the wrapped/combined consumer. 79-- 80-- Mathematically, a functor being an instance of 'Decide' means that it is 81-- \"semigroupoidal\" with respect to the contravariant \"either-based\" Day 82-- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@). 83-- That is, it is possible to define a function @(f `EitherDay` f) a -> 84-- f a@ in a way that is associative. 85-- 86-- @since 5.3.6 87class Contravariant f => Decide f where 88 -- | Takes the \"decision\" method and the two potential consumers, and 89 -- returns the wrapped/combined consumer. 90 decide :: (a -> Either b c) -> f b -> f c -> f a 91 92-- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct 93-- 'Left's to be consumed by @x@, and 'Right's to be consumed by y. 94-- 95-- @since 5.3.6 96decided :: Decide f => f b -> f c -> f (Either b c) 97decided = decide id 98 99-- | @since 5.3.6 100instance Decidable f => Decide (WrappedDivisible f) where 101 decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y) 102 103-- | @since 5.3.6 104instance Decide Comparison where decide = choose 105 106-- | @since 5.3.6 107instance Decide Equivalence where decide = choose 108 109-- | @since 5.3.6 110instance Decide Predicate where decide = choose 111 112-- | Unlike 'Decidable', requires no constraint on @r@. 113-- 114-- @since 5.3.6 115instance Decide (Op r) where 116 decide f (Op g) (Op h) = Op $ either g h . f 117 118#if MIN_VERSION_base(4,8,0) 119-- | @since 5.3.6 120instance Decide f => Decide (Alt f) where 121 decide f (Alt l) (Alt r) = Alt $ decide f l r 122#endif 123 124#ifdef GHC_GENERICS 125-- | @since 5.3.6 126instance Decide U1 where decide = choose 127 128-- | Has no 'Decidable' or 'Conclude' instance. 129-- 130-- @since 5.3.6 131#if MIN_VERSION_base(4,7,0) 132instance Decide V1 where decide _ x = case x of {} 133#else 134instance Decide V1 where decide _ x = case x of !_ -> error "V1" 135#endif 136 137-- | @since 5.3.6 138instance Decide f => Decide (Rec1 f) where 139 decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r 140 141-- | @since 5.3.6 142instance Decide f => Decide (M1 i c f) where 143 decide f (M1 l) (M1 r) = M1 $ decide f l r 144 145-- | @since 5.3.6 146instance (Decide f, Decide g) => Decide (f :*: g) where 147 decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2 148 149-- | Unlike 'Decidable', requires only 'Apply' on @f@. 150-- 151-- @since 5.3.6 152instance (Apply f, Decide g) => Decide (f :.: g) where 153 decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r) 154#endif 155 156-- | @since 5.3.6 157instance Decide f => Decide (Backwards f) where 158 decide f (Backwards l) (Backwards r) = Backwards $ decide f l r 159 160-- | @since 5.3.6 161instance Decide f => Decide (IdentityT f) where 162 decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r 163 164-- | @since 5.3.6 165instance Decide m => Decide (ReaderT r m) where 166 decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r) 167 168-- | @since 5.3.6 169instance Decide m => Decide (Lazy.RWST r w s m) where 170 decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s -> 171 decide (\ ~(a, s', w) -> either (Left . betuple3 s' w) 172 (Right . betuple3 s' w) 173 (abc a)) 174 (rsmb r s) (rsmc r s) 175 176-- | @since 5.3.6 177instance Decide m => Decide (Strict.RWST r w s m) where 178 decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s -> 179 decide (\(a, s', w) -> either (Left . betuple3 s' w) 180 (Right . betuple3 s' w) 181 (abc a)) 182 (rsmb r s) (rsmc r s) 183 184#if !(MIN_VERSION_transformers(0,6,0)) 185-- | @since 5.3.6 186instance Divise m => Decide (ListT m) where 187 decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r 188#endif 189 190-- | @since 5.3.6 191instance Divise m => Decide (MaybeT m) where 192 decide f (MaybeT l) (MaybeT r) = MaybeT $ 193 divise ( maybe (Nothing, Nothing) 194 (either (\b -> (Just b, Nothing)) 195 (\c -> (Nothing, Just c)) . f) 196 ) l r 197 198-- | @since 5.3.6 199instance Decide m => Decide (Lazy.StateT s m) where 200 decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s -> 201 decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) 202 (l s) (r s) 203 204-- | @since 5.3.6 205instance Decide m => Decide (Strict.StateT s m) where 206 decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s -> 207 decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) 208 (l s) (r s) 209 210-- | @since 5.3.6 211instance Decide m => Decide (Lazy.WriterT w m) where 212 decide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $ 213 decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r 214 215-- | @since 5.3.6 216instance Decide m => Decide (Strict.WriterT w m) where 217 decide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $ 218 decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r 219 220-- | Unlike 'Decidable', requires only 'Apply' on @f@. 221-- 222-- @since 5.3.6 223instance (Apply f, Decide g) => Decide (Compose f g) where 224 decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r) 225 226-- | @since 5.3.6 227instance (Decide f, Decide g) => Decide (Product f g) where 228 decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2) 229 230-- | @since 5.3.6 231instance Decide f => Decide (Reverse f) where 232 decide f (Reverse l) (Reverse r) = Reverse $ decide f l r 233 234betuple :: s -> a -> (a, s) 235betuple s a = (a, s) 236 237betuple3 :: s -> w -> a -> (a, s, w) 238betuple3 s w a = (a, s, w) 239 240#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged) 241-- | @since 5.3.6 242instance Decide Proxy where 243 decide _ Proxy Proxy = Proxy 244#endif 245 246#ifdef MIN_VERSION_StateVar 247-- | @since 5.3.6 248instance Decide SettableStateVar where 249 decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of 250 Left b -> l b 251 Right c -> r c 252#endif 253