Merge pull request #22 from purescript/newtypes

Add some bifunctors-style newtypes

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"
   }
 }

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,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)

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/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)

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)