diff --git a/bower.json b/bower.json index 73d7d5f..990aea9 100644 --- a/bower.json +++ b/bower.json @@ -22,8 +22,10 @@ "package.json" ], "dependencies": { + "purescript-contravariant": "^3.0.0", "purescript-distributive": "^3.0.0", "purescript-either": "^3.0.0", + "purescript-exists": "^3.0.0", "purescript-tuples": "^4.0.0" } } diff --git a/src/Data/Profunctor/Clown.purs b/src/Data/Profunctor/Clown.purs new file mode 100644 index 0000000..cd90ab6 --- /dev/null +++ b/src/Data/Profunctor/Clown.purs @@ -0,0 +1,23 @@ +module Data.Profunctor.Clown where + +import Prelude + +import Data.Profunctor (class Profunctor) +import Data.Newtype (class Newtype) +import Data.Functor.Contravariant (class Contravariant, cmap) + +-- | Makes a trivial `Profunctor` for a `Contravariant` functor. +newtype Clown f a b = Clown (f a) + +derive instance newtypeClown :: Newtype (Clown f a b) _ +derive newtype instance eqClown :: Eq (f a) => Eq (Clown f a b) +derive newtype instance ordClown :: Ord (f a) => Ord (Clown f a b) + +instance showClown :: Show (f a) => Show (Clown f a b) where + show (Clown x) = "(Clown " <> show x <> ")" + +instance functorClown :: Functor (Clown f a) where + map _ (Clown a) = Clown a + +instance profunctorClown :: Contravariant f => Profunctor (Clown f) where + dimap f g (Clown a) = Clown (cmap f a) diff --git a/src/Data/Profunctor/Cowrap.purs b/src/Data/Profunctor/Cowrap.purs new file mode 100644 index 0000000..90e45e3 --- /dev/null +++ b/src/Data/Profunctor/Cowrap.purs @@ -0,0 +1,20 @@ +module Data.Profunctor.Cowrap where + +import Prelude + +import Data.Newtype (class Newtype) +import Data.Functor.Contravariant (class Contravariant) +import Data.Profunctor (class Profunctor, lmap) + +-- | Provides a `Contravariant` over the first argument of a `Profunctor`. +newtype Cowrap p b a = Cowrap (p a b) + +derive instance newtypeCowrap :: Newtype (Cowrap p b a) _ +derive newtype instance eqCowrap :: Eq (p a b) => Eq (Cowrap p b a) +derive newtype instance ordCowrap :: Ord (p a b) => Ord (Cowrap p b a) + +instance showCowrap :: Show (p a b) => Show (Cowrap p b a) where + show (Cowrap x) = "(Cowrap " <> show x <> ")" + +instance contravariantCowrap :: Profunctor p => Contravariant (Cowrap p b) where + cmap f (Cowrap a) = Cowrap (lmap f a) diff --git a/src/Data/Profunctor/Join.purs b/src/Data/Profunctor/Join.purs new file mode 100644 index 0000000..2892726 --- /dev/null +++ b/src/Data/Profunctor/Join.purs @@ -0,0 +1,28 @@ +module Data.Profunctor.Join where + +import Prelude + +import Data.Functor.Invariant (class Invariant) +import Data.Newtype (class Newtype) +import Data.Profunctor (class Profunctor, dimap) +import Data.Monoid (class Monoid) + +-- | Turns a `Profunctor` into a `Invariant` functor by equating the two type +-- | arguments. +newtype Join p a = Join (p a a) + +derive instance newtypeJoin :: Newtype (Join p a) _ +derive newtype instance eqJoin :: Eq (p a a) => Eq (Join p a) +derive newtype instance ordJoin :: Ord (p a a) => Ord (Join p a) + +instance showJoin :: Show (p a a) => Show (Join p a) where + show (Join x) = "(Join " <> show x <> ")" + +instance semigroupJoin :: Semigroupoid p => Semigroup (Join p a) where + append (Join a) (Join b) = Join (a <<< b) + +instance monoidJoin :: Category p => Monoid (Join p a) where + mempty = Join id + +instance invariantJoin :: Profunctor p => Invariant (Join p) where + imap f g (Join a) = Join (dimap g f a) diff --git a/src/Data/Profunctor/Joker.purs b/src/Data/Profunctor/Joker.purs new file mode 100644 index 0000000..fd0d872 --- /dev/null +++ b/src/Data/Profunctor/Joker.purs @@ -0,0 +1,22 @@ +module Data.Profunctor.Joker where + +import Prelude + +import Data.Profunctor (class Profunctor) +import Data.Newtype (class Newtype) + +-- | Makes a trivial `Profunctor` for a covariant `Functor`. +newtype Joker f a b = Joker (f b) + +derive instance newtypeJoker :: Newtype (Joker f a b) _ +derive newtype instance eqJoker :: Eq (f b) => Eq (Joker f a b) +derive newtype instance ordJoker :: Ord (f b) => Ord (Joker f a b) + +instance showJoker :: Show (f b) => Show (Joker f a b) where + show (Joker x) = "(Joker " <> show x <> ")" + +instance functorJoker :: Functor f => Functor (Joker f a) where + map f (Joker a) = Joker (map f a) + +instance profunctorJoker :: Functor f => Profunctor (Joker f) where + dimap f g (Joker a) = Joker (map g a) diff --git a/src/Data/Profunctor/Split.purs b/src/Data/Profunctor/Split.purs new file mode 100644 index 0000000..3664431 --- /dev/null +++ b/src/Data/Profunctor/Split.purs @@ -0,0 +1,39 @@ +module Data.Profunctor.Split + ( Split + , split + , unSplit + , liftSplit + , lowerSplit + , hoistSplit + ) where + +import Prelude + +import Data.Exists (Exists, mkExists, runExists) +import Data.Functor.Invariant (class Invariant, imap) +import Data.Profunctor (class Profunctor) + +newtype Split f a b = Split (Exists (SplitF f a b)) + +data SplitF f a b x = SplitF (a -> x) (x -> b) (f x) + +instance functorSplit :: Functor (Split f a) where + map f = unSplit \g h fx -> split g (f <<< h) fx + +instance profunctorSplit :: Profunctor (Split f) where + dimap f g = unSplit \h i -> split (h <<< f) (g <<< i) + +split :: forall f a b x. (a -> x) -> (x -> b) -> f x -> Split f a b +split f g fx = Split (mkExists (SplitF f g fx)) + +unSplit :: forall f a b r. (forall x. (a -> x) -> (x -> b) -> f x -> r) -> Split f a b -> r +unSplit f (Split e) = runExists (\(SplitF g h fx) -> f g h fx) e + +liftSplit :: forall f a. f a -> Split f a a +liftSplit = split id id + +lowerSplit :: forall f a. Invariant f => Split f a a -> f a +lowerSplit = unSplit (flip imap) + +hoistSplit :: forall f g a b. (f ~> g) -> Split f a b -> Split g a b +hoistSplit nat = unSplit (\f g -> split f g <<< nat) diff --git a/src/Data/Profunctor/Wrap.purs b/src/Data/Profunctor/Wrap.purs new file mode 100644 index 0000000..64e8e91 --- /dev/null +++ b/src/Data/Profunctor/Wrap.purs @@ -0,0 +1,19 @@ +module Data.Profunctor.Wrap where + +import Prelude + +import Data.Newtype (class Newtype) +import Data.Profunctor (class Profunctor, rmap) + +-- | Provides a `Functor` over the second argument of a `Profunctor`. +newtype Wrap p a b = Wrap (p a b) + +derive instance newtypeWrap :: Newtype (Wrap p a b) _ +derive newtype instance eqWrap :: Eq (p a b) => Eq (Wrap p a b) +derive newtype instance ordWrap :: Ord (p a b) => Ord (Wrap p a b) + +instance showWrap :: Show (p a b) => Show (Wrap p a b) where + show (Wrap x) = "(Wrap " <> show x <> ")" + +instance functorWrap :: Profunctor p => Functor (Wrap p a) where + map f (Wrap a) = Wrap (rmap f a)