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

instance RecordCurry ts => RecordCurry (t ': ts) where
  rcurry :: (Rec f (t : ts) -> a) -> CurriedF f (t : ts) a
rcurry Rec f (t : ts) -> a
f f t
x = (Rec f ts -> a) -> CurriedF f ts a
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 f t -> Rec f ts -> Rec f (t : ts)
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f ts
xs))
  {-# INLINABLE rcurry #-}
instance RecordCurry' ts => RecordCurry' (t ': ts) where
  rcurry' :: (Rec Identity (t : ts) -> a) -> Curried (t : ts) a
rcurry' Rec Identity (t : ts) -> a
f t
x = (Rec Identity ts -> a) -> Curried ts a
forall (ts :: [*]) a.
RecordCurry' ts =>
(Rec Identity ts -> a) -> Curried ts a
rcurry' (\Rec Identity ts
xs -> Rec Identity (t : ts) -> a
f (t -> Identity t
forall a. a -> Identity a
Identity t
x Identity t -> Rec Identity ts -> Rec Identity (t : ts)
forall a (f :: a -> *) (r :: a) (rs :: [a]).
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 :: CurriedF f ts a -> Rec f ts -> a
runcurry CurriedF f ts a
x Rec f ts
RNil      = a
CurriedF f ts a
x
runcurry CurriedF f ts a
f (f r
x :& Rec f rs
xs) = CurriedF f rs a -> Rec f rs -> a
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF f ts a
f r -> CurriedF f rs 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' :: Curried ts a -> Rec Identity ts -> a
runcurry' Curried ts a
x Rec Identity ts
RNil               = a
Curried ts a
x
runcurry' Curried ts a
f (Identity r
x :& Rec Identity rs
xs) = Curried rs a -> Rec Identity rs -> a
forall (ts :: [*]) a. Curried ts a -> Rec Identity ts -> a
runcurry' (Curried ts a
r -> Curried rs 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 :: CurriedX f ts a -> XRec f ts -> a
xruncurry CurriedX f ts a
x XRec f ts
RNil = a
CurriedX f ts a
x
xruncurry CurriedX f ts a
f (XData f r
x :& Rec (XData f) rs
xs) = CurriedX f rs a -> Rec (XData f) rs -> a
forall u (f :: u -> *) (ts :: [u]) a.
CurriedX f ts a -> XRec f ts -> a
xruncurry (CurriedX f ts a
HKD f r -> CurriedX f rs a
f (XData f r -> HKD f r
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 :: CurriedX f ts a -> Rec f ts -> a
runcurryX CurriedX f ts a
f = CurriedX f ts a -> XRec f ts -> a
forall u (f :: u -> *) (ts :: [u]) a.
CurriedX f ts a -> XRec f ts -> a
xruncurry CurriedX f ts a
f (XRec f ts -> a) -> (Rec f ts -> XRec f ts) -> Rec f ts -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec f ts -> XRec f ts
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' :: Curried ts a -> Rec f ts -> f a
runcurryA' Curried ts a
f = (Rec Identity ts -> a) -> f (Rec Identity ts) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Curried ts a -> Rec Identity ts -> a
forall (ts :: [*]) a. Curried ts a -> Rec Identity ts -> a
runcurry' Curried ts a
f) (f (Rec Identity ts) -> f a)
-> (Rec f ts -> f (Rec Identity ts)) -> Rec f ts -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. f x -> f (Identity x))
-> Rec f ts -> f (Rec Identity ts)
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 ((x -> Identity x) -> f x -> f (Identity x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> Identity x
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 :: CurriedF g ts a -> Rec (Compose f g) ts -> f a
runcurryA CurriedF g ts a
f = (Rec g ts -> a) -> f (Rec g ts) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CurriedF g ts a -> Rec g ts -> a
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry CurriedF g ts a
f) (f (Rec g ts) -> f a)
-> (Rec (Compose f g) ts -> f (Rec g ts))
-> Rec (Compose f g) ts
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (x :: u). Compose f g x -> f (g x))
-> Rec (Compose f g) ts -> f (Rec g ts)
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 (x :: u). Compose f g x -> f (g x)
forall l (f :: l -> *) k (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 -> *) (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 -> *) (ts :: [u]) a where
  CurriedX f '[] a = a
  CurriedX f (t ': ts) a = HKD f t -> CurriedX f ts a