hs-functors 0.1.0.0 → 0.1.1.0

raw patch · 9 files changed

+346/−13 lines, 9 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Control/Comonad.hs +70/−0
• Control/Comonad/Trans/Class.hs +9/−0
• Control/Monad/Morph.hs +46/−0
• Control/Monad/Trans/Compose.hs +20/−0
• Data/Bifunctor/Braided.hs +8/−0
• Data/Cotraversable.hs +50/−0
• Data/Functor/Contravariant.hs +25/−7
• Data/Profunctor.hs +102/−1
• hs-functors.cabal +16/−5

@@ -0,0 +1,70 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Control.Comonad where++import Control.Applicative+import Control.Category+import Control.Monad+import Control.Monad.Trans.Identity+import Data.Function (($), fix, flip)+import Data.Functor.Identity+import Data.List.NonEmpty+import Data.Semigroup (Arg (..), Semigroup (..))+import Data.Monoid (Monoid (..))++infixl 1 =>>+infixr 1 <<=, =>=, =<=++class Functor ɯ => Comonad ɯ where+    copure :: ɯ a -> a++    cut :: ɯ a -> ɯ (ɯ a)+    cut = (<<=) id++    (<<=) :: (ɯ a -> b) -> ɯ a -> ɯ b+    (<<=) f = fmap f . cut++(=>>) :: Comonad ɯ => ɯ a -> (ɯ a -> b) -> ɯ b+(=>>) = flip (<<=)++(=>=) :: Comonad ɯ => (ɯ a -> b) -> (ɯ b -> c) -> ɯ a -> c+f =>= g = g . (<<=) f++(=<=) :: Comonad ɯ => (ɯ b -> c) -> (ɯ a -> b) -> ɯ a -> c+(=<=) = flip (=>=)++wfix :: Comonad ɯ => (ɯ a -> a) -> ɯ a+wfix f = fix (fmap f . cut)++instance Comonad Identity where+    copure = runIdentity+    cut = Identity++instance Comonad NonEmpty where+    copure = head+    cut (x:|xs) = (x:|xs) :| go xs+      where go [] = []+            go (x:xs) = (x:|xs) : go xs++instance (Semigroup m, Monoid m) => Comonad ((->) m) where+    copure = ($ mempty)+    cut f x y = f (x <> y)++instance Comonad ((,) a) where+    copure (_, b) = b+    cut (a, b) = (a, (a, b))++instance Comonad (Arg a) where+    copure (Arg _ b) = b+    cut (Arg a b) = Arg a (Arg a b)++instance Comonad ɯ => Comonad (IdentityT ɯ) where+    copure = copure . runIdentityT+    cut (IdentityT x) = IdentityT (IdentityT <$> cut x)++newtype Cokleisli ɯ a b = Cokleisli { runCokleisli :: ɯ a -> b }+    deriving (Functor, Applicative, Monad)++instance Comonad ɯ => Category (Cokleisli ɯ) where+    id = Cokleisli copure+    Cokleisli f . Cokleisli g = Cokleisli (f =<= g)

@@ -0,0 +1,9 @@+module Control.Comonad.Trans.Class where++import Control.Comonad+import Control.Monad.Trans.Identity++class ComonadTrans t where+    colift :: Comonad ɯ => t ɯ a -> ɯ a++instance ComonadTrans IdentityT where colift = runIdentityT

@@ -0,0 +1,46 @@+{-# LANGUAGE RankNTypes #-}++module Control.Monad.Morph where++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Control.Monad.Trans.Writer+import Data.Functor.Compose+import Data.Functor.Product+import Data.Functor.Sum+import Data.Monoid ((<>))++class MFunctor t where+    mmap :: (∀ a . m a -> n a) -> t m a -> t n a++class (MonadTrans t, MFunctor t) => MMonad t where+    mjoin :: Monad m => t (t m) a -> t m a+    mjoin = mbind id++    mbind :: Monad n => (∀ a . m a -> t n a) -> t m a -> t n a+    mbind f = mjoin . mmap f++instance Functor f => MFunctor (Compose f) where mmap f (Compose x) = Compose (f <$> x)+instance MFunctor (Product f) where mmap f (Pair x y) = Pair x (f y)+instance MFunctor (Sum f) where+    mmap _ (InL x) = InL x+    mmap f (InR y) = InR (f y)++instance MFunctor (ExceptT e) where mmap = mapExceptT+instance MFunctor IdentityT   where mmap = mapIdentityT+instance MFunctor MaybeT      where mmap = mapMaybeT+instance MFunctor (ReaderT r) where mmap = mapReaderT+instance MFunctor (StateT  s) where mmap = mapStateT+instance MFunctor (WriterT w) where mmap = mapWriterT++instance MMonad (ExceptT e) where mjoin (ExceptT   (ExceptT   x)) = ExceptT (join <$> x)+instance MMonad IdentityT   where mjoin (IdentityT (IdentityT x)) = IdentityT x+instance MMonad MaybeT      where mjoin (MaybeT    (MaybeT    x)) = MaybeT (join <$> x)+instance MMonad (ReaderT r) where mjoin (ReaderT f) = ReaderT (join (runReaderT . f))+instance Monoid w => MMonad (WriterT w) where+    mjoin (WriterT (WriterT x)) = WriterT ((\ ((a, u), v) -> (a, u <> v)) <$> x)

@@ -0,0 +1,20 @@+module Control.Monad.Trans.Compose where++import Control.Applicative+import Control.Monad+import Control.Monad.Morph+import Control.Monad.Trans.Class+import Data.Functor.Classes+import qualified Data.Functor.Contravariant as Contravar+import Data.Semigroup (Semigroup (..))++newtype ComposeT s t m a = ComposeT { getComposeT :: s (t m) a }+  deriving (Functor, Applicative, Monad, Foldable, Traversable, Alternative, MonadPlus,+            Eq, Ord, Bounded, Read, Show, Semigroup, Monoid, Eq1, Ord1, Read1, Show1,+            Contravar.Functor)++instance (MFunctor s, MonadTrans s, MonadTrans t) => MonadTrans (ComposeT s t) where+    lift = ComposeT . mmap lift . lift++instance (MFunctor s, MFunctor t) => MFunctor (ComposeT s t) where+    mmap f (ComposeT x) = ComposeT (mmap (mmap f) x)

@@ -0,0 +1,8 @@+module Data.Bifunctor.Braided where++class Braided f where braid :: f a b -> f b a++instance Braided (,) where braid (x, y) = (y, x)+instance Braided Either where+    braid (Left  x) = Right x+    braid (Right y) = Left  y

@@ -0,0 +1,50 @@+module Data.Cotraversable where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Reader+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Proxy++class Functor f => Cotraversable f where+    collect :: Functor g => (a -> f b) -> g a -> f (g b)+    collect f = cosequence . fmap f++    cosequence :: Functor g => g (f a) -> f (g a)+    cosequence = collect id++    cotraverse :: Functor g => (g a -> b) -> g (f a) -> f b+    cotraverse f = fmap f . cosequence++instance Cotraversable Identity where+    cosequence = Identity . fmap runIdentity++instance Cotraversable ((->) r) where+    cosequence x a = ($ a) <$> x++instance Cotraversable Proxy where+    cosequence _ = Proxy++instance Cotraversable f => Cotraversable (IdentityT f) where+    cosequence = IdentityT . collect runIdentityT++instance Cotraversable f => Cotraversable (ReaderT r f) where+    cosequence x = ReaderT $ \ a -> flip runReaderT a `collect` x++instance Cotraversable f => Cotraversable (Reverse f) where+    cosequence = Reverse . collect getReverse++instance Cotraversable f => Cotraversable (Backwards f) where+    cosequence = Backwards . collect forwards++instance (Cotraversable f, Cotraversable g) => Cotraversable (Compose f g) where+    cosequence = Compose . fmap cosequence . collect getCompose++instance (Cotraversable f, Cotraversable g) => Cotraversable (Product f g) where+    cosequence = liftA2 Pair (collect fstP) (collect sndP)+      where fstP (Pair a _) = a+            sndP (Pair _ b) = b

@@ -1,20 +1,20 @@ module Data.Functor.Contravariant where -import Prelude hiding (Functor)+import Prelude hiding (Functor, (.), id) +import Control.Applicative import Control.Applicative.Backwards import Control.Arrow+import Control.Category import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Control.Monad.Trans.Writer import Data.Function (on)-import qualified Data.Functor as Covar-import Data.Functor.Compose-import Data.Functor.Const import Data.Functor.Product import Data.Functor.Reverse import Data.Functor.Sum+import Data.Semigroup (Semigroup (..)) import Data.Monoid (Alt (..)) import Data.Proxy @@ -26,9 +26,6 @@ (>$<) :: Functor f => (a -> b) -> f b -> f a (>$<) = gmap -newtype Op1 b a = Op1 { op1 :: a -> b }-newtype Op2 b a = Op2 { op2 :: a -> a -> b }- instance Functor (Op1 a) where gmap f (Op1 g) = Op1 (g . f) instance Functor (Op2 a) where gmap f (Op2 g) = Op2 (g `on` f) instance Functor (Const a) where gmap _ (Const a) = Const a@@ -46,3 +43,24 @@ instance Functor f => Functor (StateT  s f) where     gmap f = StateT  . (fmap . gmap) (f *** id) . runStateT instance Functor f => Functor (WriterT w f) where gmap f = WriterT . gmap (f *** id) . runWriterT++newtype Op1 b a = Op1 { op1 :: a -> b }+newtype Op2 b a = Op2 { op2 :: a -> a -> b }++instance Category Op1 where+    id = Op1 id+    Op1 f . Op1 g = Op1 (g . f)++instance Semigroup a => Semigroup (Op1 a b) where+    Op1 f <> Op1 g = Op1 (liftA2 (<>) f g)++instance (Semigroup a, Monoid a) => Monoid (Op1 a b) where+    mempty = Op1 (pure mempty)+    mappend = (<>)++instance Semigroup a => Semigroup (Op2 a b) where+    Op2 f <> Op2 g = Op2 ((liftA2 . liftA2) (<>) f g)++instance (Semigroup a, Monoid a) => Monoid (Op2 a b) where+    mempty = Op2 ((pure . pure) mempty)+    mappend = (<>)

@@ -1,10 +1,18 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-}+ module Data.Profunctor where  import Prelude hiding ((.), id) +import Control.Applicative import Control.Arrow (Kleisli (..)) import Control.Category+import Control.Comonad import Control.Monad+import Control.Monad.Fix+import Data.Bifunctor.Braided+import Data.Cotraversable  class Profunctor p where     dimap :: (a -> b) -> (c -> d) -> p b c -> p a d@@ -16,8 +24,101 @@     rmap :: (b -> c) -> p a b -> p a c     rmap g = dimap id g +infixr 1 ^>>, >>^, <<^, ^<<++(^>>) :: Profunctor p => (a -> b) -> p b c -> p a c+(^>>) = lmap++(>>^) :: Profunctor p => p a b -> (b -> c) -> p a c+(>>^) = flip rmap++(<<^) :: Profunctor p => p b c -> (a -> b) -> p a c+(<<^) = flip lmap++(^<<) :: Profunctor p => (b -> c) -> p a b -> p a c+(^<<) = rmap+ instance Profunctor (->) where     dimap f g a = g . a . f -instance Monad m => Profunctor (Kleisli m) where+instance Functor f => Profunctor (Kleisli f) where     dimap f g (Kleisli a) = Kleisli (fmap g . a . f)++instance Functor f => Profunctor (Cokleisli f) where+    dimap f g (Cokleisli a) = Cokleisli (g . a . fmap f)++class Profunctor p => Strong f p where+    strong :: p a₁ b₁ -> p a₂ b₂ -> p (f a₁ a₂) (f b₁ b₂)++infixr 3 ***, &&&++(***) :: Strong (,) p => p a₁ b₁ -> p a₂ b₂ -> p (a₁, a₂) (b₁, b₂)+(***) = strong++(&&&) :: Strong (,) p => p a b₁ -> p a b₂ -> p a (b₁, b₂)+f &&& g = f *** g <<^ join (,)++infixr 2 +++, |||++(+++) :: Strong Either p => p a₁ b₁ -> p a₂ b₂ -> p (Either a₁ a₂) (Either b₁ b₂)+(+++) = strong++(|||) :: Strong Either p => p a₁ b -> p a₂ b -> p (Either a₁ a₂) b+f ||| g = either id id ^<< f +++ g++instance Strong (,) (->) where strong f g (x, y) = (f x, g y)++instance Applicative p => Strong (,) (Kleisli p) where+    strong (Kleisli f) (Kleisli g) = Kleisli $ \ (x, y) -> liftA2 (,) (f x) (g y)++instance Strong Either (->) where+    strong f _ (Left x)  = Left (f x)+    strong _ g (Right y) = Right (g y)++instance Functor f => Strong Either (Kleisli f) where+    strong (Kleisli f) (Kleisli g) = Kleisli $ \ case Left  x -> Left  <$> f x+                                                      Right y -> Right <$> g y++instance Comonad ɯ => Strong Either (Cokleisli ɯ) where+    strong (Cokleisli f) (Cokleisli g) =+        (\ a -> Left  . f . (a <$)) |||+        (\ a -> Right . g . (a <$)) ^>> Cokleisli (copure <*> void)+++class Profunctor p => Costrong f p where+    costrongL :: p (f a c) (f b c) -> p a b+    costrongR :: p (f a b) (f a c) -> p b c++    default costrongL :: Braided f => p (f a c) (f b c) -> p a b+    costrongL = costrongR . dimap braid braid++    default costrongR :: Braided f => p (f a b) (f a c) -> p b c+    costrongR = costrongL . dimap braid braid++instance Costrong (,) (->) where+    costrongL f a = let (b, c) = f (a, c) in b++instance MonadFix m => Costrong (,) (Kleisli m) where+    costrongL (Kleisli f) = Kleisli $ \ a -> fst <$> mfix (f . (,) a . snd)++instance Costrong Either (->) where+    costrongL f = let go = either id (go . f . Right) in go . f . Left++instance Monad m => Costrong Either (Kleisli m) where+    costrongL (Kleisli f) = let go = either pure (go <=< f . Right) in Kleisli (go <=< f . Left)++instance Functor f => Costrong Either (Cokleisli f) where+    costrongL (Cokleisli f) = Cokleisli (go . fmap Left)+      where go ɯ = case f ɯ of Left  b -> b+                               Right c -> go (Right c <$ ɯ)++class Profunctor p => Closed f p where+    closed :: p a b -> p (f a) (f b)++instance Functor f => Closed f (->) where closed = fmap++instance (Traversable f, Applicative p) => Closed f (Kleisli p) where+    closed = Kleisli . traverse . runKleisli++instance (Cotraversable f, Functor ɯ) => Closed f (Cokleisli ɯ) where+    closed = Cokleisli . cotraverse . runCokleisli

@@ -1,5 +1,5 @@ name:                hs-functors-version:             0.1.0.0+version:             0.1.1.0 synopsis:            Functors from products of Haskell and its dual to Haskell -- description:          license:             BSD3@@ -12,13 +12,24 @@ cabal-version:       >=1.10  library-  exposed-modules:     Data.Functor.Contravariant-  exposed-modules:     Data.Profunctor+  exposed-modules:     Control.Comonad+                     , Control.Comonad.Trans.Class+                     , Control.Monad.Morph+                     , Control.Monad.Trans.Compose+                     , Data.Bifunctor.Braided+                     , Data.Cotraversable+                     , Data.Functor.Contravariant+                     , Data.Profunctor   -- other-modules:          -- other-extensions:    -  build-depends:       base >=4.9 && <4.12+  build-depends:       base >=4.9 && <5                      , transformers >=0.4.2 && <0.6   -- hs-source-dirs:         default-language:    Haskell2010-  default-extensions:  StandaloneDeriving+  default-extensions:  LambdaCase+                     , UnicodeSyntax+                     , PolyKinds+                     , StandaloneDeriving                      , GeneralizedNewtypeDeriving+                     , DeriveFunctor, DeriveFoldable, DeriveTraversable+  ghc-options:         -Wall -Wno-name-shadowing