GenericInstances.hs

{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables  #-}
-- | Generic instances of Csv.ToNamedRecord,
--   and Csv.DefaultOrdered.
--
--   Allow modular treatment of nested records when writing with Cassava.
module Data.Csv.GenericInstances
  ( -- Instances only
  )
where

import            GHC.Generics
import            Data.Typeable
import            Data.Aeson
import            Data.List                   (sort)
import            Data.Aeson.Types            (prependFailure)
import            Control.Applicative
import            Data.Text             as Text
import qualified  Data.ByteString.Char8 as BS
import qualified  Data.Text.Encoding    as Text
import            Data.Vector
import qualified  Data.Foldable         as F
import            Data.Functor.Identity
import qualified  Data.HashMap.Strict   as Map
import            Data.Default
import            Data.Functor.Classes
import qualified  Data.Csv              as Csv

-- * Missing instances of `Data.Csv.ToField class`
instance Csv.ToField [Text] where
  toField = Text.encodeUtf8 . Text.intercalate " "

instance Csv.ToField  Bool where
  toField True  = "yes"
  toField False = "no"

instance Csv.ToField [String] where
  toField aList = " " `BS.intercalate` (BS.pack <$> aList)

-- * Assoc list:
instance Csv.ToField [(Text, Text)] where
  toField ttList = " " `BS.intercalate` Prelude.map (
        \(a, b) ->
          Text.encodeUtf8 $ "=" `Text.intercalate` [a, b]) ttList

instance {-# OVERLAPPABLE #-} Show a => Csv.ToField a where
  toField = BS.pack . show

-- * These instances assume that we use argument for `headerOrder` like `Proxy`
--   (so do not need value at all).
-- Generic Either instance for ToNamedRecord
instance (Csv.DefaultOrdered a
         ,Csv.ToNamedRecord a)
      =>  Csv.ToNamedRecord (Either String a) where
  toNamedRecord (arg :: Either String a) = case arg of
      Left msg  -> Csv.namedRecord (F.foldMap emptyField subHeader)
                <> errorField msg
      Right  r  -> Csv.toNamedRecord r
                <> errorField (""::String)
    where
      subHeader :: Csv.Header
      subHeader = Csv.headerOrder (error "fails in ToNamedRecord (Either String a)" :: a)
      errorField errorMessage = Csv.namedRecord
        [(Data.Vector.head subHeader<>"_error") Csv..= errorMessage]

-- Generic Either instance for ToNamedRecord
instance (Csv.DefaultOrdered a
         ,Csv.ToNamedRecord a)
      =>  Csv.DefaultOrdered (Either String a) where
  headerOrder (_ :: Either String a) = Csv.header [Data.Vector.head subHeader<>"_error"]
                                      <>                              subHeader
    where
      subHeader :: Csv.Header
      subHeader = Csv.headerOrder (error "fails in DefaultOrdered (Either String a)" :: a)

-- Generic Maybe instance for ToNamedRecord
instance (Csv.DefaultOrdered a
         ,Csv.ToNamedRecord a)
      =>  Csv.ToNamedRecord (Maybe a) where
  toNamedRecord (arg :: Maybe a) = case arg of
      Nothing -> Csv.namedRecord (F.foldMap emptyField subHeader)
      Just  r -> Csv.toNamedRecord r
    where
      subHeader :: Csv.Header
      subHeader = Csv.headerOrder (error "fails in ToNamedRecord (Maybe a)" :: a)

-- | Generic Identity instance for ToNamedRecord
instance Csv.ToNamedRecord           a
      => Csv.ToNamedRecord (Identity a) where
  toNamedRecord (Identity a) = Csv.toNamedRecord a

-- | Empty field for generic instances
emptyField name = [name Csv..= ("" :: String)]

instance (Csv.DefaultOrdered a
         ,Csv.ToNamedRecord  a)
      =>  Csv.DefaultOrdered (Maybe a) where
  headerOrder (_ :: Maybe a) = subHeader
    where
      subHeader :: Csv.Header
      subHeader = Csv.headerOrder (error "fails in DefaultOrdered (Maybe a)" :: a)

-- | Generic Identity instance for DefaultOrdered
instance Csv.DefaultOrdered           a
      => Csv.DefaultOrdered (Identity a) where
  headerOrder _ = Csv.headerOrder (undefined :: a)