{-# 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 m = pure $ F RNil
instance ToNamedRecord (F f '[]) where
toNamedRecord m = mempty
instance FromNamedRecord (TF f '[]) where
parseNamedRecord m = pure $ TF RNil
instance ToNamedRecord (TF f '[]) where
toNamedRecord m = 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 {unF :: Rec f xs}
instance (Functor f, KnownSymbol s, FromField (f x), FromNamedRecord (F f xs)) => FromNamedRecord (F f ((s :-> x) ': xs)) where
parseNamedRecord m = do
x <- m .: T.encodeUtf8 (valName @s undefined)
F f <- parseNamedRecord @(F f xs) m
pure $ F $ x :^: f
instance (Functor f, KnownSymbol s, ToField (f x), ToNamedRecord (F f xs)) => ToNamedRecord (F f ((s :-> x) ': xs)) where
toNamedRecord (F (x :^: xs)) = HM.singleton (T.encodeUtf8 (valName @s undefined)) (toField x) <> toNamedRecord (F 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 {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 m = do
x <- m .: T.encodeUtf8 (valName @s undefined)
TF f <- parseNamedRecord @(TF f xs) m
pure $ TF $ x :& f
instance (Functor f, KnownSymbol s, ToField (f (s :-> x)), ToNamedRecord (TF f xs)) => ToNamedRecord (TF f ((s :-> x) ': xs)) where
toNamedRecord (TF (x :& xs)) = HM.singleton (T.encodeUtf8 (valName @s undefined)) (toField x) <> toNamedRecord (TF 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 _ = Data.Vector.fromList []
instance (KnownSymbol s, ToHeader (Rec f xs)) => ToHeader (Rec f (s :-> x ': xs)) where
extractRecHeader Proxy = pure (encodeUtf8 $ valName @s undefined) <> extractRecHeader (Proxy @(Rec f xs))