{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}

module Data.Bank.NationalAustraliaBank.NationalAustraliaBank where

import Control.Applicative (Alternative((<|>)))
import Control.Lens( Lens', Prism', prism', (#), view )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.Reader.Class ( MonadReader )
import Control.Monad.Trans.Except ( ExceptT(..) )
import Data.Bool(bool)
import Data.List ( sortBy )
import Data.Functor( Functor(..), (<$>) )
import Data.Functor.Identity ( Identity(..) )
import Data.ByteString(ByteString)
import qualified Data.ByteString.Lazy.UTF8 as L(fromString)
import Data.Digit
    ( charDecimal,
      parseDecimal,
      decDigitsIntegral,
      integralDecDigits,
      integralDecimal,
      DecDigit(DecDigit0) )
import Data.Foldable ( asum, toList )
import Data.List.NonEmpty ( NonEmpty(..), some1 )
import Data.Ord
import Data.String ( IsString(fromString) )
import Data.Sv
    ( parseDecodeFromFile,
      (=:),
      comma,
      ParseOptions(ParseOptions),
      Decode,
      Decode',
      NameEncode,
      Headedness(Headed) )
import qualified Data.Sv.Decode as D
import qualified Data.Sv.Encode as E
import Data.Validation ( toEither )
import Data.Time ( fromGregorian, toGregorian, Day )
import Data.Functor.Contravariant ( Contravariant(contramap) )
import Data.Ratio ( Ratio, (%) )
import System.Directory
    ( doesDirectoryExist,
      listDirectory )
import System.FilePath ( (</>) )
import Text.Parsec
    ( char,
      string,
      try,
      ParsecT,
      Stream )

data Month =
  Jan
  | Feb
  | Mar
  | Apr
  | May
  | Jun
  | Jul
  | Aug
  | Sep
  | Oct
  | Nov
  | Dec
  deriving (Eq, Ord, Show)

class HasMonth a where
  month ::
    Lens' a Month

instance HasMonth Month where
  month =
    id

class AsMonth a where
  _Month ::
    Prism' a Month
  _Jan ::
    Prism' a ()
  _Jan =
    _Month .
      prism'
        (\() -> Jan)
        (\case
            Jan ->
              Just ()
            _ ->
              Nothing)
  _Feb ::
    Prism' a ()
  _Feb =
    _Month .
      prism'
        (\() -> Feb)
        (\case
            Feb ->
              Just ()
            _ ->
              Nothing)
  _Mar ::
    Prism' a ()
  _Mar =
    _Month .
      prism'
        (\() -> Mar)
        (\case
            Mar ->
              Just ()
            _ ->
              Nothing)
  _Apr ::
    Prism' a ()
  _Apr =
    _Month .
      prism'
        (\() -> Apr)
        (\case
            Apr ->
              Just ()
            _ ->
              Nothing)
  _May ::
    Prism' a ()
  _May =
    _Month .
      prism'
        (\() -> May)
        (\case
            May ->
              Just ()
            _ ->
              Nothing)
  _Jun ::
    Prism' a ()
  _Jun =
    _Month .
      prism'
        (\() -> Jun)
        (\case
            Jun ->
              Just ()
            _ ->
              Nothing)
  _Jul ::
    Prism' a ()
  _Jul =
    _Month .
      prism'
        (\() -> Jul)
        (\case
            Jul ->
              Just ()
            _ ->
              Nothing)
  _Aug ::
    Prism' a ()
  _Aug =
    _Month .
      prism'
        (\() -> Aug)
        (\case
            Aug ->
              Just ()
            _ ->
              Nothing)
  _Sep ::
    Prism' a ()
  _Sep =
    _Month .
      prism'
        (\() -> Sep)
        (\case
            Sep ->
              Just ()
            _ ->
              Nothing)
  _Oct ::
    Prism' a ()
  _Oct =
    _Month .
      prism'
        (\() -> Oct)
        (\case
            Oct ->
              Just ()
            _ ->
              Nothing)
  _Nov ::
    Prism' a ()
  _Nov =
    _Month .
      prism'
        (\() -> Nov)
        (\case
            Nov ->
              Just ()
            _ ->
              Nothing)
  _Dec ::
    Prism' a ()
  _Dec =
    _Month .
      prism'
        (\() -> Dec)
        (\case
            Dec ->
              Just ()
            _ ->
              Nothing)

instance AsMonth Month where
  _Month =
    id

parseMonth ::
  Stream s m Char =>
  ParsecT s u m Month
parseMonth =
  asum . fmap try $ [
    Jan <$ string "Jan"
  , Feb <$ string "Feb"
  , Mar <$ string "Mar"
  , Apr <$ string "Apr"
  , May <$ string "May"
  , Jun <$ string "Jun"
  , Jul <$ string "Jul"
  , Aug <$ string "Aug"
  , Sep <$ string "Sep"
  , Oct <$ string "Oct"
  , Nov <$ string "Nov"
  , Dec <$ string "Dec"
  ]

data Date =
  Date {
    _day1 ::
      DecDigit
  , _day2 ::
      DecDigit
  , _month ::
    Month
  , _year1 ::
    DecDigit
  , _year2 ::
    DecDigit
  } deriving (Eq, Show)

class HasDate a where
  date ::
    Lens' a Date
  day1 ::
    Lens' a DecDigit
  day1 =
    date .
    \f (Date d1 d2 m y1 y2) -> fmap (\d1' -> Date d1' d2 m y1 y2) (f d1)
  day2 ::
    Lens' a DecDigit
  day2 =
    date .
    \f (Date d1 d2 m y1 y2) -> fmap (\d2' -> Date d1 d2' m y1 y2) (f d2)
  year1 ::
    Lens' a DecDigit
  year1 =
    date .
    \f (Date d1 d2 m y1 y2) -> fmap (\y1' -> Date d1 d2 m y1' y2) (f y1)
  year2 ::
    Lens' a DecDigit
  year2 =
    date .
    \f (Date d1 d2 m y1 y2) -> fmap (\y2' -> Date d1 d2 m y1 y2') (f y2)

instance HasDate Date where
  date =
    id

instance HasMonth Date where
  month f (Date d1 d2 m y1 y2) =
    fmap (\m' -> Date d1 d2 m' y1 y2) (f m)

class AsDate a where
  _Date ::
    Prism' a Date

instance AsDate Date where
  _Date =
    id

instance Ord Date where
  Date d1 d2 m y1 y2 `compare` Date e1 e2 n z1 z2 =
    let twoDigits a b = decDigitsIntegral (Right (a :| [b]))
        d = twoDigits d1 d2 :: Int
        e = twoDigits e1 e2 :: Int
        y = twoDigits y1 y2 :: Int
        z = twoDigits z1 z2 :: Int
    in  (y, m, d) `compare` (z, n, e)

parseDate ::
  Stream s Identity Char =>
  ParsecT s u Identity Date
parseDate =
  Date <$>
    parseDecimal <*>
    parseDecimal <*
    char ' ' <*>
    parseMonth <*
    char ' ' <*>
    parseDecimal <*>
    parseDecimal

decodeDate ::
  Decode' ByteString Date
decodeDate =
  D.withParsec parseDate

encodeDate ::
  NameEncode Date
encodeDate =
  fromString "Date" =: E.mkEncodeBS (\(Date d1 d2 m y1 y2) ->
    L.fromString (concat [[charDecimal # d1, charDecimal # d2, ' '], show m, [' ', charDecimal # y1], [charDecimal # y2]]))

dayDate ::
  Day
  -> Date
dayDate day =
  let (y, m, d) = toGregorian day
      twodigits x =
        case either id id (integralDecDigits x) of
          h :| [] ->
            (DecDigit0, h)
          h :| i : _ ->
            (h, i)
      (d1, d2) = twodigits d
      m' = case m of
            1 -> Jan
            2 -> Feb
            3 -> Mar
            4 -> Apr
            5 -> May
            6 -> Jun
            7 -> Jul
            8 -> Aug
            9 -> Sep
            10 -> Oct
            11 -> Nov
            _ -> Dec
      (y1, y2) = twodigits (y - 2000)
  in  Date d1 d2 m' y1 y2

dateDay ::
  Date
  -> Day
dateDay (Date d1 d2 m y1 y2) =
  let year = 2000 + integralDecimal # y1 * 10 + integralDecimal # y2
      mon Jan = 1
      mon Feb = 2
      mon Mar = 3
      mon Apr = 4
      mon May = 5
      mon Jun = 6
      mon Jul = 7
      mon Aug = 8
      mon Sep = 9
      mon Oct = 10
      mon Nov = 11
      mon Dec = 12
      dt = integralDecimal # d1 * 10 + integralDecimal # d2
  in  fromGregorian year (mon m) dt

data Amount =
  Amount {
    _negated ::
      Bool
  , _dollars ::
      NonEmpty DecDigit
  , _cents1 ::
      DecDigit
  , _cents2 ::
      DecDigit
  } deriving (Eq, Ord, Show)

class AsAmount a where
  _Amount ::
    Prism' a Amount

instance AsAmount Amount where
  _Amount =
    id

class HasAmount a where
  amount ::
    Lens' a Amount
  negated ::
    Lens' a Bool
  negated =
    amount .
    \f (Amount n d c1 c2) -> fmap (\n' -> Amount n' d c1 c2) (f n)
  dollars ::
    Lens' a (NonEmpty DecDigit)
  dollars =
    amount .
    \f (Amount n d c1 c2) -> fmap (\d' -> Amount n d' c1 c2) (f d)
  cents1 ::
    Lens' a DecDigit
  cents1 =
    amount .
    \f (Amount n d c1 c2) -> fmap (\c1' -> Amount n d c1' c2) (f c1)
  cents2 ::
    Lens' a DecDigit
  cents2 =
    amount .
    \f (Amount n d c1 c2) -> fmap (\c2' -> Amount n d c1 c2') (f c2)

instance HasAmount Amount where
  amount =
    id

parseAmount ::
  Stream s Identity Char =>
  ParsecT s u Identity Amount
parseAmount =
  Amount <$>
    try (True <$ char '-' <|> pure False) <*>
    some1 parseDecimal <*
    char '.' <*>
    parseDecimal <*>
    parseDecimal

decodeAmount ::
  Decode' ByteString Amount
decodeAmount =
  D.withParsec parseAmount

encodeAmount ::
  String
  -> NameEncode Amount
encodeAmount label =
  fromString label =: E.mkEncodeBS (\(Amount n d c1 c2) ->
    L.fromString (concat [bool "" "-" n, fmap (charDecimal #) (toList d), ".", [charDecimal # c1], [charDecimal # c2]]))

realAmount ::
  Integral a =>
  Amount
  -> Ratio a
realAmount (Amount n ds d1 d2) =
  let neg =
        if n then Left else Right
  in  (decDigitsIntegral (neg ds) * 100 + decDigitsIntegral (Right (d1 :| [d2]))) % 100

data Transaction =
  Transaction {
    _date ::
      Date
  , _amount ::
      Amount
  , _accountNumber ::
      String
  , _emptyField ::
      String
  , _transactionType ::
      String
  , _details ::
      String
  , _balance ::
      Amount
  , _category ::
      String
  , _merchantName ::
      String
  } deriving (Eq, Ord, Show)

class AsTransaction a where
  _Transaction ::
    Prism' a Transaction

instance AsTransaction Transaction where
  _Transaction =
    id

class HasTransaction a where
  transaction ::
    Lens' a Transaction
  accountNumber ::
    Lens' a String
  accountNumber =
    transaction .
    \f (Transaction dt am an ef tt dl bl ct mn) -> fmap (\an' -> Transaction dt am an' ef tt dl bl ct mn) (f an)
  emptyField ::
    Lens' a String
  emptyField =
    transaction .
    \f (Transaction dt am an ef tt dl bl ct mn) -> fmap (\ef' -> Transaction dt am an ef' tt dl bl ct mn) (f ef)
  transactionType ::
    Lens' a String
  transactionType =
    transaction .
    \f (Transaction dt am an ef tt dl bl ct mn) -> fmap (\tt' -> Transaction dt am an ef tt' dl bl ct mn) (f tt)
  details ::
    Lens' a String
  details =
    transaction .
    \f (Transaction dt am an ef tt dl bl ct mn) -> fmap (\dl' -> Transaction dt am an ef tt dl' bl ct mn) (f dl)
  balance ::
    Lens' a Amount
  balance =
    transaction .
    \f (Transaction dt am an ef tt dl bl ct mn) -> fmap (\bl' -> Transaction dt am an ef tt dl bl' ct mn) (f bl)
  category ::
    Lens' a String
  category =
    transaction .
    \f (Transaction dt am an ef tt dl bl ct mn) -> fmap (\ct' -> Transaction dt am an ef tt dl bl ct' mn) (f ct)
  merchantName ::
    Lens' a String
  merchantName =
    transaction .
    \f (Transaction dt am an ef tt dl bl ct mn) -> fmap (\mn' -> Transaction dt am an ef tt dl bl ct mn') (f mn)

instance HasTransaction Transaction where
  transaction =
    id

instance HasDate Transaction where
  date f (Transaction dt am an ef tt dl bl ct mn) =
    fmap (\dt' -> Transaction dt' am an ef tt dl bl ct mn) (f dt)

instance HasAmount Transaction where
  amount f (Transaction dt am an ef tt dl bl ct mn) =
    fmap (\am' -> Transaction dt am' an ef tt dl bl ct mn) (f am)

encodeTransaction ::
  NameEncode Transaction
encodeTransaction =
  contramap _date encodeDate <>
  contramap _amount (encodeAmount "Amount") <>
  fromString "Account Number" =: contramap _accountNumber E.string <>
  fromString "" =: contramap _emptyField E.string <>
  fromString "Transaction Type" =: contramap _transactionType E.string <>
  fromString "Transaction Details" =: contramap _details E.string <>
  contramap _balance (encodeAmount "Balance") <>
  fromString "Category" =: contramap _category E.string <>
  fromString "Merchant Name" =: contramap _merchantName E.string

decodeTransaction ::
  Decode ByteString ByteString Transaction
decodeTransaction =
  Transaction <$>
    decodeDate <*>
    decodeAmount <*>
    D.string <*>
    D.string <*>
    D.string <*>
    D.string <*>
    decodeAmount <*>
    D.string <*>
    D.string

date' ::
  MonadReader Transaction f =>
  f Date
date' =
  view date

dateDay' ::
  MonadReader Transaction f =>
  f Day
dateDay' =
  fmap dateDay date'

amount' ::
  MonadReader Transaction f =>
  f Amount
amount' =
  view amount

amountRatio' ::
  (MonadReader Transaction f, Integral b) =>
  f (Ratio b)
amountRatio' =
  fmap realAmount amount'

accountNumber' ::
  MonadReader Transaction f =>
  f String
accountNumber' =
  view accountNumber

emptyField' ::
  MonadReader Transaction f =>
  f String
emptyField' =
  view emptyField

transactionType' ::
  MonadReader Transaction f =>
  f String
transactionType' =
  view transactionType

details' ::
  MonadReader Transaction f =>
  f String
details' =
  view details

balance' ::
  MonadReader Transaction f =>
  f Amount
balance' =
  view balance

balanceRatio' ::
  (MonadReader Transaction f, Integral b) =>
  f (Ratio b)
balanceRatio' =
  fmap realAmount balance'

category' ::
  MonadReader Transaction f =>
  f String
category' =
  view category

merchantName' ::
  MonadReader Transaction f =>
  f String
merchantName' =
  view merchantName

parseTransactionDirectory ::
  MonadIO m =>
  FilePath
  -> ExceptT (D.DecodeErrors ByteString) m [Transaction]
parseTransactionDirectory p =
  let parseCSVDirectory ::
        MonadIO m =>
        Decode' ByteString a
        -> FilePath
        -> ExceptT (D.DecodeErrors ByteString) m [a]
      parseCSVDirectory dec fp =
        let files =
              do  e <- liftIO (doesDirectoryExist fp)
                  if e
                    then
                      do  d <- liftIO (listDirectory fp)
                          pure (fmap (fp </>) d)
                    else
                      pure [fp]
        in  ExceptT $
              do  f <- files
                  x <- mapM (parseDecodeFromFile dec (ParseOptions comma Headed)) f
                  pure (fmap concat (toEither (sequenceA x)))
      sortTransactions ::
        [Transaction]
        -> [Transaction]
      sortTransactions =
        let comp t1 t2 =
              comparing dateDay' t1 t2 <> comparing accountNumber' t1 t2
        in  sortBy comp
  in  fmap sortTransactions (parseCSVDirectory decodeTransaction p)