diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +0.0.10 + +* split out modules +* add search report modules + 0.0.9 * Fix `amountReal` to accept function how to handle precision loss. diff --git a/national-australia-bank.cabal b/national-australia-bank.cabal --- a/national-australia-bank.cabal +++ b/national-australia-bank.cabal @@ -1,5 +1,5 @@ name: national-australia-bank -version: 0.0.9 +version: 0.0.10 synopsis: Functions for National Australia Bank transactions description: Parsing, Processing and other functions for National Australia Bank transactions license: BSD3 @@ -21,7 +21,10 @@ library exposed-modules: - Data.Bank.NationalAustraliaBank.NationalAustraliaBank + Data.Bank.NationalAustraliaBank + Data.Bank.NationalAustraliaBank.Report + Data.Bank.NationalAustraliaBank.Search + Data.Bank.NationalAustraliaBank.Transaction build-depends: base >= 4.9 && < 4.15 , bytestring == 0.10.8.2 diff --git a/src/Data/Bank/NationalAustraliaBank.hs b/src/Data/Bank/NationalAustraliaBank.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bank/NationalAustraliaBank.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -Wall #-} + +module Data.Bank.NationalAustraliaBank( + module N +) where + +import Data.Bank.NationalAustraliaBank.Report as N +import Data.Bank.NationalAustraliaBank.Search as N +import Data.Bank.NationalAustraliaBank.Transaction as N diff --git a/src/Data/Bank/NationalAustraliaBank/NationalAustraliaBank.hs b/src/Data/Bank/NationalAustraliaBank/NationalAustraliaBank.hs deleted file mode 100644 --- a/src/Data/Bank/NationalAustraliaBank/NationalAustraliaBank.hs +++ /dev/null @@ -1,859 +0,0 @@ -{-# 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 - --- | --- --- >>> amountRealRound 0 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0} --- --- >>> amountRealRound 0.01 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealRound 0.0123 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealRound (-0.01) --- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealRound (-0.0123) --- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealRound (-12.01) --- Amount {_negated = True, _dollars = DecDigit1 :| [DecDigit2], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealRound (452.99) --- Amount {_negated = False, _dollars = DecDigit4 :| [DecDigit5,DecDigit2], _cents1 = DecDigit9, _cents2 = DecDigit9} --- --- >>> amountRealRound (391233 % 67700) --- Amount {_negated = False, _dollars = DecDigit5 :| [], _cents1 = DecDigit7, _cents2 = DecDigit8} -amountRealRound :: - Integral a => - Ratio a - -> Amount -amountRealRound = - amountReal round - --- | --- --- >>> amountRealTruncate 0 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0} --- --- >>> amountRealTruncate 0.01 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealTruncate 0.0123 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealTruncate (-0.01) --- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealTruncate (-0.0123) --- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealTruncate (-12.01) --- Amount {_negated = True, _dollars = DecDigit1 :| [DecDigit2], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealTruncate (452.99) --- Amount {_negated = False, _dollars = DecDigit4 :| [DecDigit5,DecDigit2], _cents1 = DecDigit9, _cents2 = DecDigit9} --- --- >>> amountRealTruncate (391233 % 67700) --- Amount {_negated = False, _dollars = DecDigit5 :| [], _cents1 = DecDigit7, _cents2 = DecDigit7} -amountRealTruncate :: - Integral a => - Ratio a - -> Amount -amountRealTruncate = - amountReal truncate - --- | --- --- >>> amountRealCeiling 0 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0} --- --- >>> amountRealCeiling 0.01 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealCeiling 0.0123 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit2} --- --- >>> amountRealCeiling (-0.01) --- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealCeiling (-0.0123) --- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealCeiling (-12.01) --- Amount {_negated = True, _dollars = DecDigit1 :| [DecDigit2], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealCeiling (452.99) --- Amount {_negated = False, _dollars = DecDigit4 :| [DecDigit5,DecDigit2], _cents1 = DecDigit9, _cents2 = DecDigit9} --- --- >>> amountRealCeiling (391233 % 67700) --- Amount {_negated = False, _dollars = DecDigit5 :| [], _cents1 = DecDigit7, _cents2 = DecDigit8} -amountRealCeiling :: - Integral a => - Ratio a - -> Amount -amountRealCeiling = - amountReal ceiling - --- | --- --- >>> amountRealFloor 0 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0} --- --- >>> amountRealFloor 0.01 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealFloor 0.0123 --- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealFloor (-0.01) --- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealFloor (-0.0123) --- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit2} --- --- >>> amountRealFloor (-12.01) --- Amount {_negated = True, _dollars = DecDigit1 :| [DecDigit2], _cents1 = DecDigit0, _cents2 = DecDigit1} --- --- >>> amountRealFloor (452.99) --- Amount {_negated = False, _dollars = DecDigit4 :| [DecDigit5,DecDigit2], _cents1 = DecDigit9, _cents2 = DecDigit9} --- --- >>> amountRealFloor (391233 % 67700) --- Amount {_negated = False, _dollars = DecDigit5 :| [], _cents1 = DecDigit7, _cents2 = DecDigit7} -amountRealFloor :: - Integral a => - Ratio a - -> Amount -amountRealFloor = - amountReal floor - -amountReal :: - Num a => - (a -> Integer) - -> a - -> Amount -amountReal loss r = - let div10 x = over _2 (fromMaybe DecDigit0 . preview integralDecimal) (divMod x 10) - n = loss (r * 100) :: Integer - (as1, c2) = div10 (abs n) - (as2, c1) = div10 as1 - in Amount (n < 0) (either id id (integralDecDigits as2)) c1 c2 - -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 = - amountRealTruncate (realAmount a1 + realAmount a2 :: Ratio Integer) - -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) diff --git a/src/Data/Bank/NationalAustraliaBank/Report.hs b/src/Data/Bank/NationalAustraliaBank/Report.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bank/NationalAustraliaBank/Report.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -Wall #-} + +module Data.Bank.NationalAustraliaBank.Report where + +import Data.Bank.NationalAustraliaBank.Transaction + ( Transaction, + Amount, + Date, + diffDates, + realAmount, + date', + amount' ) +import Data.Ratio ( Ratio ) + +cumulativeSumTransactions :: + [Transaction] + -> [Amount] +cumulativeSumTransactions [] = + [] +cumulativeSumTransactions (h:t) = + scanl (\a t' -> amount' t' <> a) (amount' h) t + +cumulativeDays :: + [Transaction] + -> [Integer] +cumulativeDays [] = + [] +cumulativeDays r@(h:_) = + cumulativeDays' (date' h) r + +cumulativeDays' :: + Date + -> [Transaction] + -> [Integer] +cumulativeDays' d = + fmap (\t -> d `diffDates` date' t + 1) + +cumulativePerDay :: + [Transaction] + -> [Ratio Integer] +cumulativePerDay [] = + [] +cumulativePerDay r@(h:_) = + cumulativePerDay' (date' h) r + +cumulativePerDay' :: + Date + -> [Transaction] + -> [Ratio Integer] +cumulativePerDay' dt txs = + zipWith (\a i -> realAmount a / fromInteger i) (cumulativeSumTransactions txs) (cumulativeDays' dt txs) diff --git a/src/Data/Bank/NationalAustraliaBank/Search.hs b/src/Data/Bank/NationalAustraliaBank/Search.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bank/NationalAustraliaBank/Search.hs @@ -0,0 +1,212 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.Bank.NationalAustraliaBank.Search where + +import Control.Applicative ( Alternative(empty) ) +import Control.Monad.Reader.Class ( MonadReader ) +import Data.Bank.NationalAustraliaBank.Transaction + ( Transaction, Date, dateDay, date' ) +import Data.Bool ( bool ) +import Data.Either ( isRight ) +import Data.Functor.Identity ( Identity ) +import Data.List ( isInfixOf ) +import Data.List.NonEmpty ( some1 ) +import Data.Time ( diffDays ) +import Text.Parsec(Stream, ParsecT, Parsec, parse, try, string, char, eof, noneOf) + +fromBool :: + Alternative f => + a + -> Bool + -> f a +fromBool = + bool empty . pure + +predicate :: + (Alternative g, Functor f) => + (a -> Bool) + -> f a + -> x + -> f (g x) +predicate f b x = + fmap (fromBool x . f) b + +contains :: + (Eq a, Functor f, Alternative g) => + [a] + -> f [a] + -> x + -> f (g x) +contains = + predicate . isInfixOf + +notContains :: + (Eq a, Functor f, Alternative g) => + [a] + -> f [a] + -> x + -> f (g x) +notContains a = + predicate (not . isInfixOf a) + +equals :: + (Eq a, Functor f, Alternative g) => + a + -> f a + -> x + -> f (g x) +equals a = + predicate (a ==) + +notEquals :: + (Eq a, Functor f, Alternative g) => + a + -> f a + -> x + -> f (g x) +notEquals a = + predicate (a /=) + +(.&&.) :: + (Eq (g x), Monad f, Alternative g) => + (x -> f (g x)) + -> (x -> f (g x)) + -> (x -> f (g x)) +p .&&. q = + \x -> + p x >>= \g -> bool (q x) (pure g) (g == empty) + +infixr 6 .&&. + +(.||.) :: + (Eq (g x), Monad f, Alternative g) => + (x -> f (g x)) + -> (x -> f (g x)) + -> (x -> f (g x)) +p .||. q = + \x -> + p x >>= \g -> bool (pure g) (q x) (g == empty) + +infixr 5 .||. + +(.|||.) :: + (Monad f, Alternative g, Eq (g x)) => + (a -> b -> x -> f (g x)) + -> (a -> b -> x -> f (g x)) + -> a -> b -> x -> f (g x) +p .|||. q = + \a fa -> + p a fa .||. q a fa + +infixl 9 .|||. + +(~~) :: a -> (a -> b) -> b +(~~) a f = + f a + +infixl 7 ~~ + +($$) :: (a -> b) -> a -> b +($$) = + ($) + +infixl 7 $$ + +($$$) :: + Monoid b => + (a -> b) + -> [a] + -> b +($$$) = + foldMap + +infixl 7 $$$ + +parenthesisedParser :: + Stream s m Char => + String + -> ParsecT s u m () +parenthesisedParser s = + string s *> string " (" *> some1 (noneOf ")") *> char ')' *> eof + +parses :: + (Functor f, Alternative g, Stream s Identity t) => + Parsec s () c + -> f s + -> x + -> f (g x) +parses p = + predicate (isRight . parse (try p) "parses") + +parenthesised :: + (Functor f, Alternative g, Stream s Identity Char) => + String + -> f s + -> x + -> f (g x) +parenthesised = + parses . parenthesisedParser + +dateDiffPredicate :: + (Alternative g, MonadReader Transaction f) => + (Integer -> Bool) + -> Date + -> x + -> f (g x) +dateDiffPredicate p d = + predicate (p . diffDays (dateDay d) . dateDay) date' + +dateEquals :: + (Alternative g, MonadReader Transaction f) => + Date + -> x + -> f (g x) +dateEquals = + dateDiffPredicate (== 0) + +dateAfterIncl :: + (Alternative g, MonadReader Transaction f) => + Date + -> x + -> f (g x) +dateAfterIncl = + dateDiffPredicate (<= 0) + +dateBeforeIncl :: + (Alternative g, MonadReader Transaction f) => + Date + -> x + -> f (g x) +dateBeforeIncl = + dateDiffPredicate (>= 0) + +dateBetweenIncl :: + (Eq (g x), Alternative g, MonadReader Transaction f) => + Date + -> Date + -> x + -> f (g x) +dateBetweenIncl dt1 dt2 = + dateAfterIncl dt1 .&&. dateBeforeIncl dt2 + +(...||) :: + (Monad f, Foldable k, Alternative g, Eq (g x)) => + (a -> f a -> x -> f (g x)) + -> k a -> f a -> x -> f (g x) +f ...|| t = + \v -> + foldr (\a b -> f a v .||. b) (pure (pure empty)) t + +infixl 9 ...|| + +(...&&) :: + (Monad f, Foldable k, Alternative g, Eq (g x)) => + (a -> f a -> x -> f (g x)) + -> k a + -> (f a -> x -> f (g x)) +f ...&& t = + \v x -> + foldr (\a b -> f a v .&&. b) (pure (pure (pure x))) t x + +infixl 9 ...&& diff --git a/src/Data/Bank/NationalAustraliaBank/Transaction.hs b/src/Data/Bank/NationalAustraliaBank/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bank/NationalAustraliaBank/Transaction.hs @@ -0,0 +1,859 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +module Data.Bank.NationalAustraliaBank.Transaction 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 + +-- | +-- +-- >>> amountRealRound 0 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0} +-- +-- >>> amountRealRound 0.01 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealRound 0.0123 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealRound (-0.01) +-- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealRound (-0.0123) +-- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealRound (-12.01) +-- Amount {_negated = True, _dollars = DecDigit1 :| [DecDigit2], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealRound (452.99) +-- Amount {_negated = False, _dollars = DecDigit4 :| [DecDigit5,DecDigit2], _cents1 = DecDigit9, _cents2 = DecDigit9} +-- +-- >>> amountRealRound (391233 % 67700) +-- Amount {_negated = False, _dollars = DecDigit5 :| [], _cents1 = DecDigit7, _cents2 = DecDigit8} +amountRealRound :: + Integral a => + Ratio a + -> Amount +amountRealRound = + amountReal round + +-- | +-- +-- >>> amountRealTruncate 0 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0} +-- +-- >>> amountRealTruncate 0.01 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealTruncate 0.0123 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealTruncate (-0.01) +-- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealTruncate (-0.0123) +-- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealTruncate (-12.01) +-- Amount {_negated = True, _dollars = DecDigit1 :| [DecDigit2], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealTruncate (452.99) +-- Amount {_negated = False, _dollars = DecDigit4 :| [DecDigit5,DecDigit2], _cents1 = DecDigit9, _cents2 = DecDigit9} +-- +-- >>> amountRealTruncate (391233 % 67700) +-- Amount {_negated = False, _dollars = DecDigit5 :| [], _cents1 = DecDigit7, _cents2 = DecDigit7} +amountRealTruncate :: + Integral a => + Ratio a + -> Amount +amountRealTruncate = + amountReal truncate + +-- | +-- +-- >>> amountRealCeiling 0 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0} +-- +-- >>> amountRealCeiling 0.01 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealCeiling 0.0123 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit2} +-- +-- >>> amountRealCeiling (-0.01) +-- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealCeiling (-0.0123) +-- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealCeiling (-12.01) +-- Amount {_negated = True, _dollars = DecDigit1 :| [DecDigit2], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealCeiling (452.99) +-- Amount {_negated = False, _dollars = DecDigit4 :| [DecDigit5,DecDigit2], _cents1 = DecDigit9, _cents2 = DecDigit9} +-- +-- >>> amountRealCeiling (391233 % 67700) +-- Amount {_negated = False, _dollars = DecDigit5 :| [], _cents1 = DecDigit7, _cents2 = DecDigit8} +amountRealCeiling :: + Integral a => + Ratio a + -> Amount +amountRealCeiling = + amountReal ceiling + +-- | +-- +-- >>> amountRealFloor 0 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit0} +-- +-- >>> amountRealFloor 0.01 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealFloor 0.0123 +-- Amount {_negated = False, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealFloor (-0.01) +-- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealFloor (-0.0123) +-- Amount {_negated = True, _dollars = DecDigit0 :| [], _cents1 = DecDigit0, _cents2 = DecDigit2} +-- +-- >>> amountRealFloor (-12.01) +-- Amount {_negated = True, _dollars = DecDigit1 :| [DecDigit2], _cents1 = DecDigit0, _cents2 = DecDigit1} +-- +-- >>> amountRealFloor (452.99) +-- Amount {_negated = False, _dollars = DecDigit4 :| [DecDigit5,DecDigit2], _cents1 = DecDigit9, _cents2 = DecDigit9} +-- +-- >>> amountRealFloor (391233 % 67700) +-- Amount {_negated = False, _dollars = DecDigit5 :| [], _cents1 = DecDigit7, _cents2 = DecDigit7} +amountRealFloor :: + Integral a => + Ratio a + -> Amount +amountRealFloor = + amountReal floor + +amountReal :: + Num a => + (a -> Integer) + -> a + -> Amount +amountReal loss r = + let div10 x = over _2 (fromMaybe DecDigit0 . preview integralDecimal) (divMod x 10) + n = loss (r * 100) :: Integer + (as1, c2) = div10 (abs n) + (as2, c1) = div10 as1 + in Amount (n < 0) (either id id (integralDecDigits as2)) c1 c2 + +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 = + amountRealTruncate (realAmount a1 + realAmount a2 :: Ratio Integer) + +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)