NationalAustraliaBank.hs

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

module Data.Bank.NationalAustraliaBank.NationalAustraliaBank where

import Control.Applicative (Applicative(liftA2), Alternative((<|>)))
import Control.Category (Category(..) )
import Control.Lens
    ( view,
      makePrisms,
      (#),
      makeLenses,
      Field1(_1),
      Field2(_2) )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.State
    ( mapM, StateT, gets )
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 ( Foldable, asum, toList )
import Data.List.NonEmpty ( NonEmpty(..), some1 )
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 )
import Prelude hiding (id, (.) )

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

makePrisms ''TransactionMonth

parseTransactionMonth ::
  Stream s m Char =>
  ParsecT s u m TransactionMonth
parseTransactionMonth =
  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 TransactionDate =
  TransactionDate {
    _day1 ::
      DecDigit
  , _day2 ::
      DecDigit
  , _month ::
    TransactionMonth
  , _year1 ::
    DecDigit
  , _year2 ::
    DecDigit
  } deriving (Eq, Show)

makeLenses ''TransactionDate

instance Ord TransactionDate where
  TransactionDate d1 d2 m y1 y2 `compare` TransactionDate 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)

parseTransactionDate ::
  Stream s Identity Char =>
  ParsecT s u Identity TransactionDate
parseTransactionDate =
  TransactionDate <$>
    parseDecimal <*>
    parseDecimal <*
    char ' ' <*>
    parseTransactionMonth <*
    char ' ' <*>
    parseDecimal <*>
    parseDecimal

decodeTransactionDate ::
  Decode' ByteString TransactionDate
decodeTransactionDate =
  D.withParsec parseTransactionDate

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

transactionDayDate ::
  Day
  -> TransactionDate
transactionDayDate 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  TransactionDate d1 d2 m' y1 y2

transactionDateDay ::
  TransactionDate
  -> Day
transactionDateDay (TransactionDate 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 TransactionAmount =
  TransactionAmount {
    _negated ::
      Bool
  , _dollars ::
      NonEmpty DecDigit
  , _cents1 ::
      DecDigit
  , _cents2 ::
      DecDigit
  } deriving (Eq, Ord, Show)

makeLenses ''TransactionAmount

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

decodeTransactionAmount ::
  Decode' ByteString TransactionAmount
decodeTransactionAmount =
  D.withParsec parseTransactionAmount

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

realTransactionAmount ::
  Integral a =>
  TransactionAmount
  -> Ratio a
realTransactionAmount (TransactionAmount 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 ::
      TransactionDate
  , _amount ::
      TransactionAmount
  , _accountNumber ::
      String
  , _emptyField ::
      String
  , _transactionType ::
      String
  , _details ::
      String
  , _balance ::
      TransactionAmount
  , _category ::
      String
  , _merchantName ::
      String
  } deriving (Eq, Ord, Show)

makeLenses ''Transaction

encodeTransaction ::
  NameEncode Transaction
encodeTransaction =
  contramap _date encodeTransactionDate <>
  contramap _amount (encodeTransactionAmount "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 (encodeTransactionAmount "Balance") <>
  fromString "Category" =: contramap _category E.string <>
  fromString "Merchant Name" =: contramap _merchantName E.string

encodeTransactionNormalised ::
  NameEncode Transaction
encodeTransactionNormalised =
  contramap _date encodeTransactionDate <>
  contramap _amount (encodeTransactionAmount "Amount") <>
  fromString "Acc#" =: contramap _accountNumber E.string <>
  fromString "Type" =: contramap _transactionType E.string <>
  fromString "Details" =: contramap _details E.string <>
  contramap _balance (encodeTransactionAmount "Balance") <>
  fromString "Merchant" =: contramap _merchantName E.string

encodeTransactionencodeTransactionNormalisedOtherCat ::
  NameEncode (Transaction, Int)
encodeTransactionencodeTransactionNormalisedOtherCat =
  contramap (view _1) encodeTransactionNormalised <>
  fromString "Other Categories" =: contramap (view _2) E.int

decodeTransaction ::
  Decode ByteString ByteString Transaction
decodeTransaction =
  Transaction <$>
    decodeTransactionDate <*>
    decodeTransactionAmount <*>
    D.string <*>
    D.string <*>
    D.string <*>
    D.string <*>
    decodeTransactionAmount <*>
    D.string <*>
    D.string

type TransactionState f a =
  StateT Transaction f a

foldMap'TransactionState ::
  (Foldable t, Applicative f, Monoid b) =>
  (a -> f b)
  -> t a
  -> f b
foldMap'TransactionState f =
  foldl (\b a -> liftA2 (<>) (f a) b) (pure mempty)

(|>) ::
  (Semigroup a, Applicative f) =>
  f a
  -> f a
  -> f a
s |> t =
  liftA2 (<>) s t

infixr 6 |>

date' ::
  Monad f =>
  TransactionState f TransactionDate
date' =
  gets (view date)

dateDay' ::
  Monad f =>
  TransactionState f Day
dateDay' =
  fmap transactionDateDay date'

amount' ::
  Monad f =>
  TransactionState f TransactionAmount
amount' =
  gets (view amount)

amountRatio' ::
  (Monad f, Integral b) =>
  TransactionState f (Ratio b)
amountRatio' =
  fmap realTransactionAmount amount'

accountNumber' ::
  Monad f =>
  TransactionState f String
accountNumber' =
  gets (view accountNumber)

emptyField' ::
  Monad f =>
  TransactionState f String
emptyField' =
  gets (view emptyField)

transactionType' ::
  Monad f =>
  TransactionState f String
transactionType' =
  gets (view transactionType)

details' ::
  Monad f =>
  TransactionState f String
details' =
  gets (view details)

balance' ::
  Monad f =>
  TransactionState f TransactionAmount
balance' =
  gets (view balance)

balanceRatio' ::
  (Monad f, Integral b) =>
  TransactionState f (Ratio b)
balanceRatio' =
  fmap realTransactionAmount balance'

category' ::
  Monad f =>
  TransactionState f String
category' =
  gets (view category)

merchantName' ::
  Monad f =>
  TransactionState f String
merchantName' =
  gets (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 =
              let d1 =
                    transactionDateDay (view date t1)
                  d2 =
                    transactionDateDay (view date t2)
                  a1 =
                    view accountNumber t1
                  a2 =
                    view accountNumber t2
              in d1 `compare` d2 <> a2 `compare` a1
        in  sortBy comp
  in  fmap sortTransactions (parseCSVDirectory decodeTransaction p)