-----------------------------------------------------------------------------
-- |
-- 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 :: forall {k} (a :: k). Prod '[] a
zeroTuple
  = forall {k} (a :: k). Prod '[] a
Unit

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

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

-- | Conversion to a standard 'Product'
toProduct :: Prod '[f, g] a -> Product f g a
toProduct :: forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
Prod '[f, g] a -> Product f g a
toProduct (Cons f a
fa (Cons f a
ga Prod fs a
Unit))
  = 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 :: forall {k} (ls :: [k -> *]) (a :: k) (rs :: [k -> *]).
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
r
    Cons f a
la Prod fs a
l' -> 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' 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 :: 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 = \case
  Prod fs a
Unit -> 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)
fun f a
fa
    in 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 :: forall a b. (a -> b) -> Prod '[] a -> Prod '[] b
fmap a -> b
_ Prod '[] a
Unit = 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 :: forall a b. (a -> b) -> Prod (f : fs) a -> Prod (f : fs) b
fmap a -> b
f (Cons f a
fa Prod fs a
fas)
    =  forall {k} (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
fa) (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 :: forall a. a -> Prod '[] a
pure a
_
    = forall {k} (a :: k). Prod '[] a
Unit

  Prod '[] (a -> b)
Unit <*> :: forall a b. Prod '[] (a -> b) -> Prod '[] a -> Prod '[] b
<*> Prod '[] a
Unit
    = 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 :: forall a. a -> Prod (f : fs) a
pure a
a
    = forall {k} (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

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

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

  Prod '[] a
Unit <|> :: forall a. Prod '[] a -> Prod '[] a -> Prod '[] a
<|> Prod '[] a
Unit
    = 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 :: forall a. Prod (f : fs) a
empty
    = forall {k} (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons forall (f :: * -> *) a. Alternative f => f a
empty forall (f :: * -> *) a. Alternative f => f a
empty

  Cons f a
f Prod fs a
fs <|> :: forall a. Prod (f : fs) a -> Prod (f : fs) a -> Prod (f : fs) a
<|> Cons f a
g Prod fs a
gs
    = forall {k} (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons (f a
f forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
g) (Prod fs a
fs forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 :: forall m a. Monoid m => (a -> m) -> Prod '[] a -> m
foldMap 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 :: forall m a. Monoid m => (a -> m) -> Prod (f : fs) a -> m
foldMap a -> m
f (Cons f a
fa Prod fs a
fas)
    = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f f a
fa forall a. Monoid a => a -> a -> a
`mappend` 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 :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Prod '[] a -> f (Prod '[] b)
traverse a -> f b
_ Prod '[] a
Unit = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall (f :: * -> *) a b.
Applicative f =>
(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)
    = forall {k} (f :: k -> *) (a :: k) (fs :: [k -> *]).
f a -> Prod fs a -> Prod (f : fs) a
Cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> 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) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f 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 :: forall a b. (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 :: forall a b.
(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)
    = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq f a
l f b
r Bool -> Bool -> 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
rs

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

-- | Inductively defined instance: @'Ord1' ('Prod' '[])@.
instance Ord1 (Prod '[]) where
  liftCompare :: forall a b.
(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 :: forall a b.
(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)
    = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp f a
l f b
r forall a. Monoid a => a -> a -> a
`mappend` 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
rs

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

-- | Inductively defined instance: @'Show1' ('Prod' '[])@.
instance Show1 (Prod '[]) where
  liftShowsPrec :: forall a.
(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 :: forall a.
(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 forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"oneTuple " forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"oneTuple " forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" `prod` "
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
FC.showsPrec1