{-# 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 Language.Haskell.TH (Name)
import Language.Haskell.TH.Lib

import Yesod.Core.Content (ContentType, simpleContentType)

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)

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)