Cassava instances via Generics.SOP

NamedRecords.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module MyLib where

import Data.ByteString (ByteString)
import Data.Csv
    ( Field
    , FromField (..)
    , FromNamedRecord (..)
    , NamedRecord
    , Parser
    , ToField (..)
    , ToNamedRecord (..)
    , namedRecord
    , runParser
    , (.:)
    )
import Data.Functor.Contravariant (Contravariant (..))
import Data.Functor.Invariant (Invariant (..))
import Data.Text (Text)
import Data.Time (parseTimeM)
import Generics.SOP
    ( I (..)
    , IsProductType
    , K (..)
    , NP (..)
    , ProductCode
    , Proxy (..)
    , productTypeFrom
    , productTypeTo
    )
import Generics.SOP.NP
    ( collapse_NP
    , map_NP
    , sequence_NP
    , trans_NP
    , zipWith_NP
    )
import Generics.SOP.TH (deriveGeneric)

import qualified Data.ByteString.Char8 as B
import qualified Data.Time as Time

-- | render to 'Field'
newtype R a = R {unR :: a -> Field}

instance Contravariant R where
    contramap f (R r) = R (r . f)

-- | parser from 'Field'
newtype P a = P {unP :: Field -> Parser a}
    deriving (Functor)

-- | a column level parse and render with column name
data Column a = Column
    { columnName :: ByteString
    -- ^ column name
    , renderColumn :: R a
    -- ^ how to render 'a'
    , parseColumn :: P a
    -- ^ how to parse 'a'
    }

instance Invariant Column where
    invmap f g (Column c r p) =
        Column c (contramap g r) (fmap f p)

getParser :: NamedRecord -> Column a -> Parser a
getParser r (Column c _ (P p)) = r .: c >>= p

getRender :: I a -> Column a -> K (ByteString, Field) a
getRender (I x) (Column c (R f) _) = K (c, f x)

column :: (ToField a, FromField a) => ByteString -> Column a
column c = Column c (R toField) (P parseField)

class IsProductType a (ProductCode a) => GenericsCSV a where
    codec :: Proxy a -> NP Column (ProductCode a)

instance GenericsCSV a => FromNamedRecord a where
    parseNamedRecord :: GenericsCSV a => NamedRecord -> Parser a
    parseNamedRecord r =
        let
            np = codec (Proxy @a)
        in
            productTypeTo <$> sequence_NP (map_NP (getParser r) np)

instance GenericsCSV a => ToNamedRecord a where
    toNamedRecord :: GenericsCSV a => a -> NamedRecord
    toNamedRecord x =
        let
            np = codec (Proxy @a)
            fields = productTypeFrom x
        in
            namedRecord $ collapse_NP (zipWith_NP getRender fields np)

newtype Title = Title ByteString
    deriving newtype (Show, Eq, FromField, ToField)
newtype Author = Author ByteString
    deriving newtype (Show, Eq, FromField, ToField)
newtype ISBN = ISBN ByteString
    deriving newtype (Show, Eq, FromField, ToField)
newtype Day = Day Time.Day
    deriving newtype (Show, Eq)

dayColumn :: ByteString -> Column Day
dayColumn x =
    Column
        { columnName = x
        , renderColumn = R $ \(Day d) ->
            B.pack
                $ Time.formatTime Time.defaultTimeLocale format d
        , parseColumn = P
            $ \f ->
                Day
                    <$> parseTimeM
                        True
                        Time.defaultTimeLocale
                        format
                        (B.unpack f)
        }
  where
    format = "%d/%m/%Y"

data Book where
    Book
        :: { title :: Title
           , author :: Author
           , isbn13 :: ISBN
           , dateAdded :: Day
           }
        -> Book
    deriving stock (Show, Eq)

deriveGeneric ''Book

instance GenericsCSV Book where
    codec _ =
        column "Title"
            :* column "Author"
            :* column "ISBN"
            :* dayColumn "Date Added"
            :* Nil

b0 :: Book
b0 =
    Book
        (Title "foo")
        (Author "bar")
        (ISBN "baz")
        (Day $ Time.fromGregorian 2020 1 1)

roundtrip :: (Eq a, FromNamedRecord a, ToNamedRecord a) => a -> Bool
roundtrip x = runParser (parseNamedRecord (toNamedRecord x)) == Right x

test :: Bool
test = roundtrip b0