national-australia-bank-0.0.7: src/Data/Bank/NationalAustraliaBank/NationalAustraliaBank.hs
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module Data.Bank.NationalAustraliaBank.NationalAustraliaBank where
import Control.Applicative (Alternative((<|>)))
import Control.Lens( Lens', Prism', prism', (#), view, preview, over, _2 )
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.Maybe( fromMaybe )
import Data.Ord( comparing )
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, diffDays, 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 )
-- #setup
-- >>> import Data.Digit
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
diffDates ::
Date
-> Date
-> Integer
diffDates dt1 dt2 =
dateDay dt1 `diffDays` dateDay dt2
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 a =
integralAmount100 a % 100
integralAmount100 ::
Integral a =>
Amount
-> a
integralAmount100 (Amount n ds d1 d2) =
let neg =
if n then (-1) else 1
in neg * (decDigitsIntegral (Right ds) * 100 + decDigitsIntegral (Right (d1 :| [d2])))
-- |
--
-- >>> Amount False (DecDigit1 :| []) DecDigit0 DecDigit0 <> Amount False (DecDigit1 :| []) DecDigit0 DecDigit0
-- Amount {_negated = False, _dollars = DecDigit2 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0}
--
-- >>> Amount True (DecDigit1 :| []) DecDigit0 DecDigit0 <> Amount False (DecDigit1 :| []) DecDigit0 DecDigit0
-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0}
--
-- >>> Amount False (DecDigit1 :| []) DecDigit0 DecDigit0 <> Amount True (DecDigit1 :| []) DecDigit0 DecDigit0
-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0}
--
-- >>> Amount True (DecDigit1 :| [DecDigit2]) DecDigit5 DecDigit9 <> Amount True (DecDigit9 :| []) DecDigit7 DecDigit3
-- Amount {_negated = True, _dollars = DecDigit2 :| [DecDigit2], _cents1 = DecDigit3, _cents2 = DecDigit2}
--
-- >>> Amount False (DecDigit1 :| [DecDigit2]) DecDigit5 DecDigit9 <> Amount True (DecDigit9 :| []) DecDigit7 DecDigit3
-- Amount {_negated = False, _dollars = DecDigit2 :| [], _cents1 = DecDigit8, _cents2 = DecDigit6}
--
-- >>> Amount False (DecDigit1 :| [DecDigit2]) DecDigit5 DecDigit9 <> Amount False (DecDigit9 :| []) DecDigit7 DecDigit3
-- Amount {_negated = False, _dollars = DecDigit2 :| [DecDigit2], _cents1 = DecDigit3, _cents2 = DecDigit2}
instance Semigroup Amount where
a1 <> a2 =
let div10 x = over _2 (fromMaybe DecDigit0 . preview integralDecimal) (divMod x 10)
v :: Integer
v = integralAmount100 a1 + integralAmount100 a2
(as1, c2) = div10 (abs v)
(as2, c1) = div10 as1
in Amount (v < 0) (either id id (integralDecDigits as2)) c1 c2
instance Monoid Amount where
mempty =
Amount False (DecDigit0 :| []) DecDigit0 DecDigit0
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
encodeTransactionNoEmptyField ::
NameEncode Transaction
encodeTransactionNoEmptyField =
contramap _date encodeDate <>
contramap _amount (encodeAmount "Amount") <>
fromString "Account Number" =: contramap _accountNumber 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)