{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

{-|

Provides combinators for currying and uncurrying functions over arbitrary vinyl
records.

-}
module Data.Vinyl.Curry where
import           Data.Kind (Type)
import           Data.Vinyl
import           Data.Vinyl.Functor
import           Data.Vinyl.XRec

-- * Currying

class RecordCurry ts where
  {-|
  N-ary version of 'curry' over functorial records.

  Example specialized signatures:

  @
  rcurry :: (Rec Maybe '[Int, Double] -> Bool) -> Maybe Int -> Maybe Double -> Bool
  rcurry :: (Rec (Either Int) '[Double, String, ()] -> Int) -> Either Int Double -> Either Int String -> Either Int () -> Int
  rcurry :: (Rec f '[] -> Bool) -> Bool
  @

  -}
  rcurry :: (Rec f ts -> a) -> CurriedF f ts a

class RecordCurry' ts where
  {-|
  N-ary version of 'curry' over pure records.

  Example specialized signatures:

  @
  rcurry' :: (Rec Identity '[Int, Double] -> Bool) -> Int -> Double -> Bool
  rcurry' :: (Rec Identity '[Double, String, ()] -> Int) -> Double -> String -> () -> Int
  rcurry' :: (Rec Identity '[] -> Bool) -> Bool
  @

  -}
  rcurry' :: (Rec Identity ts -> a) -> Curried ts a


instance RecordCurry '[] where
  rcurry :: forall (f :: u -> *) a. (Rec f '[] -> a) -> CurriedF f '[] a
rcurry Rec f '[] -> a
f = Rec f '[] -> a
f forall {u} (f :: u -> *). Rec f '[]
RNil
  {-# INLINABLE rcurry #-}
instance RecordCurry' '[] where
  rcurry' :: forall a. (Rec Identity '[] -> a) -> Curried '[] a
rcurry' Rec Identity '[] -> a
f = Rec Identity '[] -> a
f forall {u} (f :: u -> *). Rec f '[]
RNil
  {-# INLINABLE rcurry' #-}

instance RecordCurry ts => RecordCurry (t ': ts) where
  rcurry :: forall (f :: u -> *) a.
(Rec f (t : ts) -> a) -> CurriedF f (t : ts) a
rcurry Rec f (t : ts) -> a
f f t
x = forall {u} (ts :: [u]) (f :: u -> *) a.
RecordCurry ts =>
(Rec f ts -> a) -> CurriedF f ts a
rcurry (\Rec f ts
xs -> Rec f (t : ts) -> a
f (f t
x forall {u} (f :: u -> *) (r :: u) (rs :: [u]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f ts
xs))
  {-# INLINABLE rcurry #-}
instance RecordCurry' ts => RecordCurry' (t ': ts) where
  rcurry' :: forall a. (Rec Identity (t : ts) -> a) -> Curried (t : ts) a
rcurry' Rec Identity (t : ts) -> a
f t
x = forall (ts :: [*]) a.
RecordCurry' ts =>
(Rec Identity ts -> a) -> Curried ts a
rcurry' (\Rec Identity ts
xs -> Rec Identity (t : ts) -> a
f (forall a. a -> Identity a
Identity t
x forall {u} (f :: u -> *) (r :: u) (rs :: [u]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec Identity ts
xs))
  {-# INLINABLE rcurry' #-}

-- * Uncurrying

{-|
N-ary version of 'uncurry' over functorial records.

Example specialized signatures:

@
runcurry :: (Maybe Int -> Maybe Double -> String) -> Rec Maybe '[Int, Double] -> String
runcurry :: (IO FilePath -> String) -> Rec IO '[FilePath] -> String
runcurry :: Int -> Rec f '[] -> Int
@
-}
runcurry :: CurriedF f ts a -> Rec f ts -> a
runcurry :: forall {u} (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry CurriedF f ts a
x Rec f ts
RNil      = CurriedF f ts a
x
runcurry CurriedF f ts a
f (f r
x :& Rec f rs
xs) = forall {u} (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF f ts a
f f r
x) Rec f rs
xs
{-# INLINABLE runcurry #-}


{-|
N-ary version of 'uncurry' over pure records.

Example specialized signatures:

@
runcurry' :: (Int -> Double -> String) -> Rec Identity '[Int, Double] -> String
runcurry' :: Int -> Rec Identity '[] -> Int
@

Example usage:

@
f :: Rec Identity '[Bool, Int, Double] -> Either Int Double
f = runcurry' $ \b x y -> if b then Left x else Right y
@
-}
runcurry' :: Curried ts a -> Rec Identity ts -> a
runcurry' :: forall (ts :: [*]) a. Curried ts a -> Rec Identity ts -> a
runcurry' Curried ts a
x Rec Identity ts
RNil               = Curried ts a
x
runcurry' Curried ts a
f (Identity r
x :& Rec Identity rs
xs) = forall (ts :: [*]) a. Curried ts a -> Rec Identity ts -> a
runcurry' (Curried ts a
f r
x) Rec Identity rs
xs
{-# INLINABLE runcurry' #-}

-- | Apply an uncurried function to an 'XRec'.
xruncurry :: CurriedX f ts a -> XRec f ts -> a
xruncurry :: forall {u} (f :: u -> *) (ts :: [u]) a.
CurriedX f ts a -> XRec f ts -> a
xruncurry CurriedX f ts a
x Rec (XData f) ts
RNil = CurriedX f ts a
x
xruncurry CurriedX f ts a
f (XData f r
x :& Rec (XData f) rs
xs) = forall {u} (f :: u -> *) (ts :: [u]) a.
CurriedX f ts a -> XRec f ts -> a
xruncurry (CurriedX f ts a
f (forall {k} (t :: k -> *) (a :: k). XData t a -> HKD t a
unX XData f r
x)) Rec (XData f) rs
xs
{-# INLINABLE xruncurry #-}

-- | Apply an uncurried function to a 'Rec' like 'runcurry' except the
-- function enjoys a type simplified by the 'XData' machinery that
-- strips away type-induced noise like 'Identity', 'Compose', and
-- 'ElField'.
runcurryX :: IsoXRec f ts => CurriedX f ts a -> Rec f ts -> a
runcurryX :: forall {u} (f :: u -> *) (ts :: [u]) a.
IsoXRec f ts =>
CurriedX f ts a -> Rec f ts -> a
runcurryX CurriedX f ts a
f = forall {u} (f :: u -> *) (ts :: [u]) a.
CurriedX f ts a -> XRec f ts -> a
xruncurry CurriedX f ts a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (f :: u -> *) (ts :: [u]).
IsoXRec f ts =>
Rec f ts -> XRec f ts
toXRec
{-# INLINE runcurryX #-}

-- * Applicative Combinators

{-|
Lift an N-ary function to work over a record of 'Applicative' computations.

>>> runcurryA' (+) (Just 2 :& Just 3 :& RNil)
Just 5

>>> runcurryA' (+) (Nothing :& Just 3 :& RNil)
Nothing
-}
runcurryA' :: (Applicative f) => Curried ts a -> Rec f ts -> f a
runcurryA' :: forall (f :: * -> *) (ts :: [*]) a.
Applicative f =>
Curried ts a -> Rec f ts -> f a
runcurryA' Curried ts a
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (ts :: [*]) a. Curried ts a -> Rec Identity ts -> a
runcurry' Curried ts a
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
rtraverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity)
{-# INLINE runcurryA' #-}

{-|
Lift an N-ary function over types in @g@ to work over a record of 'Compose'd
'Applicative' computations. A more general version of 'runcurryA''.

Example specialized signatures:

@
runcurryA :: (g x -> g y -> a) -> Rec (Compose Maybe g) '[x, y] -> Maybe a
@
-}
runcurryA :: (Applicative f) => CurriedF g ts a -> Rec (Compose f g) ts -> f a
runcurryA :: forall {u} (f :: * -> *) (g :: u -> *) (ts :: [u]) a.
Applicative f =>
CurriedF g ts a -> Rec (Compose f g) ts -> f a
runcurryA CurriedF g ts a
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {u} (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry CurriedF g ts a
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
rtraverse forall l k (f :: l -> *) (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose
{-# INLINE runcurryA #-}

-- * Curried Function Types

{-|
For the list of types @ts@, @'Curried' ts a@ is a curried function type from
arguments of types in @ts@ to a result of type @a@.

>>> :kind! Curried '[Int, Bool, String] Int
Curried '[Int, Bool, String] Int :: *
= Int -> Bool -> [Char] -> Int
-}
type family Curried ts a where
  Curried '[] a = a
  Curried (t ': ts) a = t -> Curried ts a


{-|
For the type-level list @ts@, @'CurriedF' f ts a@ is a curried function type
from arguments of type @f t@ for @t@ in @ts@, to a result of type @a@.

>>> :kind! CurriedF Maybe '[Int, Bool, String] Int
CurriedF Maybe '[Int, Bool, String] Int :: *
= Maybe Int -> Maybe Bool -> Maybe [Char] -> Int
-}
type family CurriedF (f :: u -> Type) (ts :: [u]) a where
  CurriedF f '[] a = a
  CurriedF f (t ': ts) a = f t -> CurriedF f ts a

{-|
For the type-level list @ts@, @'CurriedX' f ts a@ is a curried function type
from arguments of type @HKD f t@ for @t@ in @ts@, to a result of type @a@.

>>> :set -XTypeOperators
>>> :kind! CurriedX (Maybe :. Identity) '[Int, Bool, String] Int
CurriedX (Maybe :. Identity) '[Int, Bool, String] Int :: *
= Maybe Int -> Maybe Bool -> Maybe [Char] -> Int
-}
type family CurriedX (f :: u -> Type) (ts :: [u]) a where
  CurriedX f '[] a = a
  CurriedX f (t ': ts) a = HKD f t -> CurriedX f ts a