{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}

module Data.Profunctor.Product.Examples where

import qualified Data.Profunctor                 as P
import qualified Data.Profunctor.Product         as PP
import qualified Data.Profunctor.Product.Default as D
import           Control.Applicative             (Applicative, liftA2, pure, (<*>),
                                                  ZipList(ZipList), getZipList)

newtype Replicator r f a b = Replicator (r -> f b)
  deriving a -> Replicator r f a b -> Replicator r f a a
(a -> b) -> Replicator r f a a -> Replicator r f a b
(forall a b. (a -> b) -> Replicator r f a a -> Replicator r f a b)
-> (forall a b. a -> Replicator r f a b -> Replicator r f a a)
-> Functor (Replicator r f a)
forall a b. a -> Replicator r f a b -> Replicator r f a a
forall a b. (a -> b) -> Replicator r f a a -> Replicator r f a b
forall r (f :: * -> *) a a b.
Functor f =>
a -> Replicator r f a b -> Replicator r f a a
forall r (f :: * -> *) a a b.
Functor f =>
(a -> b) -> Replicator r f a a -> Replicator r f a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Replicator r f a b -> Replicator r f a a
$c<$ :: forall r (f :: * -> *) a a b.
Functor f =>
a -> Replicator r f a b -> Replicator r f a a
fmap :: (a -> b) -> Replicator r f a a -> Replicator r f a b
$cfmap :: forall r (f :: * -> *) a a b.
Functor f =>
(a -> b) -> Replicator r f a a -> Replicator r f a b
Functor

instance Applicative f => D.Default (Replicator (f b) f) b b where
  def :: Replicator (f b) f b b
def = (f b -> f b) -> Replicator (f b) f b b
forall r (f :: * -> *) a b. (r -> f b) -> Replicator r f a b
Replicator f b -> f b
forall a. a -> a
id

-- | A higher-order generalisation of 'Prelude.replicate'.  For
-- example
--
-- @
-- foo :: IO (String, String, String)
-- foo = replicateT getLine
-- @
--
-- @
-- > foo
-- Hello
-- world
-- !
-- (\"Hello\",\"world\",\"!\")
-- @
replicateT :: D.Default (Replicator r f) b b => r -> f b
replicateT :: r -> f b
replicateT = r -> f b
f
  where Replicator r -> f b
f = Replicator r f b b
forall (p :: * -> * -> *) a. Default p a a => p a a
def'
        def' :: D.Default p a a => p a a
        def' :: p a a
def' = p a a
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

-- Boilerplate that is derivable using generics but I never got round
-- to implementing it.
instance Applicative f => Applicative (Replicator r f a) where
  pure :: a -> Replicator r f a a
pure = (r -> f a) -> Replicator r f a a
forall r (f :: * -> *) a b. (r -> f b) -> Replicator r f a b
Replicator ((r -> f a) -> Replicator r f a a)
-> (a -> r -> f a) -> a -> Replicator r f a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> r -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> r -> f a) -> (a -> f a) -> a -> r -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Replicator r -> f (a -> b)
f <*> :: Replicator r f a (a -> b)
-> Replicator r f a a -> Replicator r f a b
<*> Replicator r -> f a
x = (r -> f b) -> Replicator r f a b
forall r (f :: * -> *) a b. (r -> f b) -> Replicator r f a b
Replicator ((f (a -> b) -> f a -> f b)
-> (r -> f (a -> b)) -> (r -> f a) -> r -> f b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) r -> f (a -> b)
f r -> f a
x)

instance Functor f => P.Profunctor (Replicator r f) where
  dimap :: (a -> b) -> (c -> d) -> Replicator r f b c -> Replicator r f a d
dimap a -> b
_ c -> d
h (Replicator r -> f c
f) = (r -> f d) -> Replicator r f a d
forall r (f :: * -> *) a b. (r -> f b) -> Replicator r f a b
Replicator (((f c -> f d) -> (r -> f c) -> r -> f d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f c -> f d) -> (r -> f c) -> r -> f d)
-> ((c -> d) -> f c -> f d) -> (c -> d) -> (r -> f c) -> r -> f d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> d) -> f c -> f d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) c -> d
h r -> f c
f)

instance Applicative f=> PP.ProductProfunctor (Replicator r f) where
  purePP :: b -> Replicator r f a b
purePP = b -> Replicator r f a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: Replicator r f a (b -> c)
-> Replicator r f a b -> Replicator r f a c
(****) = Replicator r f a (b -> c)
-> Replicator r f a b -> Replicator r f a c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

-- In the real world this would be 'StateT [a] Maybe b' but I don't want to
-- pick up the transformers dependency here
newtype Take a z b = Take ([a] -> Maybe ([a], b))
  deriving a -> Take a z b -> Take a z a
(a -> b) -> Take a z a -> Take a z b
(forall a b. (a -> b) -> Take a z a -> Take a z b)
-> (forall a b. a -> Take a z b -> Take a z a)
-> Functor (Take a z)
forall a b. a -> Take a z b -> Take a z a
forall a b. (a -> b) -> Take a z a -> Take a z b
forall a z a b. a -> Take a z b -> Take a z a
forall a z a b. (a -> b) -> Take a z a -> Take a z b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Take a z b -> Take a z a
$c<$ :: forall a z a b. a -> Take a z b -> Take a z a
fmap :: (a -> b) -> Take a z a -> Take a z b
$cfmap :: forall a z a b. (a -> b) -> Take a z a -> Take a z b
Functor

instance D.Default (Take a) z a where
  def :: Take a z a
def = ([a] -> Maybe ([a], a)) -> Take a z a
forall a z b. ([a] -> Maybe ([a], b)) -> Take a z b
Take (\[a]
as ->
    case [a]
as of
      []      -> Maybe ([a], a)
forall a. Maybe a
Nothing
      (a
a:[a]
as') -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a]
as', a
a))

-- | A type safe generalisation of 'Prelude.take'.  For example
--
-- @
-- > let count = [1..] :: [Int]
-- > takeT count :: Maybe (Int, Int)
-- Just (1,2)
-- > takeT count
--     :: Maybe (Int, Int, (Int, (Int, Int), Int, Int),
--               Const Int Bool, Identity (Int, Int), Tagged String Int)
-- Just (1,2,(3,(4,5),6,7),Const 8,Identity (9,10),Tagged 11)
-- @
takeT :: D.Default (Take a) b b
      => [a]
      -> Maybe b
takeT :: [a] -> Maybe b
takeT = Take a b b -> [a] -> Maybe b
forall a b. Take a b b -> [a] -> Maybe b
takeExplicit Take a b b
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def
  where takeExplicit :: Take a b b -> [a] -> Maybe b
        takeExplicit :: Take a b b -> [a] -> Maybe b
takeExplicit (Take [a] -> Maybe ([a], b)
f) [a]
as = (([a], b) -> b) -> Maybe ([a], b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([a], b) -> b
forall a b. (a, b) -> b
snd ([a] -> Maybe ([a], b)
f [a]
as)

-- More boilerplate
instance Applicative (Take a z) where
  pure :: a -> Take a z a
pure a
x = ([a] -> Maybe ([a], a)) -> Take a z a
forall a z b. ([a] -> Maybe ([a], b)) -> Take a z b
Take (\[a]
as -> ([a], a) -> Maybe ([a], a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
as, a
x))
  Take [a] -> Maybe ([a], a -> b)
f <*> :: Take a z (a -> b) -> Take a z a -> Take a z b
<*> Take [a] -> Maybe ([a], a)
x = ([a] -> Maybe ([a], b)) -> Take a z b
forall a z b. ([a] -> Maybe ([a], b)) -> Take a z b
Take (\[a]
as -> do
    ([a]
as', a -> b
f')  <- [a] -> Maybe ([a], a -> b)
f [a]
as
    ([a]
as'', a
x') <- [a] -> Maybe ([a], a)
x [a]
as'

    ([a], b) -> Maybe ([a], b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
as'', a -> b
f' a
x'))

instance P.Profunctor (Take a) where
  dimap :: (a -> b) -> (c -> d) -> Take a b c -> Take a a d
dimap a -> b
_ c -> d
g (Take [a] -> Maybe ([a], c)
h) = ([a] -> Maybe ([a], d)) -> Take a a d
forall a z b. ([a] -> Maybe ([a], b)) -> Take a z b
Take (((Maybe ([a], c) -> Maybe ([a], d))
-> ([a] -> Maybe ([a], c)) -> [a] -> Maybe ([a], d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe ([a], c) -> Maybe ([a], d))
 -> ([a] -> Maybe ([a], c)) -> [a] -> Maybe ([a], d))
-> ((c -> d) -> Maybe ([a], c) -> Maybe ([a], d))
-> (c -> d)
-> ([a] -> Maybe ([a], c))
-> [a]
-> Maybe ([a], d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([a], c) -> ([a], d)) -> Maybe ([a], c) -> Maybe ([a], d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([a], c) -> ([a], d)) -> Maybe ([a], c) -> Maybe ([a], d))
-> ((c -> d) -> ([a], c) -> ([a], d))
-> (c -> d)
-> Maybe ([a], c)
-> Maybe ([a], d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> d) -> ([a], c) -> ([a], d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) c -> d
g [a] -> Maybe ([a], c)
h)

instance PP.ProductProfunctor (Take a) where
  purePP :: b -> Take a a b
purePP = b -> Take a a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: Take a a (b -> c) -> Take a a b -> Take a a c
(****) = Take a a (b -> c) -> Take a a b -> Take a a c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

newtype Traverse f a b = Traverse { Traverse f a b -> a -> f b
runTraverse :: a -> f b } deriving a -> Traverse f a b -> Traverse f a a
(a -> b) -> Traverse f a a -> Traverse f a b
(forall a b. (a -> b) -> Traverse f a a -> Traverse f a b)
-> (forall a b. a -> Traverse f a b -> Traverse f a a)
-> Functor (Traverse f a)
forall a b. a -> Traverse f a b -> Traverse f a a
forall a b. (a -> b) -> Traverse f a a -> Traverse f a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (f :: * -> *) a a b.
Functor f =>
a -> Traverse f a b -> Traverse f a a
forall (f :: * -> *) a a b.
Functor f =>
(a -> b) -> Traverse f a a -> Traverse f a b
<$ :: a -> Traverse f a b -> Traverse f a a
$c<$ :: forall (f :: * -> *) a a b.
Functor f =>
a -> Traverse f a b -> Traverse f a a
fmap :: (a -> b) -> Traverse f a a -> Traverse f a b
$cfmap :: forall (f :: * -> *) a a b.
Functor f =>
(a -> b) -> Traverse f a a -> Traverse f a b
Functor

-- | Use 'sequenceT' instead.  It has a better name.
traverseT :: D.Default (Traverse f) a b => a -> f b
traverseT :: a -> f b
traverseT = Traverse f a b -> a -> f b
forall (f :: * -> *) a b. Traverse f a b -> a -> f b
runTraverse Traverse f a b
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

-- | Actually, @Sequence@ is a better name for this
type Sequence = Traverse

-- | A higher-order generalisation of 'Data.Traversable.sequenceA'.  For example
--
-- @
-- > sequenceT (print 3110, putStrLn "World") :: IO ((), ())
-- 3110
-- World
-- ((),())
-- @
sequenceT :: D.Default (Sequence f) a b => a -> f b
sequenceT :: a -> f b
sequenceT = Traverse f a b -> a -> f b
forall (f :: * -> *) a b. Traverse f a b -> a -> f b
runTraverse Traverse f a b
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

-- If we used this then inference may get better:
--
--    instance a ~ b => D.Default (Traverse f) (f a) b where
instance D.Default (Traverse f) (f a) a where
  def :: Traverse f (f a) a
def = (f a -> f a) -> Traverse f (f a) a
forall (f :: * -> *) a b. (a -> f b) -> Traverse f a b
Traverse f a -> f a
forall a. a -> a
id

-- Boilerplate that is derivable using generics but I never got round
-- to implementing it.
instance Applicative f => Applicative (Traverse f a) where
  pure :: a -> Traverse f a a
pure = (a -> f a) -> Traverse f a a
forall (f :: * -> *) a b. (a -> f b) -> Traverse f a b
Traverse ((a -> f a) -> Traverse f a a)
-> (a -> a -> f a) -> a -> Traverse f a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> a -> f a) -> (a -> f a) -> a -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Traverse a -> f (a -> b)
f <*> :: Traverse f a (a -> b) -> Traverse f a a -> Traverse f a b
<*> Traverse a -> f a
x = (a -> f b) -> Traverse f a b
forall (f :: * -> *) a b. (a -> f b) -> Traverse f a b
Traverse ((f (a -> b) -> f a -> f b)
-> (a -> f (a -> b)) -> (a -> f a) -> a -> f b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) a -> f (a -> b)
f a -> f a
x)

instance Functor f => P.Profunctor (Traverse f) where
  dimap :: (a -> b) -> (c -> d) -> Traverse f b c -> Traverse f a d
dimap a -> b
g c -> d
h (Traverse b -> f c
f) = (a -> f d) -> Traverse f a d
forall (f :: * -> *) a b. (a -> f b) -> Traverse f a b
Traverse ((a -> b) -> (f c -> f d) -> (b -> f c) -> a -> f d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap a -> b
g ((c -> d) -> f c -> f d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
h) b -> f c
f)

instance Applicative f => PP.ProductProfunctor (Traverse f) where
  purePP :: b -> Traverse f a b
purePP = b -> Traverse f a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: Traverse f a (b -> c) -> Traverse f a b -> Traverse f a c
(****) = Traverse f a (b -> c) -> Traverse f a b -> Traverse f a c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

newtype Zipper a b = Zipper { Zipper a b -> Traverse ZipList a b
unZipper :: Traverse ZipList a b }
  deriving a -> Zipper a b -> Zipper a a
(a -> b) -> Zipper a a -> Zipper a b
(forall a b. (a -> b) -> Zipper a a -> Zipper a b)
-> (forall a b. a -> Zipper a b -> Zipper a a)
-> Functor (Zipper a)
forall a b. a -> Zipper a b -> Zipper a a
forall a b. (a -> b) -> Zipper a a -> Zipper a b
forall a a b. a -> Zipper a b -> Zipper a a
forall a a b. (a -> b) -> Zipper a a -> Zipper a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Zipper a b -> Zipper a a
$c<$ :: forall a a b. a -> Zipper a b -> Zipper a a
fmap :: (a -> b) -> Zipper a a -> Zipper a b
$cfmap :: forall a a b. (a -> b) -> Zipper a a -> Zipper a b
Functor

instance a ~ b => D.Default Zipper [a] b where
  def :: Zipper [a] b
def = Traverse ZipList [a] b -> Zipper [a] b
forall a b. Traverse ZipList a b -> Zipper a b
Zipper (([a] -> ZipList a)
-> (b -> b)
-> Traverse ZipList (ZipList a) b
-> Traverse ZipList [a] b
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap [a] -> ZipList a
forall a. [a] -> ZipList a
ZipList b -> b
forall a. a -> a
id Traverse ZipList (ZipList a) b
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def)

-- { Boilerplate

instance P.Profunctor Zipper where
  dimap :: (a -> b) -> (c -> d) -> Zipper b c -> Zipper a d
dimap a -> b
f c -> d
g = Traverse ZipList a d -> Zipper a d
forall a b. Traverse ZipList a b -> Zipper a b
Zipper (Traverse ZipList a d -> Zipper a d)
-> (Zipper b c -> Traverse ZipList a d) -> Zipper b c -> Zipper a d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b)
-> (c -> d) -> Traverse ZipList b c -> Traverse ZipList a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap a -> b
f c -> d
g (Traverse ZipList b c -> Traverse ZipList a d)
-> (Zipper b c -> Traverse ZipList b c)
-> Zipper b c
-> Traverse ZipList a d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipper b c -> Traverse ZipList b c
forall a b. Zipper a b -> Traverse ZipList a b
unZipper

instance Applicative (Zipper a) where
  pure :: a -> Zipper a a
pure = Traverse ZipList a a -> Zipper a a
forall a b. Traverse ZipList a b -> Zipper a b
Zipper (Traverse ZipList a a -> Zipper a a)
-> (a -> Traverse ZipList a a) -> a -> Zipper a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Traverse ZipList a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Zipper a (a -> b)
f <*> :: Zipper a (a -> b) -> Zipper a a -> Zipper a b
<*> Zipper a a
x = Traverse ZipList a b -> Zipper a b
forall a b. Traverse ZipList a b -> Zipper a b
Zipper (Traverse ZipList a (a -> b)
-> Traverse ZipList a a -> Traverse ZipList a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (Zipper a (a -> b) -> Traverse ZipList a (a -> b)
forall a b. Zipper a b -> Traverse ZipList a b
unZipper Zipper a (a -> b)
f) (Zipper a a -> Traverse ZipList a a
forall a b. Zipper a b -> Traverse ZipList a b
unZipper Zipper a a
x))

instance PP.ProductProfunctor Zipper where
  purePP :: b -> Zipper a b
purePP = b -> Zipper a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: Zipper a (b -> c) -> Zipper a b -> Zipper a c
(****) = Zipper a (b -> c) -> Zipper a b -> Zipper a c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

-- }

-- | A challenge from a Clojurist on Hacker News
-- (https://news.ycombinator.com/item?id=23939350)
--
-- @
-- > cl_map (uncurry (+)) ([1,2,3], [4,5,6])
-- [5,7,9]
--
-- > cl_map (+3) [1,2,3]
-- [4,5,6]
--
-- > let max3 (x, y, z) = x `max` y `max` z
-- > cl_map max3 ([1,20], [3,4], [5,6])
-- [5,20]
-- @
cl_map :: D.Default Zipper a b => (b -> r) -> a -> [r]
cl_map :: (b -> r) -> a -> [r]
cl_map b -> r
f = ZipList r -> [r]
forall a. ZipList a -> [a]
getZipList (ZipList r -> [r]) -> (a -> ZipList r) -> a -> [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> r) -> ZipList b -> ZipList r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> r
f (ZipList b -> ZipList r) -> (a -> ZipList b) -> a -> ZipList r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traverse ZipList a b -> a -> ZipList b
forall (f :: * -> *) a b. Traverse f a b -> a -> f b
runTraverse (Zipper a b -> Traverse ZipList a b
forall a b. Zipper a b -> Traverse ZipList a b
unZipper Zipper a b
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def)