Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add VoidProfunctor class #54

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Add VoidProfunctor class #54

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions CHANGELOG.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,3 +1,5 @@
* Added `VoidProfunctor` typeclass.

# 0.11.0.0

* Added `makeAdaptorAndInstanceInferrable` which has better inference
Expand Down
29 changes: 28 additions & 1 deletion Data/Profunctor/Product.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,10 +31,13 @@ import Data.Profunctor (Profunctor, dimap, lmap, WrappedArrow, Star(..), Costar)
import qualified Data.Profunctor as Profunctor
import Data.Profunctor.Composition (Procompose(..))
import Data.Functor.Contravariant (Contravariant, contramap)
import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable, chosen)
import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable, chosen,
lose, lost)
import Data.Void (absurd)
import Control.Category (id)
import Control.Arrow (Arrow, (***), (<<<), arr, (&&&), ArrowChoice, (+++))
import Control.Applicative (Applicative, liftA2, pure, (<*>), Alternative, (<|>), (<$>))
import qualified Control.Applicative as Applicative

import Data.Monoid (Monoid, mempty, (<>))
import Data.Tagged
Expand Down Expand Up @@ -153,27 +156,51 @@ instance (Applicative f, ProductProfunctor p) => ProductProfunctor (Tannen f p)

-- { Sum

instance VoidProfunctor (->) where
loseP = (absurd .)

instance SumProfunctor (->) where
f +++! g = either (Left . f) (Right . g)

instance ArrowChoice arr => VoidProfunctor (WrappedArrow arr) where
loseP f = Profunctor.WrapArrow $ arr (loseP f)

instance ArrowChoice arr => SumProfunctor (WrappedArrow arr) where
(+++!) = (+++)

instance Applicative f => VoidProfunctor (Star f) where
loseP = Star . loseP

instance Applicative f => SumProfunctor (Star f) where
Star f +++! Star g = Star $ either (fmap Left . f) (fmap Right . g)

instance (VoidProfunctor p, VoidProfunctor q) => VoidProfunctor (Procompose p q) where
loseP f = Procompose (loseP f) (loseP f)

instance (SumProfunctor p, SumProfunctor q) => SumProfunctor (Procompose p q) where
Procompose pa qa +++! Procompose pb qb = Procompose (pa +++! pb) (qa +++! qb)

instance Alternative f => VoidProfunctor (Joker f) where
loseP _ = Joker Applicative.empty

instance Alternative f => SumProfunctor (Joker f) where
Joker f +++! Joker g = Joker $ Left <$> f <|> Right <$> g

instance Decidable f => VoidProfunctor (Clown f) where
loseP = Clown . lose

instance Decidable f => SumProfunctor (Clown f) where
Clown f +++! Clown g = Clown $ chosen f g

instance (VoidProfunctor p, VoidProfunctor q) => VoidProfunctor (Product p q) where
loseP f = Pair (loseP f) (loseP f)

instance (SumProfunctor p, SumProfunctor q) => SumProfunctor (Product p q) where
Pair l1 l2 +++! Pair r1 r2 = Pair (l1 +++! r1) (l2 +++! r2)

instance (Applicative f, VoidProfunctor p) => VoidProfunctor (Tannen f p) where
loseP f = Tannen $ pure (loseP f)

instance (Applicative f, SumProfunctor p) => SumProfunctor (Tannen f p) where
Tannen l +++! Tannen r = Tannen $ liftA2 (+++!) l r

Expand Down
16 changes: 14 additions & 2 deletions Data/Profunctor/Product/Class.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@ module Data.Profunctor.Product.Class where

import Data.Profunctor (Profunctor)
import qualified Data.Profunctor as Profunctor
import Data.Void (Void)

--- vv These are redundant imports but they're needeed for Haddock
--- links. AIUI Haddock can't link to something you haven't imported.
Expand Down Expand Up @@ -94,7 +95,18 @@ class Profunctor p => ProductProfunctor p where
f ***! g = (,) `Profunctor.rmap` Profunctor.lmap fst f
**** Profunctor.lmap snd g

-- | In the future 'VoidProfunctor' will be a superclass of
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Should this be the other way around? Looking at the semigroupoids PR, they have:

                              Contravariant
                               /         \
                              /           \
 (semigroupoid Divisible) Divise        Decide (semigroupoid Decidable)
                                           |
                                           v
                                        Conclude (Decide + lose)

Should the eventual goal be a hierarchy more like:

              Profunctor
               /      \
              /        \
ProductProfunctor     SumProfunctor
             |         |
             v         v
  UnitProfunctor     VoidProfunctor

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Interesting. I didn't expect that. If we really want to do the superclassing in that direction then we can do it now with no backwards compatibility changes!

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If we have a superclass relationship between SumProfunctor and VoidProfunctor, it should be this one. "Providing a unit" is almost always done with a subclass (Semigroup => Monoid etc.) as it lets you write laws in terms of superclass operations that you know you have.

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, that rationale makes sense to me, thanks! I guess I can also add a superclass of ProductProfunctor with method pureP. Perhaps I can add purePP = pureP as a default and eventually remove purePP.

On the other hand this suggests the names need work. The names UnitProfunctor and VoidProfunctor no longer capture everything the classes do.

ApplicativeProfunctor from your "Option 2" now sounds good to me, but I prefer DecidableProfunctor to ConcludeProfunctor. What do you think?

What do you think?

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If you have pureP, you have unitP, so it needs to be on the UnitProfunctor subclass, becuase

pureP a = dimap (const ()) (const a) unitP
unitP = pureP ()

I think I like the {Sum,Void,Product,Unit}Profunctor names better, because to me that's the fundamental idea being captured: you're tying pairs of profunctors together in interesting ways, and sometimes you have units for these operations. From there, you can recover a bunch of familiar-looking operations from the Applicative/Divisible/Decidable world, but I don't feel like any of them are compelling enough to take over the class names. Also, it makes the package name confusing if there's no ProductProfunctor class any more.

-- 'SumProfunctor'.
class Profunctor p => VoidProfunctor p where
-- | 'Data.Profunctor.Profunctor' version of
-- 'Data.Functor.Contravariant.Divisible.lose'. @'lost' = loseP id@
-- is the unit of @('+++!')@.
loseP :: (a -> Void) -> p a b
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Kinda matches the shape of the proposed conclude :: (a -> Void) -> f a, but obviously in the first position. Makes hypothetical instance VoidProfunctor p => Conclude (Flip p a) seem easy.


-- | 'Data.Profunctor.Profunctor' version of
-- 'Data.Functor.Contravariant.Divisible.lost'.
lostP :: VoidProfunctor p => p Void b
lostP = loseP id

class Profunctor p => SumProfunctor p where
-- Morally we should have 'zero :: p Void Void' but I don't think
-- that would actually be useful
(+++!) :: p a b -> p a' b' -> p (Either a a') (Either b b')
6 changes: 3 additions & 3 deletions product-profunctors.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ source-repository head

library
default-language: Haskell2010
build-depends: base >= 4.5 && < 5
build-depends: base >= 4.8 && < 5
, profunctors >= 5 && < 5.6
, bifunctors >= 5.4 && < 6.0
, contravariant >= 0.4 && < 1.6
Expand Down Expand Up @@ -56,7 +56,7 @@ test-suite test
DefinitionsUndecidable
hs-source-dirs: Test
build-depends:
base >= 4 && < 5,
base >= 4.8 && < 5,
profunctors,
product-profunctors
ghc-options: -Wall
Expand All @@ -67,7 +67,7 @@ benchmark bench
main-is: Main.hs
hs-source-dirs: Bench
build-depends:
base >= 4 && < 5,
base >= 4.8 && < 5,
criterion,
deepseq,
product-profunctors