contravariant 1.3.3 → 1.4

raw patch · 4 files changed

+336/−16 lines, 4 filesdep ~basedep ~transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +6/−0
• contravariant.cabal +10/−2
• src/Data/Functor/Contravariant/Divisible.hs +280/−7
• src/Data/Functor/Contravariant/Generic.hs +40/−7

@@ -1,3 +1,9 @@+1.4+---+* Improved the performance of `Deciding` at the cost of downgrading it to `Trustworthy`.+* Support for GHC 8+* Support for `transformers` 0.5+ 1.3.3 ----- * Add `instance Monoid m => Divisible (Const m)`

@@ -1,6 +1,6 @@ name:          contravariant category:      Control, Data-version:       1.3.3+version:       1.4 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -38,6 +38,11 @@   default: True   manual: True +flag safe+  description: Get Safe guarantees rather than merely Trustworthy, but with worse constant factors.+  default: False+  manual: True+ flag StateVar   description:     You can disable the use of the `StateVar` package using `-f-StateVar`.@@ -50,7 +55,7 @@   hs-source-dirs: src   build-depends:     base                              < 5,-    transformers        >= 0.2 &&     < 0.5,+    transformers        >= 0.2 &&     < 0.6,     transformers-compat >= 0.3 &&     < 1,     void                >= 0.6 &&     < 1 @@ -65,6 +70,9 @@    if impl(ghc >= 7.2 && < 7.6)     build-depends: ghc-prim++  if flag(safe)+    cpp-options: -DSAFE    exposed-modules:     Data.Functor.Contravariant

@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Functor.Contravariant.Divisible@@ -20,18 +23,48 @@   ) where  import Control.Applicative+import Control.Applicative.Backwards+import Control.Arrow+import Control.Monad.Trans.Error+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Either+import Data.Functor.Compose+import Data.Functor.Constant import Data.Functor.Contravariant+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Void -#if __GLASGOW_HASKELL__ < 710-import Data.Monoid+#if MIN_VERSION_base(4,8,0)+import Data.Monoid (Alt(..))+#else+import Data.Monoid (Monoid(..)) #endif -import Data.Void+#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+import Data.Proxy+#endif  #if MIN_VERSION_StateVar import Data.StateVar #endif +#if __GLASGOW_HASKELL__ >= 702+#define GHC_GENERICS+import GHC.Generics+#endif+ -------------------------------------------------------------------------------- -- * Contravariant Applicative --------------------------------------------------------------------------------@@ -53,7 +86,7 @@ -- @ -- delta a = (a,a) -- @--- +-- -- @'divide' 'delta'@ should be associative with 'conquer' as a unit -- -- @@@ -94,7 +127,7 @@ -- | Redundant, but provided for symmetry. -- -- @--- 'conquered' = 'conquer+-- 'conquered' = 'conquer' -- @ conquered :: Divisible f => f () conquered = conquer@@ -108,7 +141,7 @@ -- @ liftD :: Divisible f => (a -> b) -> f b -> f a liftD f = divide ((,) () . f) conquer-  + instance Monoid r => Divisible (Op r) where   divide f (Op g) (Op h) = Op $ \a -> case f a of     (b, c) -> g b `mappend` h c@@ -135,6 +168,118 @@   divide _ (Const a) (Const b) = Const (mappend a b)   conquer = Const mempty +#if MIN_VERSION_base(4,8,0)+instance Divisible f => Divisible (Alt f) where+  divide f (Alt l) (Alt r) = Alt $ divide f l r+  conquer = Alt conquer+#endif++#ifdef GHC_GENERICS+instance Divisible U1 where+  divide _ U1 U1 = U1+  conquer = U1++instance Divisible f => Divisible (Rec1 f) where+  divide f (Rec1 l) (Rec1 r) = Rec1 $ divide f l r+  conquer = Rec1 conquer++instance Divisible f => Divisible (M1 i c f) where+  divide f (M1 l) (M1 r) = M1 $ divide f l r+  conquer = M1 conquer++instance (Divisible f, Divisible g) => Divisible (f :*: g) where+  divide f (l1 :*: r1) (l2 :*: r2) = divide f l1 l2 :*: divide f r1 r2+  conquer = conquer :*: conquer++instance (Applicative f, Divisible g) => Divisible (f :.: g) where+  divide f (Comp1 l) (Comp1 r) = Comp1 (divide f <$> l <*> r)+  conquer = Comp1 $ pure conquer+#endif++instance Divisible f => Divisible (Backwards f) where+  divide f (Backwards l) (Backwards r) = Backwards $ divide f l r+  conquer = Backwards conquer++instance Divisible m => Divisible (ErrorT e m) where+  divide f (ErrorT l) (ErrorT r) = ErrorT $ divide (funzip . fmap f) l r+  conquer = ErrorT conquer++instance Divisible m => Divisible (ExceptT e m) where+  divide f (ExceptT l) (ExceptT r) = ExceptT $ divide (funzip . fmap f) l r+  conquer = ExceptT conquer++instance Divisible f => Divisible (IdentityT f) where+  divide f (IdentityT l) (IdentityT r) = IdentityT $ divide f l r+  conquer = IdentityT conquer++instance Divisible m => Divisible (ListT m) where+  divide f (ListT l) (ListT r) = ListT $ divide (funzip . map f) l r+  conquer = ListT conquer++instance Divisible m => Divisible (MaybeT m) where+  divide f (MaybeT l) (MaybeT r) = MaybeT $ divide (funzip . fmap f) l r+  conquer = MaybeT conquer++instance Divisible m => Divisible (ReaderT r m) where+  divide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divide abc (rmb r) (rmc r)+  conquer = ReaderT $ \_ -> conquer++instance Divisible m => Divisible (Lazy.RWST r w s m) where+  divide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->+    divide (\ ~(a, s', w) -> case abc a of+                                  ~(b, c) -> ((b, s', w), (c, s', w)))+           (rsmb r s) (rsmc r s)+  conquer = Lazy.RWST $ \_ _ -> conquer++instance Divisible m => Divisible (Strict.RWST r w s m) where+  divide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->+    divide (\(a, s', w) -> case abc a of+                                (b, c) -> ((b, s', w), (c, s', w)))+           (rsmb r s) (rsmc r s)+  conquer = Strict.RWST $ \_ _ -> conquer++instance Divisible m => Divisible (Lazy.StateT s m) where+  divide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->+    divide (lazyFanout f) (l s) (r s)+  conquer = Lazy.StateT $ \_ -> conquer++instance Divisible m => Divisible (Strict.StateT s m) where+  divide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->+    divide (strictFanout f) (l s) (r s)+  conquer = Strict.StateT $ \_ -> conquer++instance Divisible m => Divisible (Lazy.WriterT w m) where+  divide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $+    divide (lazyFanout f) l r+  conquer = Lazy.WriterT conquer++instance Divisible m => Divisible (Strict.WriterT w m) where+  divide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $+    divide (strictFanout f) l r+  conquer = Strict.WriterT conquer++instance (Applicative f, Divisible g) => Divisible (Compose f g) where+  divide f (Compose l) (Compose r) = Compose (divide f <$> l <*> r)+  conquer = Compose $ pure conquer++instance Monoid m => Divisible (Constant m) where+  divide _ (Constant l) (Constant r) = Constant $ mappend l r+  conquer = Constant mempty++instance (Divisible f, Divisible g) => Divisible (Product f g) where+  divide f (Pair l1 r1) (Pair l2 r2) = Pair (divide f l1 l2) (divide f r1 r2)+  conquer = Pair conquer conquer++instance Divisible f => Divisible (Reverse f) where+  divide f (Reverse l) (Reverse r) = Reverse $ divide f l r+  conquer = Reverse conquer++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+instance Divisible Proxy where+  divide _ Proxy Proxy = Proxy+  conquer = Proxy+#endif+ #if MIN_VERSION_StateVar instance Divisible SettableStateVar where   divide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of@@ -142,13 +287,24 @@   conquer = SettableStateVar $ \_ -> return () #endif +lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))+lazyFanout f ~(a, s) = case f a of+  ~(b, c) -> ((b, s), (c, s))++strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))+strictFanout f (a, s) = case f a of+  (b, c) -> ((b, s), (c, s))++funzip :: Functor f => f (a, b) -> (f a, f b)+funzip = fmap fst &&& fmap snd+ -------------------------------------------------------------------------------- -- * Contravariant Alternative --------------------------------------------------------------------------------  -- | ----- A 'Divisible' contravariant functor is a monoid object in the category of presheaves +-- A 'Divisible' contravariant functor is a monoid object in the category of presheaves -- from Hask to Hask, equipped with Day convolution mapping the cartesian product of the -- source to the Cartesian product of the target. --@@ -209,6 +365,123 @@ instance Monoid r => Decidable (Op r) where   lose f = Op $ absurd . f   choose f (Op g) (Op h) = Op $ either g h . f++#if MIN_VERSION_base(4,8,0)+instance Decidable f => Decidable (Alt f) where+  lose = Alt . lose+  choose f (Alt l) (Alt r) = Alt $ choose f l r+#endif++#ifdef GHC_GENERICS+instance Decidable U1 where+  lose _ = U1+  choose _ U1 U1 = U1++instance Decidable f => Decidable (Rec1 f) where+  lose = Rec1 . lose+  choose f (Rec1 l) (Rec1 r) = Rec1 $ choose f l r++instance Decidable f => Decidable (M1 i c f) where+  lose = M1 . lose+  choose f (M1 l) (M1 r) = M1 $ choose f l r++instance (Decidable f, Decidable g) => Decidable (f :*: g) where+  lose f = lose f :*: lose f+  choose f (l1 :*: r1) (l2 :*: r2) = choose f l1 l2 :*: choose f r1 r2++instance (Applicative f, Decidable g) => Decidable (f :.: g) where+  lose = Comp1 . pure . lose+  choose f (Comp1 l) (Comp1 r) = Comp1 (choose f <$> l <*> r)+#endif++instance Decidable f => Decidable (Backwards f) where+  lose = Backwards . lose+  choose f (Backwards l) (Backwards r) = Backwards $ choose f l r++instance Decidable f => Decidable (IdentityT f) where+  lose = IdentityT . lose+  choose f (IdentityT l) (IdentityT r) = IdentityT $ choose f l r++instance Decidable m => Decidable (ReaderT r m) where+  lose f = ReaderT $ \_ -> lose f+  choose abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> choose abc (rmb r) (rmc r)++instance Decidable m => Decidable (Lazy.RWST r w s m) where+  lose f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (lose f)+  choose abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->+    choose (\ ~(a, s', w) -> either (Left  . betuple3 s' w)+                                    (Right . betuple3 s' w)+                                    (abc a))+           (rsmb r s) (rsmc r s)++instance Decidable m => Decidable (Strict.RWST r w s m) where+  lose f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (lose f)+  choose abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->+    choose (\(a, s', w) -> either (Left  . betuple3 s' w)+                                  (Right . betuple3 s' w)+                                  (abc a))+           (rsmb r s) (rsmc r s)++instance Divisible m => Decidable (ListT m) where+  lose _ = ListT conquer+  choose f (ListT l) (ListT r) = ListT $ divide ((lefts &&& rights) . map f) l r++instance Divisible m => Decidable (MaybeT m) where+  lose _ = MaybeT conquer+  choose f (MaybeT l) (MaybeT r) = MaybeT $+    divide ( maybe (Nothing, Nothing)+                   (either (\b -> (Just b, Nothing))+                           (\c -> (Nothing, Just c)))+           . fmap f) l r++instance Decidable m => Decidable (Lazy.StateT s m) where+  lose f = Lazy.StateT $ \_ -> contramap lazyFst (lose f)+  choose f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->+    choose (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))+           (l s) (r s)++instance Decidable m => Decidable (Strict.StateT s m) where+  lose f = Strict.StateT $ \_ -> contramap fst (lose f)+  choose f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->+    choose (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))+           (l s) (r s)++instance Decidable m => Decidable (Lazy.WriterT w m) where+  lose f = Lazy.WriterT $ contramap lazyFst (lose f)+  choose f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $+    choose (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r++instance Decidable m => Decidable (Strict.WriterT w m) where+  lose f = Strict.WriterT $ contramap fst (lose f)+  choose f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $+    choose (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r++instance (Applicative f, Decidable g) => Decidable (Compose f g) where+  lose = Compose . pure . lose+  choose f (Compose l) (Compose r) = Compose (choose f <$> l <*> r)++instance (Decidable f, Decidable g) => Decidable (Product f g) where+  lose f = Pair (lose f) (lose f)+  choose f (Pair l1 r1) (Pair l2 r2) = Pair (choose f l1 l2) (choose f r1 r2)++instance Decidable f => Decidable (Reverse f) where+  lose = Reverse . lose+  choose f (Reverse l) (Reverse r) = Reverse $ choose f l r++betuple :: s -> a -> (a, s)+betuple s a = (a, s)++betuple3 :: s -> w -> a -> (a, s, w)+betuple3 s w a = (a, s, w)++lazyFst :: (a, b) -> a+lazyFst ~(a, _) = a++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+instance Decidable Proxy where+  lose _ = Proxy+  choose _ Proxy Proxy = Proxy+#endif  #if MIN_VERSION_StateVar instance Decidable SettableVar where

@@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-}+#ifdef SAFE {-# LANGUAGE BangPatterns #-}+#elif __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Trustworthy #-}+#endif {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-}@@ -32,6 +36,9 @@ import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import GHC.Generics+#ifndef SAFE+import Unsafe.Coerce+#endif  -- | This provides machinery for deconstructing an arbitrary 'Generic' instance using a 'Decidable' 'Contravariant' functor. --@@ -84,13 +91,13 @@   gdeciding _ _ = conquer  instance GDeciding q V1 where-  gdeciding _ _ = lose (\ !_ -> error "impossible")+  gdeciding _ _ = glose  instance (GDeciding q f, GDeciding q g) => GDeciding q (f :*: g) where-  gdeciding p q = divide (\(a :*: b) -> (a, b)) (gdeciding p q) (gdeciding p q)+  gdeciding p q = gdivide (gdeciding p q) (gdeciding p q)  instance (GDeciding q f, GDeciding q g) => GDeciding q (f :+: g) where-  gdeciding p q = choose (\ xs -> case xs of L1 a -> Left a; R1 a -> Right a) (gdeciding p q) (gdeciding p q)+  gdeciding p q = gchoose (gdeciding p q) (gdeciding p q)  #ifndef HLINT instance q p => GDeciding q (K1 i p) where@@ -109,18 +116,44 @@   gdeciding1 _ _ _ = conquer  instance GDeciding1 q V1 where-  gdeciding1 _ _ _ = lose (\ !_ -> error "impossible")+  gdeciding1 _ _ _ = glose  instance (GDeciding1 q f, GDeciding1 q g) => GDeciding1 q (f :*: g) where-  gdeciding1 p q r = divide (\(a :*: b) -> (a, b)) (gdeciding1 p q r) (gdeciding1 p q r)+  gdeciding1 p q r = gdivide (gdeciding1 p q r) (gdeciding1 p q r)  instance (GDeciding1 q f, GDeciding1 q g) => GDeciding1 q (f :+: g) where-  gdeciding1 p q r = choose (\ xs -> case xs of L1 a -> Left a; R1 a -> Right a) (gdeciding1 p q r) (gdeciding1 p q r)+  gdeciding1 p q r = gchoose (gdeciding1 p q r) (gdeciding1 p q r) +++glose :: Decidable f => f (V1 a)+#ifdef SAFE+glose = lose (\ !_ -> error "impossible")+#else+glose = lose unsafeCoerce+#endif+{-# INLINE glose #-}++gdivide :: Divisible f => f (g a) -> f (h a) -> f ((g:*:h) a)+#ifdef SAFE+gdivide = divide (\(f:*:g) -> (f,g))+#else+gdivide = divide unsafeCoerce+#endif+{-# INLINE gdivide #-}++gchoose :: Decidable f => f (g a) -> f (h a) -> f ((g:+:h) a)+#ifdef SAFE+gchoose = choose (\xs -> case xs of L1 a -> Left a; R1 b -> Right b)+#else+gchoose = choose unsafeCoerce+#endif+{-# INLINE gchoose #-}+ #ifndef HLINT instance q p => GDeciding1 q (K1 i p) where-#endif   gdeciding1 _ q _ = contramap unK1 q+#endif  instance GDeciding1 q f => GDeciding1 q (M1 i c f) where   gdeciding1 p q r = contramap unM1 (gdeciding1 p q r)