{-# 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 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
<$ :: forall a b. 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 :: forall a b. (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 = forall r (f :: * -> *) a b. (r -> f b) -> Replicator r f a b
Replicator 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 :: forall r (f :: * -> *) b. Default (Replicator r f) b b => r -> f b
replicateT = r -> f b
f
  where Replicator r -> f b
f = forall (p :: * -> * -> *) a. Default p a a => p a a
def'
        def' :: D.Default p a a => p a a
        def' :: forall (p :: * -> * -> *) a. Default p a a => p a a
def' = 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 :: forall a. a -> Replicator r f a a
pure = forall r (f :: * -> *) a b. (r -> f b) -> Replicator r f a b
Replicator forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Replicator r -> f (a -> b)
f <*> :: forall a b.
Replicator r f a (a -> b)
-> Replicator r f a a -> Replicator r f a b
<*> Replicator r -> f a
x = forall r (f :: * -> *) a b. (r -> f b) -> Replicator r f a b
Replicator (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 :: forall a b c d.
(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) = forall r (f :: * -> *) a b. (r -> f b) -> Replicator r f a b
Replicator ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall b a. b -> Replicator r f a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: forall a b 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 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
<$ :: forall a b. 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 :: forall a b. (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 = forall a z b. ([a] -> Maybe ([a], b)) -> Take a z b
Take (\[a]
as ->
    case [a]
as of
      []      -> forall a. Maybe a
Nothing
      (a
a:[a]
as') -> 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 :: forall a b. Default (Take a) b b => [a] -> Maybe b
takeT = forall a b. Take a b b -> [a] -> Maybe b
takeExplicit forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def
  where takeExplicit :: Take a b b -> [a] -> Maybe b
        takeExplicit :: forall a b. Take a b b -> [a] -> Maybe b
takeExplicit (Take [a] -> Maybe ([a], b)
f) [a]
as = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd ([a] -> Maybe ([a], b)
f [a]
as)

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

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

instance P.Profunctor (Take a) where
  dimap :: forall a b c d. (a -> b) -> (c -> d) -> Take a b c -> Take a a d
dimap a -> b
_ c -> d
g (Take [a] -> Maybe ([a], c)
h) = forall a z b. ([a] -> Maybe ([a], b)) -> Take a z b
Take ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall b a. b -> Take a a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: forall a b 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 { forall (f :: * -> *) a b. Traverse f a b -> a -> f b
runTraverse :: a -> f b } deriving 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
<$ :: forall 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 :: forall a b. (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 :: forall (f :: * -> *) a b. Default (Traverse f) a b => a -> f b
traverseT = forall (f :: * -> *) a b. Traverse f a b -> a -> f b
runTraverse 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 :: forall (f :: * -> *) a b. Default (Traverse f) a b => a -> f b
sequenceT = forall (f :: * -> *) a b. Traverse f a b -> a -> f b
runTraverse 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 = forall (f :: * -> *) a b. (a -> f b) -> Traverse f a b
Traverse 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 :: forall a. a -> Traverse f a a
pure = forall (f :: * -> *) a b. (a -> f b) -> Traverse f a b
Traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Traverse a -> f (a -> b)
f <*> :: forall a b.
Traverse f a (a -> b) -> Traverse f a a -> Traverse f a b
<*> Traverse a -> f a
x = forall (f :: * -> *) a b. (a -> f b) -> Traverse f a b
Traverse (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 :: forall a b c d.
(a -> b) -> (c -> d) -> Traverse f b c -> Traverse f a d
dimap a -> b
g c -> d
h (Traverse b -> f c
f) = forall (f :: * -> *) a b. (a -> f b) -> Traverse f a b
Traverse (forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap a -> b
g (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 :: forall b a. b -> Traverse f a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: forall a b 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 { forall a b. Zipper a b -> Traverse ZipList a b
unZipper :: Traverse ZipList a b }
  deriving 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
<$ :: forall a b. a -> Zipper a b -> Zipper a a
$c<$ :: forall a a b. a -> Zipper a b -> Zipper a a
fmap :: forall a b. (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 = forall a b. Traverse ZipList a b -> Zipper a b
Zipper (forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap forall a. [a] -> ZipList a
ZipList forall a. a -> a
id forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def)

-- { Boilerplate

instance P.Profunctor Zipper where
  dimap :: forall a b c d. (a -> b) -> (c -> d) -> Zipper b c -> Zipper a d
dimap a -> b
f c -> d
g = forall a b. Traverse ZipList a b -> Zipper a b
Zipper forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Zipper a b -> Traverse ZipList a b
unZipper

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

instance PP.ProductProfunctor Zipper where
  purePP :: forall b a. b -> Zipper a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: forall a a b. Zipper a (a -> b) -> Zipper a a -> Zipper a b
(****) = 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 :: forall a b r. Default Zipper a b => (b -> r) -> a -> [r]
cl_map b -> r
f = forall a. ZipList a -> [a]
getZipList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Traverse f a b -> a -> f b
runTraverse (forall a b. Zipper a b -> Traverse ZipList a b
unZipper forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def)