{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE ConstraintKinds            #-}

module Csv
  ( CanCsv
  , CsvError(..)
  , AsCsvError(_CsvError,_CsvIoError, _CsvHeaderParseError, _CsvDecodeErrors)
  , readTransactions
  ) where

import BasePrelude hiding (first, try, words)

import           Control.Error              (headMay, note)
import           Control.Lens               (makeClassyPrisms, (^.),(#))
import           Control.Monad.Error.Hoist  ((<?>),(<%?>))
import           Control.Monad.Except       (MonadError, runExceptT)
import           Control.Monad.TM           ((.>>=.))
import           Control.Monad.Trans        (MonadIO)
import           Data.Bifunctor             (bimap, first)
import qualified Data.ByteString.Char8      as C8
import qualified Data.ByteString.Lazy       as LBS
import qualified Data.ByteString.Lazy.Char8 as LC8
import           Data.Csv                   (FromField (..), FromRecord (..),
                                             HasHeader (NoHeader), decode, (.!))
import qualified Data.Text                  as T
import           Data.Text.Encoding         (decodeUtf8)
import           Data.Time                  (Day, parseTimeM,defaultTimeLocale)
import           Data.Validation            (AccValidation, _AccValidation)
import qualified Data.Vector                as V
import           Text.Parsec                (alphaNum, anyChar, char, choice,
                                             digit, lookAhead, many1, manyTill,
                                             parse, sepEndBy1, space, spaces,
                                             string, try)
import           Text.Parsec.Text           (Parser)

import Types hiding (transactionDesc)
import Utils

data CsvError
  = CsvIoError IOException
  | CsvHeaderParseError String
  | CsvDecodeErrors [String]
  deriving (Eq,Show)
makeClassyPrisms ''CsvError

type CanCsv e m      = ( CanCsvError e m , MonadIO m    )
type CanCsvError e m = ( MonadError e m  , AsCsvError e )

readTransactions :: CanCsv e m => FilePath -> m Transactions
readTransactions fn = do
  lbs <- wrapException (_CsvIoError #) $ (LBS.readFile fn)
  let (headers,csvs) = splitAt 2 . LC8.lines $ lbs
  (name,t,num) <- parseHeader headers
  xactsV <- throwAccValidation (_CsvDecodeErrors #) $ csvs .>>=. decodeCsvLine -- t .>>=. f is fmap fold . traverse f t
  pure $ Transactions name t num xactsV

decodeCsvLine
  :: FromRecord a
  => LBS.ByteString
  -> AccValidation [String] [a]
decodeCsvLine bs =
  (bimap (:[]) toList . decode NoHeader $ bs) ^._AccValidation

parseHeader
  :: (CanCsvError e m, Applicative m)
  => [LBS.ByteString]
  -> m (T.Text,T.Text,Int)
parseHeader hs = do
  h <- headMay hs <?> (_CsvHeaderParseError # "Header Missing")
  let r = parse header (LC8.unpack h) (decodeUtf8 . LBS.toStrict $ h)
  r <%?> ((_CsvHeaderParseError #) . show)
  where
    header = do
      void $ string "\"Account History for Account:\",\""
      name <- manyTill anyChar (try $ string " - ")
      t    <- manyTill anyChar (try $ string " - ")
      num  <- int
      pure (T.pack name,T.pack t,num)

words :: Parser T.Text
words = T.unwords . fmap T.pack <$> sepEndBy1 (many1 alphaNum) space

int :: Parser Int
int = read <$> many1 digit

anyText :: Parser T.Text
anyText = T.pack <$> many anyChar

enumParser :: a -> String -> Parser a
enumParser c s = const c <$> string s

desc :: String -> Parser a -> Parser a
desc s p = string s *> spaces *> p

transactionDesc :: Parser TransactionDesc
transactionDesc = choice
  [ desc "VISA PURCHASE"                   $ fmap VisaPurchase visaPurchaseDesc
  , desc "EFTPOS WDL"                      $ fmap (EftposPurchase . Place) anyText
  , desc "FOREIGN CURRENCY CONVERSION FEE" $ pure ForeignCurrencyConversionFee
  , desc "DIRECT CREDIT"                   $ fmap DirectCredit directCreditDesc
  , string "ATM " *> choice
    [ desc "OPERATOR FEE" $ fmap AtmOperatorFee atmOperatorFeeDesc
    , desc "WITHDRAWAL"   $ fmap AtmWithdrawal place
    ]
  , string "INTERNET TRANSFER " *> choice
    [ desc "CREDIT FROM"   $ fmap InternetTransferCredit (internetTransferDesc "REF NO")
    , desc "DEBIT TO"      $ fmap InternetTransferDebit (internetTransferDesc "REFERENCE NO")
    ]
  ]

visaPurchaseDesc :: Parser VisaPurchaseDesc
visaPurchaseDesc = VisaPurchaseDesc
  -- This one is different because we can't rely on the double space to end things
  -- So lets parse anyChar until we hit space then the DD/MM bit
  <$> (Place . T.pack <$> manyTill anyChar (try . lookAhead $ space >> ddMm))
  <*> (spaces *> ddMm)
  <*> (spaces *> countryCode)
  <*> (spaces *> currencyCode)

directCreditDesc :: Parser DirectCreditDesc
directCreditDesc = DirectCreditDesc
  <$> place
  <*> (spaces *> int)

place :: Parser Place
place = Place <$> words

atmOperatorFeeDesc :: Parser AtmOperatorFeeDesc
atmOperatorFeeDesc = AtmOperatorFeeDesc
  <$> choice [enumParser Withdrawal "WITHDRAWAL"]
  <*> (spaces *> place)

internetTransferDesc :: String -> Parser InternetTransferDesc
internetTransferDesc s = InternetTransferDesc
  <$> int
  <*> (spaces *> string s *> spaces *> anyText)

countryCode :: Parser CountryCode
countryCode = choice
  [ enumParser AU "AU"
  , enumParser US "US"
  ]

currencyCode :: Parser CurrencyCode
currencyCode = choice
  [ enumParser AUD "AUD"
  , enumParser USD "USD"
  ]

ddMm :: Parser DdMm
ddMm = DdMm <$> (int <* char '/') <*> int

instance FromField Currency where
  parseField bs =
    let s    = C8.unpack bs
        sign = bool id (0-) $ isPrefixOf "-" s
    in maybe (fail $ "Invalid currency: " <> s) (pure . Currency . sign)
       . readMaybe
       . filter (/= ',')
       . dropWhile (== '$')
       . dropWhile (== '-')
       $ s

instance FromField TransactionDesc where
  parseField s = either (fail . show) pure $
    parse transactionDesc (C8.unpack s) (decodeUtf8 s)

instance FromField Day where
  parseField s = maybe (fail "Invalid DD/MM/YYYY date") pure $
    parseTimeM True defaultTimeLocale "%d/%m/%Y" (C8.unpack s)

instance FromRecord Transaction where
  parseRecord v
    | V.length v == 4 = Transaction <$> v .! 0 <*> v .! 1 <*> v .! 2 <*> v .! 3
    | otherwise      = fail $ "Invalid number of fields: " <> show (V.length v)
