{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Composite.Csv where

import Composite.Record
import Data.Csv
import Data.HashMap.Strict as HM
import Data.Proxy
import Data.Text.Encoding as T
import Data.Vector
import GHC.TypeLits

instance FromNamedRecord (F f '[]) where
  parseNamedRecord :: NamedRecord -> Parser (F f '[])
parseNamedRecord NamedRecord
m = F f '[] -> Parser (F f '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F f '[] -> Parser (F f '[])) -> F f '[] -> Parser (F f '[])
forall a b. (a -> b) -> a -> b
$ Rec f '[] -> F f '[]
forall (f :: * -> *) (xs :: [*]). Rec f xs -> F f xs
F Rec f '[]
forall u (a :: u -> *). Rec a '[]
RNil

instance ToNamedRecord (F f '[]) where
  toNamedRecord :: F f '[] -> NamedRecord
toNamedRecord F f '[]
m = NamedRecord
forall a. Monoid a => a
mempty

instance FromNamedRecord (TF f '[]) where
  parseNamedRecord :: NamedRecord -> Parser (TF f '[])
parseNamedRecord NamedRecord
m = TF f '[] -> Parser (TF f '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TF f '[] -> Parser (TF f '[])) -> TF f '[] -> Parser (TF f '[])
forall a b. (a -> b) -> a -> b
$ Rec f '[] -> TF f '[]
forall (f :: * -> *) (xs :: [*]). Rec f xs -> TF f xs
TF Rec f '[]
forall u (a :: u -> *). Rec a '[]
RNil

instance ToNamedRecord (TF f '[]) where
  toNamedRecord :: TF f '[] -> NamedRecord
toNamedRecord TF f '[]
m = NamedRecord
forall a. Monoid a => a
mempty

-- Newtype helper for DerivingVia `FromNamedRecord` and `ToNamedRecord`. This uses the `FromField` instance
-- on the underlying a in (s :-> a). For the alternative derivation, see `TF`.
--
-- @since 0.0.2.0
newtype F f xs = F {F f xs -> Rec f xs
unF :: Rec f xs}

instance (Functor f, KnownSymbol s, FromField (f x), FromNamedRecord (F f xs)) => FromNamedRecord (F f ((s :-> x) ': xs)) where
  parseNamedRecord :: NamedRecord -> Parser (F f ((s :-> x) : xs))
parseNamedRecord NamedRecord
m = do
    f x
x <- NamedRecord
m NamedRecord -> ByteString -> Parser (f x)
forall a. FromField a => NamedRecord -> ByteString -> Parser a
.: Text -> ByteString
T.encodeUtf8 ((s :-> Any) -> Text
forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> Text
valName @s s :-> Any
forall a. HasCallStack => a
undefined)
    F Rec f xs
f <- NamedRecord -> Parser (F f xs)
forall a. FromNamedRecord a => NamedRecord -> Parser a
parseNamedRecord @(F f xs) NamedRecord
m
    F f ((s :-> x) : xs) -> Parser (F f ((s :-> x) : xs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F f ((s :-> x) : xs) -> Parser (F f ((s :-> x) : xs)))
-> F f ((s :-> x) : xs) -> Parser (F f ((s :-> x) : xs))
forall a b. (a -> b) -> a -> b
$ Rec f ((s :-> x) : xs) -> F f ((s :-> x) : xs)
forall (f :: * -> *) (xs :: [*]). Rec f xs -> F f xs
F (Rec f ((s :-> x) : xs) -> F f ((s :-> x) : xs))
-> Rec f ((s :-> x) : xs) -> F f ((s :-> x) : xs)
forall a b. (a -> b) -> a -> b
$ f x
x f x -> Rec f xs -> Rec f ((s :-> x) : xs)
forall (f :: * -> *) a (rs :: [*]) (s :: Symbol).
Functor f =>
f a -> Rec f rs -> Rec f ((s :-> a) : rs)
:^: Rec f xs
f

instance (Functor f, KnownSymbol s, ToField (f x), ToNamedRecord (F f xs)) => ToNamedRecord (F f ((s :-> x) ': xs)) where
  toNamedRecord :: F f ((s :-> x) : xs) -> NamedRecord
toNamedRecord (F (f x
x :^: Rec f xs
xs)) = ByteString -> ByteString -> NamedRecord
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (Text -> ByteString
T.encodeUtf8 ((s :-> Any) -> Text
forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> Text
valName @s s :-> Any
forall a. HasCallStack => a
undefined)) (f x -> ByteString
forall a. ToField a => a -> ByteString
toField f x
x) NamedRecord -> NamedRecord -> NamedRecord
forall a. Semigroup a => a -> a -> a
<> F f xs -> NamedRecord
forall a. ToNamedRecord a => a -> NamedRecord
toNamedRecord (Rec f xs -> F f xs
forall (f :: * -> *) (xs :: [*]). Rec f xs -> F f xs
F Rec f xs
xs)

-- Newtype helper for DerivingVia `FromNamedRecord` and `ToNamedRecord`. This uses the `FromField` instance on the
-- (s :-> a) field declared as a whole. For the alternative derivation, see `F`.
--
-- @since 0.0.2.0
newtype TF f xs = TF {TF f xs -> Rec f xs
unTF :: Rec f xs}

instance (Functor f, KnownSymbol s, FromField (f (s :-> x)), FromNamedRecord (TF f xs)) => FromNamedRecord (TF f ((s :-> x) ': xs)) where
  parseNamedRecord :: NamedRecord -> Parser (TF f ((s :-> x) : xs))
parseNamedRecord NamedRecord
m = do
    f (s :-> x)
x <- NamedRecord
m NamedRecord -> ByteString -> Parser (f (s :-> x))
forall a. FromField a => NamedRecord -> ByteString -> Parser a
.: Text -> ByteString
T.encodeUtf8 ((s :-> Any) -> Text
forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> Text
valName @s s :-> Any
forall a. HasCallStack => a
undefined)
    TF Rec f xs
f <- NamedRecord -> Parser (TF f xs)
forall a. FromNamedRecord a => NamedRecord -> Parser a
parseNamedRecord @(TF f xs) NamedRecord
m
    TF f ((s :-> x) : xs) -> Parser (TF f ((s :-> x) : xs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TF f ((s :-> x) : xs) -> Parser (TF f ((s :-> x) : xs)))
-> TF f ((s :-> x) : xs) -> Parser (TF f ((s :-> x) : xs))
forall a b. (a -> b) -> a -> b
$ Rec f ((s :-> x) : xs) -> TF f ((s :-> x) : xs)
forall (f :: * -> *) (xs :: [*]). Rec f xs -> TF f xs
TF (Rec f ((s :-> x) : xs) -> TF f ((s :-> x) : xs))
-> Rec f ((s :-> x) : xs) -> TF f ((s :-> x) : xs)
forall a b. (a -> b) -> a -> b
$ f (s :-> x)
x f (s :-> x) -> Rec f xs -> Rec f ((s :-> x) : xs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec f xs
f

instance (Functor f, KnownSymbol s, ToField (f (s :-> x)), ToNamedRecord (TF f xs)) => ToNamedRecord (TF f ((s :-> x) ': xs)) where
  toNamedRecord :: TF f ((s :-> x) : xs) -> NamedRecord
toNamedRecord (TF (f r
x :& Rec f rs
xs)) = ByteString -> ByteString -> NamedRecord
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (Text -> ByteString
T.encodeUtf8 ((s :-> Any) -> Text
forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> Text
valName @s s :-> Any
forall a. HasCallStack => a
undefined)) (f r -> ByteString
forall a. ToField a => a -> ByteString
toField f r
x) NamedRecord -> NamedRecord -> NamedRecord
forall a. Semigroup a => a -> a -> a
<> TF f rs -> NamedRecord
forall a. ToNamedRecord a => a -> NamedRecord
toNamedRecord (Rec f rs -> TF f rs
forall (f :: * -> *) (xs :: [*]). Rec f xs -> TF f xs
TF Rec f rs
xs)

-- | Extracts a `Header` from a composite `Rec` using the symbol names.
--
-- @since 0.0.3.0
class ToHeader x where
  extractRecHeader :: Proxy x -> Vector Name

instance ToHeader (Rec f '[]) where
  extractRecHeader :: Proxy (Rec f '[]) -> Vector ByteString
extractRecHeader Proxy (Rec f '[])
_ = [ByteString] -> Vector ByteString
forall a. [a] -> Vector a
Data.Vector.fromList []

instance (KnownSymbol s, ToHeader (Rec f xs)) => ToHeader (Rec f (s :-> x ': xs)) where
  extractRecHeader :: Proxy (Rec f ((s :-> x) : xs)) -> Vector ByteString
extractRecHeader Proxy (Rec f ((s :-> x) : xs))
Proxy = ByteString -> Vector ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ (s :-> Any) -> Text
forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> Text
valName @s s :-> Any
forall a. HasCallStack => a
undefined) Vector ByteString -> Vector ByteString -> Vector ByteString
forall a. Semigroup a => a -> a -> a
<> Proxy (Rec f xs) -> Vector ByteString
forall x. ToHeader x => Proxy x -> Vector ByteString
extractRecHeader (Proxy (Rec f xs)
forall k (t :: k). Proxy t
Proxy @(Rec f xs))