packages feed

profunctors 3.1.3 → 3.2

raw patch · 3 files changed

+90/−54 lines, 3 files

Files

profunctors.cabal view
@@ -1,6 +1,6 @@ name:          profunctors category:      Control, Categories-version:       3.1.3+version:       3.2 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE
src/Data/Profunctor.hs view
@@ -25,8 +25,8 @@   -- * Profunctors     Profunctor(dimap,lmap,rmap)   -- ** Profunctorial Strength-  , Lenticular(..)-  , Prismatic(..)+  , Strong(..)+  , Choice(..)   -- ** Common Profunctors   , UpStar(..)   , DownStar(..)@@ -36,9 +36,10 @@ import Control.Applicative hiding (WrappedArrow(..)) import Control.Arrow import Control.Category-import Control.Comonad (Cokleisli(..))+import Control.Comonad import Data.Tagged import Data.Traversable+import Data.Tuple import Data.Profunctor.Unsafe import Prelude hiding (id,(.),sequence) import Unsafe.Coerce@@ -47,7 +48,7 @@ -- UpStar ------------------------------------------------------------------------------ --- | Lift a 'Functor' into a 'Profunctor' (forwards)+-- | Lift a 'Functor' into a 'Profunctor' (forwards). newtype UpStar f d c = UpStar { runUpStar :: d -> f c }  instance Functor f => Profunctor (UpStar f) where@@ -69,7 +70,7 @@ -- DownStar ------------------------------------------------------------------------------ --- | Lift a 'Functor' into a 'Profunctor' (backwards)+-- | Lift a 'Functor' into a 'Profunctor' (backwards). newtype DownStar f d c = DownStar { runDownStar :: f d -> c }  instance Functor f => Profunctor (DownStar f) where@@ -91,7 +92,7 @@ -- Wrapped Profunctors ------------------------------------------------------------------------------ --- | Wrap an arrow for use as a 'Profunctor'+-- | Wrap an arrow for use as a 'Profunctor'. newtype WrappedArrow p a b = WrapArrow { unwrapArrow :: p a b }  instance Category p => Category (WrappedArrow p) where@@ -142,65 +143,99 @@   -- We cannot safely overload ( #. ) or ( .# ) because we didn't write the 'Arrow'.  --------------------------------------------------------------------------------- Lenticular+-- Strong ------------------------------------------------------------------------------  -- | Generalizing upstar of a strong 'Functor' --+-- Minimal complete definition: 'first'' or 'second''+-- -- /Note:/ Every 'Functor' in Haskell is strong.-class Profunctor p => Lenticular p where-  lenticular :: p a b -> p a (a, b)+class Profunctor p => Strong p where+  first' :: p a b  -> p (a, c) (b, c)+  first' = dimap swap swap . second' -instance Lenticular (->) where-  lenticular f a = (a, f a)-  {-# INLINE lenticular #-}+  second' :: p a b -> p (c, a) (c, b)+  second' = dimap swap swap . first' -instance Monad m => Lenticular (Kleisli m) where-  lenticular (Kleisli f) = Kleisli $ \ a -> do+instance Strong (->) where+  first' ab ~(a, c) = (ab a, c)+  {-# INLINE first' #-}+  second' ab ~(c, a) = (c, ab a)++instance Monad m => Strong (Kleisli m) where+  first' (Kleisli f) = Kleisli $ \ ~(a, c) -> do      b <- f a-     return (a, b)-  {-# INLINE lenticular #-}+     return (b, c)+  {-# INLINE first' #-}+  second' (Kleisli f) = Kleisli $ \ ~(c, a) -> do+     b <- f a+     return (c, b)+  {-# INLINE second' #-} -instance Functor m => Lenticular (UpStar m) where-  lenticular (UpStar f) = UpStar $ \ a -> (,) a <$> f a-  {-# INLINE lenticular #-}+instance Functor m => Strong (UpStar m) where+  first' (UpStar f) = UpStar $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a+  {-# INLINE first' #-}+  second' (UpStar f) = UpStar $ \ ~(c, a) -> (,) c <$> f a+  {-# INLINE second' #-} -instance Arrow p => Lenticular (WrappedArrow p) where-  lenticular (WrapArrow k) = WrapArrow (id &&& k)-  {-# INLINE lenticular #-}+instance Arrow p => Strong (WrappedArrow p) where+  first' (WrapArrow k) = WrapArrow (first k)+  {-# INLINE first' #-}+  second' (WrapArrow k) = WrapArrow (second k)+  {-# INLINE second' #-}  --------------------------------------------------------------------------------- Prismatic+-- Choice ------------------------------------------------------------------------------ --- | The generalization of 'DownStar' of a \"Costrong\" 'Functor'+-- | The generalization of 'DownStar' of a \"costrong\" 'Functor' ----- /Note:/ Here we use 'Traversable' as an approximate costrength.-class Profunctor p => Prismatic p where-  prismatic :: p a b -> p (Either b a) b+-- Minimal complete definition: 'left'' or 'right''+--+-- /Note:/ We use 'traverse' and 'extract' as approximate costrength as needed.+class Profunctor p => Choice p where+  left'  :: p a b -> p (Either a c) (Either b c)+  left' =  dimap (either Right Left) (either Right Left) . right' -instance Prismatic (->) where-  prismatic = either id-  {-# INLINE prismatic #-}+  right' :: p a b -> p (Either c a) (Either c b)+  right' =  dimap (either Right Left) (either Right Left) . left' -instance Monad m => Prismatic (Kleisli m) where-  prismatic (Kleisli pab) = Kleisli (either return pab)-  {-# INLINE prismatic #-}+instance Choice (->) where+  left' ab (Left a) = Left (ab a)+  left' _ (Right c) = Right c+  {-# INLINE left' #-}+  right' = fmap+  {-# INLINE right' #-} --- | 'sequence' approximates 'costrength'-instance Traversable w => Prismatic (Cokleisli w) where-  prismatic (Cokleisli wab) = Cokleisli (either id wab . sequence)-  {-# INLINE prismatic #-}+instance Monad m => Choice (Kleisli m) where+  left' = left+  {-# INLINE left' #-}+  right' = right+  {-# INLINE right' #-} +-- | 'extract' approximates 'costrength'+instance Comonad w => Choice (Cokleisli w) where+  left' = left+  {-# INLINE left' #-}+  right' = right+  {-# INLINE right' #-}+ -- | 'sequence' approximates 'costrength'-instance Traversable w => Prismatic (DownStar w) where-  prismatic (DownStar wab) = DownStar (either id wab . sequence)-  {-# INLINE prismatic #-}+instance Traversable w => Choice (DownStar w) where+  left' (DownStar wab) = DownStar (either Right Left . fmap wab . traverse (either Right Left))+  {-# INLINE left' #-}+  right' (DownStar wab) = DownStar (fmap wab . sequence)+  {-# INLINE right' #-} -instance Prismatic Tagged where-  prismatic = retag-  {-# INLINE prismatic #-}+instance Choice Tagged where+  left' (Tagged b) = Tagged (Left b)+  {-# INLINE left' #-}+  right' (Tagged b) = Tagged (Right b)+  {-# INLINE right' #-} -instance ArrowChoice p => Prismatic (WrappedArrow p) where-  prismatic (WrapArrow k) = WrapArrow (id ||| k)-  {-# INLINE prismatic #-}+instance ArrowChoice p => Choice (WrappedArrow p) where+  left' (WrapArrow k) = WrapArrow (left k)+  {-# INLINE left' #-}+  right' (WrapArrow k) = WrapArrow (right k)+  {-# INLINE right' #-}
src/Data/Profunctor/Unsafe.hs view
@@ -50,12 +50,13 @@ -- Profunctors ---------------------------------------------------------------------------- --- | Formally, the class 'Profunctor' represents a profunctor from @Hask@ -> @Hask@+-- | Formally, the class 'Profunctor' represents a profunctor+-- from @Hask@ -> @Hask@. -- -- Intuitively it is a bifunctor where the first argument is contravariant -- and the second argument is covariant. ----- You can define a profunctor by either defining 'dimap' or by defining both+-- You can define a 'Profunctor' by either defining 'dimap' or by defining both -- 'lmap' and 'rmap'. -- -- If you supply 'dimap', you should ensure that:@@ -71,7 +72,7 @@ -- -- If you supply both, you should also ensure: ----- @'dimap' f g ≡ 'lmap' f . 'rmap' g@+-- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ -- -- These ensure by parametricity: --@@ -88,14 +89,14 @@   dimap f g = lmap f . rmap g   {-# INLINE dimap #-} -  -- | Map the first argument contravariantly+  -- | Map the first argument contravariantly.   --   -- @'lmap' f ≡ 'dimap' f 'id'@   lmap :: (a -> b) -> p b c -> p a c   lmap f = dimap f id   {-# INLINE lmap #-} -  -- | Map the second argument covariantly+  -- | Map the second argument covariantly.   --   -- @'rmap' ≡ 'dimap' 'id'@   rmap :: (b -> c) -> p a b -> p a c@@ -126,7 +127,7 @@   -- The semantics of this function with respect to bottoms   -- should match the default definition:   ---  -- @(#.) ≡ \\f -> \\p -> p \`seq\` 'rmap' f p@+  -- @('Profuctor.Unsafe.#.') ≡ \\f -> \\p -> p \`seq\` 'rmap' f p@   ( #. ) :: (b -> c) -> p a b -> p a c   ( #. ) = \f -> \p -> p `seq` rmap f p   {-# INLINE ( #. ) #-}@@ -152,7 +153,7 @@   -- will only call this with a second argument that is   -- operationally identity.   ---  -- @(.#) ≡ \\p -> p \`seq\` \\f -> 'lmap' f p@+  -- @('.#') ≡ \\p -> p \`seq\` \\f -> 'lmap' f p@   ( .# ) :: p b c -> (a -> b) -> p a c   ( .# ) = \p -> p `seq` \f -> lmap f p   {-# INLINE ( .# ) #-}