-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Prod
--
-- Generalize the standard two-functor 'Product' to the product of
-- @n@-functors. Intuitively, this means:
--
-- @
-- 'Product' f g a ~~ (f a, g a)
--
-- 'Prod' '[]        a ~~  Const () a
-- 'Prod' '[f]       a ~~ (f a)
-- 'Prod' '[f, g]    a ~~ (f a, g a)
-- 'Prod' '[f, g, h] a ~~ (f a, g a, h a)
--     ⋮
-- @
----------------------------------------------------------------------------
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Functor.Prod
 {-# DEPRECATED "The module is no longer part of the main api and will be removed " #-}
 ( -- * n-tuples of functors.
    Prod(Unit, Cons)
  , zeroTuple
  , oneTuple
  , fromProduct
  , toProduct

    -- * Flat product of functor products
  , prod

    -- * Lifting functions
  , uncurryn

    -- * Type-level helpers
  , type (++)
  , Curried
  )

where

import Control.Applicative(Alternative(..))
import Data.Functor.Product(Product(..))
import Data.Functor.Classes(Eq1(..), Ord1(..), Show1(..))
import Data.Kind (Type)

import qualified Data.Functor.Classes as FC

-- | Product of n functors.
data Prod :: [k -> Type] -> k -> Type where
  Unit :: Prod '[] a
  Cons :: (f a) -> Prod fs a -> Prod (f ': fs) a

-- | The unit of the product.
zeroTuple :: Prod '[] a
zeroTuple :: Prod '[] a
zeroTuple
  = Prod '[] a
forall k (a :: k). Prod '[] a
Unit

-- | Lift a functor to a 1-tuple.
oneTuple :: f a -> Prod '[f] a
oneTuple :: f a -> Prod '[f] a
oneTuple f a
fa
  = f a -> Prod '[] a -> Prod '[f] a
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons f a
fa Prod '[] a
forall k (a :: k). Prod '[] a
Unit

-- | Conversion from a standard 'Product'
fromProduct :: Product f g a -> Prod '[f, g] a
fromProduct :: Product f g a -> Prod '[f, g] a
fromProduct (Pair f a
fa g a
ga)
  = f a -> Prod '[g] a -> Prod '[f, g] a
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons f a
fa (Prod '[g] a -> Prod '[f, g] a) -> Prod '[g] a -> Prod '[f, g] a
forall a b. (a -> b) -> a -> b
$ g a -> Prod '[] a -> Prod '[g] a
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons g a
ga Prod '[] a
forall k (a :: k). Prod '[] a
Unit

-- | Conversion to a standard 'Product'
toProduct :: Prod '[f, g] a -> Product f g a
toProduct :: Prod '[f, g] a -> Product f g a
toProduct (Cons f a
fa (Cons f a
ga Prod fs a
Unit))
  = f a -> f a -> Product f f a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f a
fa f a
ga


-- | Flat product of products.
prod :: Prod ls a -> Prod rs a -> Prod (ls ++ rs) a
Prod ls a
l prod :: Prod ls a -> Prod rs a -> Prod (ls ++ rs) a
`prod` Prod rs a
r =
  case Prod ls a
l of
    Prod ls a
Unit -> Prod rs a
Prod (ls ++ rs) a
r
    Cons f a
la Prod fs a
l' -> f a -> Prod (fs ++ rs) a -> Prod (f : (fs ++ rs)) a
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons f a
la (Prod fs a
l' Prod fs a -> Prod rs a -> Prod (fs ++ rs) a
forall k (ls :: [k -> *]) (a :: k) (rs :: [k -> *]).
Prod ls a -> Prod rs a -> Prod (ls ++ rs) a
`prod` Prod rs a
r)

-- | Type-level, poly-kinded, list-concatenation.
type family (++) l r :: [k] where
  '[]       ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

-- --------------------------------------------------------------
-- Uncurrying of functions
-- --------------------------------------------------------------

-- | @'Prod' '[f, g, h] a -> r@ is the type of the uncurried form
--   of a function @f a -> g a -> h a -> r@. 'Curried' moves from
--   the former to the later. E.g.
--
-- @
-- 'Curried' ('Prod' '[]  a    -> r) = r a
-- 'Curried' ('Prod' '[f] a    -> r) = f a -> r a
-- 'Curried' ('Prod' '[f, g] a -> r) = f a -> g a -> r a
-- @
type family Curried t  where
  Curried (Prod '[] a -> r a) = r a
  Curried (Prod (f ': fs) a -> r a) = f a -> Curried (Prod fs a -> r a)

-- | Like 'uncurry' but using 'Prod' instead of pairs. Can
--   be thought of as a family of functions:
--
-- @
-- 'uncurryn' :: r a -> 'Prod' '[] a
-- 'uncurryn' :: (f a -> r a) -> 'Prod' '[f] a
-- 'uncurryn' :: (f a -> g a -> r a) -> 'Prod' '[f, g] a
-- 'uncurryn' :: (f a -> g a -> h a -> r a) -> 'Prod' '[f, g, h] a
--         ⋮
-- @
uncurryn :: Curried (Prod fs a -> r a) -> Prod fs a -> r a
uncurryn :: Curried (Prod fs a -> r a) -> Prod fs a -> r a
uncurryn Curried (Prod fs a -> r a)
fun = \case
  Prod fs a
Unit -> r a
Curried (Prod fs a -> r a)
fun
  Cons f a
fa Prod fs a
fs' ->
    let fun' :: Curried (Prod fs a -> r a)
fun' = Curried (Prod fs a -> r a)
f a -> Curried (Prod fs a -> r a)
fun f a
fa
    in Curried (Prod fs a -> r a) -> Prod fs a -> r a
forall k (fs :: [k -> *]) (a :: k) (r :: k -> *).
Curried (Prod fs a -> r a) -> Prod fs a -> r a
uncurryn Curried (Prod fs a -> r a)
fun' Prod fs a
fs'

-- --------------------------------------------------------------
--  Instances
-- --------------------------------------------------------------

-- | Inductively defined instance: @'Functor' ('Prod' '[])@.
instance Functor (Prod '[]) where
  fmap :: (a -> b) -> Prod '[] a -> Prod '[] b
fmap a -> b
_ Prod '[] a
Unit = Prod '[] b
forall k (a :: k). Prod '[] a
Unit

-- | Inductively defined instance: @'Functor' ('Prod' (f ': fs))@.
instance (Functor f, Functor (Prod fs)) => Functor (Prod (f ': fs))  where
  fmap :: (a -> b) -> Prod (f : fs) a -> Prod (f : fs) b
fmap a -> b
f (Cons f a
fa Prod fs a
fas)
    =  f b -> Prod fs b -> Prod (f : fs) b
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
fa) ((a -> b) -> Prod fs a -> Prod fs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Prod fs a
fas)

-- | Inductively defined instance: @'Applicative' ('Prod' '[])@.
instance Applicative (Prod '[]) where
  pure :: a -> Prod '[] a
pure a
_
    = Prod '[] a
forall k (a :: k). Prod '[] a
Unit

  Prod '[] (a -> b)
Unit <*> :: Prod '[] (a -> b) -> Prod '[] a -> Prod '[] b
<*> Prod '[] a
Unit
    = Prod '[] b
forall k (a :: k). Prod '[] a
Unit

-- | Inductively defined instance: @'Applicative' ('Prod' (f ': fs))@.
instance (Applicative f, Applicative (Prod fs)) => Applicative (Prod (f ': fs)) where
  pure :: a -> Prod (f : fs) a
pure a
a
    = f a -> Prod fs a -> Prod (f : fs) a
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (a -> Prod fs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

  Cons f (a -> b)
f Prod fs (a -> b)
fs <*> :: Prod (f : fs) (a -> b) -> Prod (f : fs) a -> Prod (f : fs) b
<*> Cons f a
a Prod fs a
as
    = f b -> Prod fs b -> Prod (f : fs) b
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons (f (a -> b)
f f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
f a
a) (Prod fs (a -> b)
fs Prod fs (a -> b) -> Prod fs a -> Prod fs b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Prod fs a
Prod fs a
as)

-- | Inductively defined instance: @'Alternative' ('Prod' '[])@.
instance Alternative (Prod '[]) where
  empty :: Prod '[] a
empty
    = Prod '[] a
forall k (a :: k). Prod '[] a
Unit

  Prod '[] a
Unit <|> :: Prod '[] a -> Prod '[] a -> Prod '[] a
<|> Prod '[] a
Unit
    = Prod '[] a
forall k (a :: k). Prod '[] a
Unit

-- | Inductively defined instance: @'Alternative' ('Prod' (f ': fs))@.
instance (Alternative f, Alternative (Prod fs)) => Alternative (Prod (f ': fs)) where
  empty :: Prod (f : fs) a
empty
    = f a -> Prod fs a -> Prod (f : fs) a
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons f a
forall (f :: * -> *) a. Alternative f => f a
empty Prod fs a
forall (f :: * -> *) a. Alternative f => f a
empty

  Cons f a
f Prod fs a
fs <|> :: Prod (f : fs) a -> Prod (f : fs) a -> Prod (f : fs) a
<|> Cons f a
g Prod fs a
gs
    = f a -> Prod fs a -> Prod (f : fs) a
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons (f a
f f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
f a
g) (Prod fs a
fs Prod fs a -> Prod fs a -> Prod fs a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Prod fs a
Prod fs a
gs)


-- NB. There are Monad instances for `Data.Functor.Product`, but I'm not convinced they
-- make much sense. In particular, we seem to get a O(n^2) bind.

-- | Inductively defined instance: @'Foldable' ('Prod' '[])@.
instance Foldable (Prod '[]) where
  foldMap :: (a -> m) -> Prod '[] a -> m
foldMap a -> m
_ = Prod '[] a -> m
forall a. Monoid a => a
mempty

-- | Inductively defined instance: @'Foldable' ('Prod' (f ': fs))@.
instance (Foldable f, Foldable (Prod fs)) => Foldable (Prod (f ': fs)) where
  foldMap :: (a -> m) -> Prod (f : fs) a -> m
foldMap a -> m
f (Cons f a
fa Prod fs a
fas)
    = (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f f a
fa m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> Prod fs a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Prod fs a
fas

-- | Inductively defined instance: @'Traversable' ('Prod' '[])@.
instance Traversable (Prod '[]) where
  traverse :: (a -> f b) -> Prod '[] a -> f (Prod '[] b)
traverse a -> f b
_ Prod '[] a
Unit = Prod '[] b -> f (Prod '[] b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prod '[] b
forall k (a :: k). Prod '[] a
Unit

-- | Inductively defined instance: @'Traversable' ('Prod' (f ': fs))@.
instance (Traversable f, Traversable (Prod fs)) => Traversable (Prod (f ': fs)) where
  traverse :: (a -> f b) -> Prod (f : fs) a -> f (Prod (f : fs) b)
traverse a -> f b
f (Cons f a
fa Prod fs a
fas)
    = f b -> Prod fs b -> Prod (f : fs) b
forall k (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons (f b -> Prod fs b -> Prod (f : fs) b)
-> f (f b) -> f (Prod fs b -> Prod (f : fs) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f f a
fa) f (Prod fs b -> Prod (f : fs) b)
-> f (Prod fs b) -> f (Prod (f : fs) b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((a -> f b) -> Prod fs a -> f (Prod fs b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Prod fs a
fas)

-- | Inductively defined instance: @'Eq1' ('Prod' '[])@.
instance Eq1 (Prod '[]) where
  liftEq :: (a -> b -> Bool) -> Prod '[] a -> Prod '[] b -> Bool
liftEq a -> b -> Bool
_ Prod '[] a
Unit Prod '[] b
Unit = Bool
True

-- | Inductively defined instance: @'Eq1' ('Prod' (f ': fs))@.
instance (Eq1 f, Eq1 (Prod fs)) => Eq1 (Prod (f ': fs)) where
  liftEq :: (a -> b -> Bool) -> Prod (f : fs) a -> Prod (f : fs) b -> Bool
liftEq a -> b -> Bool
eq (Cons f a
l Prod fs a
ls) (Cons f b
r Prod fs b
rs)
    = (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq f a
l f b
f b
r Bool -> Bool -> Bool
&& (a -> b -> Bool) -> Prod fs a -> Prod fs b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq Prod fs a
ls Prod fs b
Prod fs b
rs

-- | Inductively defined instance: @'Eq' ('Prod' '[])@.
instance Eq a => Eq (Prod '[] a) where
  == :: Prod '[] a -> Prod '[] a -> Bool
(==) = Prod '[] a -> Prod '[] a -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
FC.eq1

-- | Inductively defined instance: @'Eq' ('Prod' (f ': fs))@.
instance (Eq1 f, Eq a, Eq1 (Prod fs)) => Eq (Prod (f ': fs) a) where
  == :: Prod (f : fs) a -> Prod (f : fs) a -> Bool
(==) = Prod (f : fs) a -> Prod (f : fs) a -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
FC.eq1

-- | Inductively defined instance: @'Ord1' ('Prod' '[])@.
instance Ord1 (Prod '[]) where
  liftCompare :: (a -> b -> Ordering) -> Prod '[] a -> Prod '[] b -> Ordering
liftCompare a -> b -> Ordering
_ Prod '[] a
Unit Prod '[] b
Unit = Ordering
EQ

-- | Inductively defined instance: @'Ord1' ('Prod' (f ': fs))@.
instance (Ord1 f, Ord1 (Prod fs)) => Ord1 (Prod (f ': fs)) where
  liftCompare :: (a -> b -> Ordering)
-> Prod (f : fs) a -> Prod (f : fs) b -> Ordering
liftCompare a -> b -> Ordering
cmp (Cons f a
l Prod fs a
ls) (Cons f b
r Prod fs b
rs)
    = (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp f a
l f b
f b
r Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` (a -> b -> Ordering) -> Prod fs a -> Prod fs b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp Prod fs a
ls Prod fs b
Prod fs b
rs

-- | Inductively defined instance: @'Ord' ('Prod' '[])@.
instance Ord a => Ord (Prod '[] a) where
  compare :: Prod '[] a -> Prod '[] a -> Ordering
compare = Prod '[] a -> Prod '[] a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
FC.compare1

-- | Inductively defined instance: @'Ord' ('Prod' (f ': fs))@.
instance (Ord1 f, Ord a, Ord1 (Prod fs)) => Ord (Prod (f ': fs) a) where
  compare :: Prod (f : fs) a -> Prod (f : fs) a -> Ordering
compare = Prod (f : fs) a -> Prod (f : fs) a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
FC.compare1

-- | Inductively defined instance: @'Show1' ('Prod' '[])@.
instance Show1 (Prod '[]) where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Prod '[] a -> ShowS
liftShowsPrec Int -> a -> ShowS
_ [a] -> ShowS
_ Int
_ Prod '[] a
Unit = String -> ShowS
showString String
"zeroTuple"

-- | Inductively defined instance: @'Show1' ('Prod' (f ': fs))@.
instance (Show1 f, Show1 (Prod fs)) => Show1 (Prod (f ': fs)) where
  liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Prod (f : fs) a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d = \case
    (Cons f a
fa Prod fs a
Unit) ->
      Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"oneTuple " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
11 f a
fa
    (Cons f a
fa Prod fs a
fas)  ->
      Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"oneTuple " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
11 f a
fa
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" `prod` "
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Prod fs a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
0 Prod fs a
fas

-- | Inductively defined instance: @'Show' ('Prod' '[])@.
instance Show a => Show (Prod '[] a) where
  showsPrec :: Int -> Prod '[] a -> ShowS
showsPrec = Int -> Prod '[] a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
FC.showsPrec1

-- | Inductively defined instance: @'Show' ('Prod' (f ': fs))@.
instance (Show1 f, Show a, Show1 (Prod fs)) => Show (Prod (f ': fs) a) where
  showsPrec :: Int -> Prod (f : fs) a -> ShowS
showsPrec = Int -> Prod (f : fs) a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
FC.showsPrec1