Add some bifunctors-style newtypes

Author: garyb

bower.json

@@ -22,6 +22,7 @@
     "package.json"
   ],
   "dependencies": {
+    "purescript-contravariant": "^3.0.0",
     "purescript-distributive": "^3.0.0",
     "purescript-either": "^3.0.0",
     "purescript-tuples": "^4.0.0"

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)

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)

src/Data/Profunctor/Join.purs

@@ -0,0 +1,21 @@
+module Data.Profunctor.Join where
+
+import Prelude
+
+import Data.Functor.Invariant (class Invariant)
+import Data.Newtype (class Newtype)
+import Data.Profunctor (class Profunctor, dimap)
+
+-- | 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 invariantJoin :: Profunctor p => Invariant (Join p) where
+  imap f g (Join a) = Join (dimap g f a)

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)

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)