{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Utils.Csv
  ( typeCsv, extensionCsv
  , decodeCsv
  , encodeCsv
  , respondCsv, respondCsvDB
  , fileSourceCsv
  , CsvParseError(..)
  , ToNamedRecord(..), FromNamedRecord(..)
  , DefaultOrdered(..)
  , ToField(..), FromField(..)
  , CsvRendered(..)
  , toCsvRendered
  ) where

import Import hiding (Header)

import Data.Csv
import Data.Csv.Conduit

import qualified Data.Conduit.List as C
import qualified Data.Conduit.Combinators as C (sourceLazy)

import qualified Data.Map as Map
import qualified Data.Vector as Vector
import qualified Data.HashMap.Strict as HashMap


deriving instance Typeable CsvParseError
instance Exception CsvParseError


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

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


decodeCsv :: (MonadThrow m, FromNamedRecord csv) => Conduit ByteString m csv
decodeCsv = transPipe throwExceptT $ fromNamedCsv defaultDecodeOptions

encodeCsv :: ( ToNamedRecord csv
             , DefaultOrdered csv
             , Monad m
             )
          => Conduit csv m ByteString
-- ^ Encode a stream of records
--
-- Currently not streaming
encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy

  
respondCsv :: ( ToNamedRecord csv
              , DefaultOrdered csv
              )
           => Source (HandlerT site IO) csv
           -> HandlerT site IO TypedContent
respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk

respondCsvDB :: ( ToNamedRecord csv
                , DefaultOrdered csv
                , YesodPersistRunner site
                )
             => Source (YesodDB site) csv
             -> HandlerT site IO TypedContent
respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk

fileSourceCsv :: ( FromNamedRecord csv
                 , MonadResource m
                 )
              => FileInfo
              -> Source m csv
fileSourceCsv = (.| decodeCsv) . fileSource


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

instance ToWidget UniWorX CsvRendered where
  toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered")
    where
      csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row
                  | columnKey <- Vector.toList csvRenderedHeader
                  ]
                | row <- csvRenderedData
                ]

      headers = decodeUtf8 <$> Vector.toList csvRenderedHeader

toCsvRendered :: forall mono.
                 ( ToNamedRecord (Element mono)
                 , DefaultOrdered (Element mono)
                 , MonoFoldable mono
                 )
              => mono -> CsvRendered
toCsvRendered (otoList -> csvs) = CsvRendered{..}
  where
    csvRenderedHeader = headerOrder (error "not forced" :: Element mono)
    csvRenderedData   = map toNamedRecord csvs