diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# 0.3 +* Require `bifunctors-5.2` and `profunctors-5.2`. Add `Invariant(2)` instances + for newly introduced datatypes from those packages. +* Add `ProfunctorFunctor`, `ProfunctorMonad`, `ProfunctorComonad`, `Mapping`, + and `Traversing` instances for `WrappedProfunctor` +* Add `StateVar` as a dependency. Add `Invariant` instances for `StateVar` and + `SettableStateVar`. +* Add `Invariant` instances for `URec` (added to `GHC.Generics` in + `base-4.9.0.0`) + # 0.2.2 * Add `genericInvmap` function (and make it the default implementation of `invmap` for `Invariant` instances) on GHC 7.2 or later diff --git a/invariant.cabal b/invariant.cabal --- a/invariant.cabal +++ b/invariant.cabal @@ -1,5 +1,5 @@ name: invariant -version: 0.2.2 +version: 0.3 synopsis: Haskell 98 invariant functors description: Haskell 98 invariant functors category: Control, Data @@ -12,6 +12,12 @@ Ryan Scott build-type: Simple cabal-version: >= 1.9.2 +tested-with: GHC == 7.0.4 + , GHC == 7.2.2 + , GHC == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 extra-source-files: CHANGELOG.md, README.md source-repository head @@ -26,21 +32,22 @@ hs-source-dirs: src build-depends: array >= 0.3 && < 0.6 , base >= 4 && < 5 - , bifunctors >= 5 && < 6 + , bifunctors >= 5.2 && < 6 , containers >= 0.1 && < 0.6 - , contravariant >= 0.1.2 && < 2 + , contravariant >= 0.5 && < 2 , ghc-prim - , profunctors >= 5 && < 6 + , profunctors >= 5.2 && < 6 , semigroups >= 0.16.2 && < 1 + , StateVar >= 1.1 && < 2 , stm >= 2.2 && < 3 , tagged >= 0.7.3 && < 1 , template-haskell >= 2.4 && < 2.12 - , transformers >= 0.2 && < 0.5 + , transformers >= 0.2 && < 0.6 , transformers-compat >= 0.3 && < 1 , unordered-containers >= 0.2.4 && < 0.3 ghc-options: -Wall -test-suite qc-tests +test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs diff --git a/src/Data/Functor/Invariant.hs b/src/Data/Functor/Invariant.hs --- a/src/Data/Functor/Invariant.hs +++ b/src/Data/Functor/Invariant.hs @@ -6,6 +6,8 @@ #if GHC_GENERICS_OK {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} #endif #if __GLASGOW_HASKELL__ >= 706 @@ -48,7 +50,7 @@ -- base import qualified Control.Category as Cat -import Control.Arrow +import Control.Arrow hiding (first) import Control.Applicative as App import Control.Exception (Handler(..)) import Control.Monad (MonadPlus(..), liftM) @@ -77,13 +79,15 @@ import Data.Array (Array) -- bifunctors -import Data.Bifunctor hiding (first) +import Data.Bifunctor import Data.Bifunctor.Biff import Data.Bifunctor.Clown +import Data.Bifunctor.Fix import Data.Bifunctor.Flip import Data.Bifunctor.Join import Data.Bifunctor.Joker -import qualified Data.Bifunctor.Product as Bifunctors +import qualified Data.Bifunctor.Product as Bifunctor +import qualified Data.Bifunctor.Sum as Bifunctor import Data.Bifunctor.Tannen import Data.Bifunctor.Wrapped @@ -101,17 +105,25 @@ -- profunctors import Data.Profunctor as Pro import Data.Profunctor.Cayley +import Data.Profunctor.Choice import Data.Profunctor.Closed -import Data.Profunctor.Codensity import Data.Profunctor.Composition +import Data.Profunctor.Mapping +import Data.Profunctor.Monad +import Data.Profunctor.Rep import Data.Profunctor.Ran -import Data.Profunctor.Tambara +import Data.Profunctor.Strong +import Data.Profunctor.Traversing +import Data.Profunctor.Unsafe -- semigroups import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Semigroup as Semigroup (First(..), Last(..), Option(..)) import Data.Semigroup (Min(..), Max(..), Arg(..)) +-- StateVar +import Data.StateVar (StateVar(..), SettableStateVar(..)) + -- stm import Control.Concurrent.STM (STM) @@ -207,7 +219,7 @@ ArrowApply a #endif => Invariant (ArrowMonad a) where - invmap f _ (ArrowMonad m) = ArrowMonad $ m >>> arr f + invmap f _ (ArrowMonad m) = ArrowMonad (m >>> arr f) -- | from @Control.Exception@ instance Invariant Handler where @@ -267,6 +279,9 @@ instance Invariant (Clown f a) where invmap = invmapFunctor -- | from the @bifunctors@ package +instance Invariant2 p => Invariant (Fix p) where + invmap f g = In . invmap2 (invmap f g) (invmap g f) f g . out +-- | from the @bifunctors@ package instance Invariant2 p => Invariant (Flip p a) where invmap = invmap2 id id -- | from the @bifunctors@ package @@ -274,7 +289,7 @@ invmap f g = Join . invmap2 f g f g . runJoin -- | from the @bifunctors@ package instance Invariant g => Invariant (Joker g a) where - invmap = invmap2 id id + invmap f g = Joker . invmap f g . runJoker -- | from the @bifunctors@ package instance (Invariant f, Invariant2 p) => Invariant (Tannen f p a) where invmap = invmap2 id id @@ -339,6 +354,12 @@ instance Invariant2 p => Invariant (Codensity p a) where invmap = invmap2 id id -- | from the @profunctors@ package +instance Invariant2 p => Invariant (Coprep p) where + invmap f g (Coprep h) = Coprep (h . invmap2 g f id id) +-- | from the @profunctors@ package +instance Invariant2 p => Invariant (Prep p) where + invmap f g (Prep x p) = Prep x (invmap2 id id f g p) +-- | from the @profunctors@ package instance Invariant2 p => Invariant (Procompose p q a) where invmap k k' (Procompose f g) = Procompose (invmap2 id id k k' f) g -- | from the @profunctors@ package @@ -351,7 +372,13 @@ instance Invariant2 p => Invariant (Tambara p a) where invmap = invmap2 id id -- | from the @profunctors@ package -instance Invariant2 p => Invariant (Cotambara p a) where +instance Invariant (Cotambara p a) where + invmap = invmapFunctor +-- | from the @profunctors@ package +instance Invariant (CotambaraSum p a) where + invmap = invmapFunctor +-- | from the @profunctors@ package +instance Invariant2 p => Invariant (TambaraSum p a) where invmap = invmap2 id id -- | from the @semigroups@ package @@ -376,6 +403,13 @@ instance Invariant (Arg a) where invmap = invmapFunctor +-- | from the @StateVar@ package +instance Invariant StateVar where + invmap f g (StateVar ga sa) = StateVar (fmap f ga) (lmap g sa) +-- | from the @StateVar@ package +instance Invariant SettableStateVar where + invmap = invmapContravariant + -- | from the @stm@ package instance Invariant STM where invmap = invmapFunctor @@ -413,12 +447,14 @@ instance Invariant m => Invariant (Lazy.RWST r w s m) where invmap f g m = Lazy.RWST $ \r s -> invmap (mapFstTriple f) (mapFstTriple g) $ Lazy.runRWST m r s - where mapFstTriple h ~(a, s, w) = (h a, s, w) + where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d) + mapFstTriple h ~(a, s, w) = (h a, s, w) -- | from the @transformers@ package instance Invariant m => Invariant (Strict.RWST r w s m) where invmap f g m = Strict.RWST $ \r s -> invmap (mapFstTriple f) (mapFstTriple g) $ Strict.runRWST m r s - where mapFstTriple h (a, s, w) = (h a, s, w) + where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d) + mapFstTriple h (a, s, w) = (h a, s, w) -- | from the @transformers@ package instance Invariant m => Invariant (ReaderT r m) where invmap f g = mapReaderT (invmap f g) @@ -426,20 +462,24 @@ instance Invariant m => Invariant (Lazy.StateT s m) where invmap f g m = Lazy.StateT $ \s -> invmap (mapFstPair f) (mapFstPair g) $ Lazy.runStateT m s - where mapFstPair h ~(a, s) = (h a, s) + where mapFstPair :: (a -> b) -> (a, c) -> (b, c) + mapFstPair h ~(a, s) = (h a, s) -- | from the @transformers@ package instance Invariant m => Invariant (Strict.StateT s m) where invmap f g m = Strict.StateT $ \s -> invmap (mapFstPair f) (mapFstPair g) $ Strict.runStateT m s - where mapFstPair h (a, s) = (h a, s) + where mapFstPair :: (a -> b) -> (a, c) -> (b, c) + mapFstPair h (a, s) = (h a, s) -- | from the @transformers@ package instance Invariant m => Invariant (Lazy.WriterT w m) where invmap f g = Lazy.mapWriterT $ invmap (mapFstPair f) (mapFstPair g) - where mapFstPair h ~(a, w) = (h a, w) + where mapFstPair :: (a -> b) -> (a, c) -> (b, c) + mapFstPair h ~(a, w) = (h a, w) -- | from the @transformers@ package instance Invariant m => Invariant (Strict.WriterT w m) where invmap f g = Strict.mapWriterT $ invmap (mapFstPair f) (mapFstPair g) - where mapFstPair h (a, w) = (h a, w) + where mapFstPair :: (a -> b) -> (a, c) -> (b, c) + mapFstPair h (a, w) = (h a, w) -- | from the @transformers@ package instance (Invariant f, Invariant g) => Invariant (Transformers.Compose f g) where invmap f g (Transformers.Compose x) = @@ -471,26 +511,32 @@ deriving (Eq, Ord, Read, Show) instance Functor f => Invariant (WrappedFunctor f) where - invmap f g = WrapFunctor . invmapFunctor f g . unwrapFunctor + invmap = invmapFunctor instance Functor f => Functor (WrappedFunctor f) where fmap f = WrapFunctor . fmap f . unwrapFunctor + x <$ WrapFunctor f = WrapFunctor (x <$ f) instance Applicative f => Applicative (WrappedFunctor f) where pure = WrapFunctor . pure - WrapFunctor f <*> WrapFunctor x = WrapFunctor $ f <*> x + WrapFunctor f <*> WrapFunctor x = WrapFunctor (f <*> x) + WrapFunctor a *> WrapFunctor b = WrapFunctor (a *> b) + WrapFunctor a <* WrapFunctor b = WrapFunctor (a <* b) instance Alternative f => Alternative (WrappedFunctor f) where empty = WrapFunctor empty - WrapFunctor x <|> WrapFunctor y = WrapFunctor $ x <|> y + WrapFunctor x <|> WrapFunctor y = WrapFunctor (x <|> y) + some = WrapFunctor . some . unwrapFunctor + many = WrapFunctor . many . unwrapFunctor instance Monad m => Monad (WrappedFunctor m) where return = WrapFunctor . return - WrapFunctor x >>= f = WrapFunctor $ x >>= unwrapFunctor . f + WrapFunctor x >>= f = WrapFunctor (x >>= unwrapFunctor . f) + WrapFunctor a >> WrapFunctor b = WrapFunctor (a >> b) instance MonadPlus m => MonadPlus (WrappedFunctor m) where mzero = WrapFunctor mzero - WrapFunctor x `mplus` WrapFunctor y = WrapFunctor $ x `mplus` y + WrapFunctor x `mplus` WrapFunctor y = WrapFunctor (x `mplus` y) instance F.Foldable f => F.Foldable (WrappedFunctor f) where fold = F.fold . unwrapFunctor @@ -529,10 +575,11 @@ deriving (Eq, Ord, Read, Show) instance Contravariant f => Invariant (WrappedContravariant f) where - invmap f g = WrapContravariant . invmapContravariant f g . unwrapContravariant + invmap = invmapContravariant instance Contravariant f => Contravariant (WrappedContravariant f) where contramap f = WrapContravariant . contramap f . unwrapContravariant + x >$ WrapContravariant f = WrapContravariant (x >$ f) instance Divisible f => Divisible (WrappedContravariant f) where divide f (WrapContravariant l) (WrapContravariant r) = @@ -606,16 +653,20 @@ instance Invariant g => Invariant2 (Joker g) where invmap2 _ _ g g' = Joker . invmap g g' . runJoker -- | from the @bifunctors@ package -instance (Invariant2 f, Invariant2 g) => Invariant2 (Bifunctors.Product f g) where - invmap2 f f' g g' (Bifunctors.Pair x y) = - Bifunctors.Pair (invmap2 f f' g g' x) (invmap2 f f' g g' y) +instance (Invariant2 f, Invariant2 g) => Invariant2 (Bifunctor.Product f g) where + invmap2 f f' g g' (Bifunctor.Pair x y) = + Bifunctor.Pair (invmap2 f f' g g' x) (invmap2 f f' g g' y) -- | from the @bifunctors@ package +instance (Invariant2 p, Invariant2 q) => Invariant2 (Bifunctor.Sum p q) where + invmap2 f f' g g' (Bifunctor.L2 l) = Bifunctor.L2 (invmap2 f f' g g' l) + invmap2 f f' g g' (Bifunctor.R2 r) = Bifunctor.R2 (invmap2 f f' g g' r) +-- | from the @bifunctors@ package instance (Invariant f, Invariant2 p) => Invariant2 (Tannen f p) where invmap2 f f' g g' = Tannen . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runTannen -- | from the @bifunctors@ package instance Bifunctor p => Invariant2 (WrappedBifunctor p) where - invmap2 f f' g g' = WrapBifunctor . invmap2Bifunctor f f' g g' . unwrapBifunctor + invmap2 = invmap2Bifunctor -- | from the @contravariant@ package instance Invariant2 Op where @@ -642,7 +693,7 @@ invmap2 f f' g g' (Closure p) = Closure $ invmap2 (f .) (f' .) (g .) (g' .) p -- | from the @profunctors@ package instance Invariant2 (Environment p) where - invmap2 _ f' g _ (Environment l m r) = Environment (g . l) m (r . f') + invmap2 = invmap2Profunctor -- | from the @profunctors@ package instance Invariant2 p => Invariant2 (Codensity p) where invmap2 ac ca bd db (Codensity f) = @@ -662,15 +713,38 @@ invmap2 f f' g g' (Tambara p) = Tambara $ invmap2 (first f) (first f') (first g) (first g') p -- | from the @profunctors@ package +instance Invariant2 (PastroSum p) where + invmap2 = invmap2Profunctor +-- | from the @profunctors@ package +instance Invariant2 p => Invariant2 (CofreeMapping p) where + invmap2 f f' g g' (CofreeMapping p) = + CofreeMapping (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p) +-- | from the @profunctors@ package +instance Invariant2 (FreeMapping p) where + invmap2 = invmap2Profunctor +-- | from the @profunctors@ package +instance Invariant2 p => Invariant2 (CofreeTraversing p) where + invmap2 f f' g g' (CofreeTraversing p) = + CofreeTraversing (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p) +-- | from the @profunctors@ package +instance Invariant2 (FreeTraversing p) where + invmap2 = invmap2Profunctor +-- | from the @profunctors@ package instance Invariant2 (Pastro p) where - invmap2 _ f' g _ (Pastro l m r) = Pastro (g . l) m (r . f') + invmap2 = invmap2Profunctor -- | from the @profunctors@ package -instance Invariant2 p => Invariant2 (Cotambara p) where - invmap2 f f' g g' (Cotambara p) = - Cotambara $ invmap2 (left f) (left f') (left g) (left g') p +instance Invariant2 (Cotambara p) where + invmap2 = invmap2Profunctor -- | from the @profunctors@ package -instance Invariant2 (Copastro p) where - invmap2 _ f' g _ (Copastro l m r) = Copastro (g . l) m (r . f') +instance Invariant2 (CopastroSum p) where + invmap2 = invmap2Profunctor +-- | from the @profunctors@ package +instance Invariant2 (CotambaraSum p) where + invmap2 = invmap2Profunctor +-- | from the @profunctors@ package +instance Invariant2 p => Invariant2 (TambaraSum p) where + invmap2 f f' g g' (TambaraSum p) = + TambaraSum (invmap2 (first f) (first f') (first g) (first g') p) -- | from the @semigroups@ package instance Invariant2 Arg where @@ -693,13 +767,17 @@ deriving (Eq, Ord, Read, Show) instance Profunctor p => Invariant2 (WrappedProfunctor p) where - invmap2 f f' g g' = WrapProfunctor . invmap2Profunctor f f' g g' . unwrapProfunctor + invmap2 = invmap2Profunctor instance Profunctor p => Invariant (WrappedProfunctor p a) where invmap = invmap2 id id instance Profunctor p => Profunctor (WrappedProfunctor p) where dimap f g = WrapProfunctor . dimap f g . unwrapProfunctor + lmap f = WrapProfunctor . lmap f . unwrapProfunctor + rmap g = WrapProfunctor . rmap g . unwrapProfunctor + WrapProfunctor x .# f = WrapProfunctor (x .# f) + g #. WrapProfunctor x = WrapProfunctor (g #. x) instance Strong p => Strong (WrappedProfunctor p) where first' = WrapProfunctor . first' . unwrapProfunctor @@ -720,6 +798,24 @@ instance Closed p => Closed (WrappedProfunctor p) where closed = WrapProfunctor . closed . unwrapProfunctor +instance Traversing p => Traversing (WrappedProfunctor p) where + traverse' = WrapProfunctor . traverse' . unwrapProfunctor + wander f = WrapProfunctor . wander f . unwrapProfunctor + +instance Mapping p => Mapping (WrappedProfunctor p) where + map' = WrapProfunctor . map' . unwrapProfunctor + +instance ProfunctorFunctor WrappedProfunctor where + promap f = WrapProfunctor . f . unwrapProfunctor + +instance ProfunctorMonad WrappedProfunctor where + proreturn = WrapProfunctor + projoin = unwrapProfunctor + +instance ProfunctorComonad WrappedProfunctor where + proextract = unwrapProfunctor + produplicate = WrapProfunctor + #if GHC_GENERICS_OK ------------------------------------------------------------------------------- -- GHC Generics @@ -752,6 +848,26 @@ -- likely requires writing your 'Generic1' instance by hand instance (Invariant f, Invariant g) => Invariant ((:.:) f g) where invmap f g (Comp1 fgp) = Comp1 $ invmap (invmap f g) (invmap g f) fgp + +# if __GLASGOW_HASKELL__ >= 800 +instance Invariant UAddr where + invmap _ _ (UAddr a) = UAddr a + +instance Invariant UChar where + invmap _ _ (UChar c) = UChar c + +instance Invariant UDouble where + invmap _ _ (UDouble d) = UDouble d + +instance Invariant UFloat where + invmap _ _ (UFloat f) = UFloat f + +instance Invariant UInt where + invmap _ _ (UInt i) = UInt i + +instance Invariant UWord where + invmap _ _ (UWord w) = UWord w +# endif {- $ghcgenerics With GHC 7.2 or later, 'Invariant' instances can be defined easily using GHC