{-# OPTIONS -fno-warn-orphans #-}

module Utils.Csv
  ( typeCsv, typeCsv', extensionCsv
  , pathPieceCsv
  , (.:??)
  , CsvRendered(..)
  , toCsvRendered
  , toDefaultOrderedCsvRendered
  ) where

import ClassyPrelude hiding (lookup)
import Settings.Mime

import Data.Csv hiding (Name)
import Data.Csv.Conduit (CsvParseError)
import qualified Data.Csv.Incremental as Incremental

import Language.Haskell.TH (Name)
import Language.Haskell.TH.Lib

import Yesod.Core.Content

import qualified Data.Map as Map


deriving instance Typeable CsvParseError
instance Exception CsvParseError


typeCsv, typeCsv' :: ContentType
typeCsv = simpleContentType typeCsv'
typeCsv' = "text/csv; charset=UTF-8; header=present"

extensionCsv :: Extension
extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]


pathPieceCsv :: Name -> DecsQ
pathPieceCsv (conT -> t) =
  [d|
    instance ToField $(t) where
      toField = toField . toPathPiece
    instance FromField $(t) where
      parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField
  |]


(.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a)
m .:?? name = lookup m name <|> return Nothing


data CsvRendered = CsvRendered
  { csvRenderedHeader :: Header
  , csvRenderedData :: [NamedRecord]
  } deriving (Eq, Read, Show, Generic, Typeable)

instance ToContent CsvRendered where
  toContent CsvRendered{..} = toContent . Incremental.encodeByName csvRenderedHeader $ foldr ((<>) . Incremental.encodeNamedRecord) mempty csvRenderedData

instance ToTypedContent CsvRendered where
  toTypedContent = TypedContent
    <$> getContentType . Identity
    <*> toContent

instance HasContentType CsvRendered where
  getContentType _ = typeCsv'

toCsvRendered :: forall mono.
                 ( ToNamedRecord (Element mono)
                 , MonoFoldable mono
                 )
              => Header
              -> mono -> CsvRendered
toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..}
  where
    csvRenderedData   = map toNamedRecord csvs

toDefaultOrderedCsvRendered :: forall mono.
                               ( ToNamedRecord (Element mono)
                               , DefaultOrdered (Element mono)
                               , MonoFoldable mono
                               )
                            => mono -> CsvRendered
toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono)