diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Adam Wick + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Adam Wick nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} +import Control.Monad(replicateM) +import Data.Attoparsec.Text(Parser) +import Data.Attoparsec.Text.Lazy(Result(..),parse) +import Data.Char(isPrint) +import Data.QIF +import Data.String(fromString) +import qualified Data.Text as S +import Data.Text.Lazy(Text) +import Data.Text.Lazy.Builder(Builder, toLazyText) +import Data.Time(Day(..), fromGregorian, addDays) +import Test.QuickCheck +import Test.Tasty(TestTree, testGroup, defaultMain) +import Test.Tasty.HUnit(testCase, (@=?)) +import Test.Tasty.QuickCheck(testProperty) + +import Debug.Trace + +main :: IO () +main = defaultMain $ testGroup "All Tests" [ + testBasics + , testBlocks + , testLists + ] + +-- ----------------------------------------------------------------------------- + +testBasics :: TestTree +testBasics = + testGroup "Basic constants" [ + testQuantities + , testDates + , testSecurityType + ] + +testQuantities :: TestTree +testQuantities = + testGroup "Simple Quantities" [ + testGroup "Currency" [ + testCase "1.25" (1.25 @=? (runP parseCurrency "1.25")) + , testCase "$1.25" (1.25 @=? (runP parseCurrency "$1.25")) + , testCase "-1.25" (-1.25 @=? (runP parseCurrency "-1.25")) + , testCase "-$1.25" (-1.25 @=? (runP parseCurrency "-$1.25")) + , testCase "-$1.2" (-1.2 @=? (runP parseCurrency "-$1.2")) + , testCase "-$1." (-1 @=? (runP parseCurrency "-$1.")) + , testCase "-1" (-1 @=? (runP parseCurrency "-1")) + , testCase "-1.2" (-1.2 @=? (runP parseCurrency "-1.2")) + , testCase "-1.0" (-1 @=? (runP parseCurrency "-1.0")) + , testCase "1.1" (1.1 @=? (runP parseCurrency "1.1")) + , testCase "1." (1 @=? (runP parseCurrency "1.")) + , testProperty "Currency Serialization" currencySerialization + ], + testGroup "Share Quantities" [ + testCase "-3.0351" (-3.0351 @=? (runP parseShareQuantity "-3.0351")) + , testCase "-3.035" (-3.035 @=? (runP parseShareQuantity "-3.035")) + , testCase "-3.03" (-3.03 @=? (runP parseShareQuantity "-3.03")) + , testCase "-3.3" (-3.3 @=? (runP parseShareQuantity "-3.3")) + , testCase "-3." (-3 @=? (runP parseShareQuantity "-3.")) + , testCase "-3" (-3 @=? (runP parseShareQuantity "-3")) + , testCase "3.0351" (3.0351 @=? (runP parseShareQuantity "3.0351")) + , testCase "3.035" (3.035 @=? (runP parseShareQuantity "3.035")) + , testCase "3.03" (3.03 @=? (runP parseShareQuantity "3.03")) + , testCase "3.3" (3.3 @=? (runP parseShareQuantity "3.3")) + , testCase "3." (3 @=? (runP parseShareQuantity "3.")) + , testCase "3" (3 @=? (runP parseShareQuantity "3")) + , testProperty "Share quantity serialization" + (standardSerializer parseShareQuantity renderShareQuantity) + ] + ] + +testDates :: TestTree +testDates = testGroup "Dates" [ + testCase "12/12/15" (fromGregorian 2015 12 12 @=? runP parseDate "12/12/15") + , testCase "5/14/15" (fromGregorian 2015 5 14 @=? runP parseDate "5/14/15") + , testCase "3/4/00" (fromGregorian 2000 3 4 @=? runP parseDate "3/4/00") + , testCase "10/5/13" (fromGregorian 2013 10 5 @=? runP parseDate "10/5/13") + , testProperty "Date serialization" + (standardSerializer parseDate renderDate) + ] + +testSecurityType :: TestTree +testSecurityType = testGroup "Security types" [ + testCase "Stock Option" + (StockOption @=? runP parseSecurityType "Stock Option") + , testCase "Bond" + (Bond @=? runP parseSecurityType "Bond") + , testCase "CD" + (CD @=? runP parseSecurityType "CD") + , testCase "Mutual Fund" + (MutualFund @=? runP parseSecurityType "Mutual Fund") + , testCase "Index" + (Index @=? runP parseSecurityType "Index") + , testCase "ETF" + (ETF @=? runP parseSecurityType "ETF") + , testCase "Money Market Fund" + (MoneyMarket @=? runP parseSecurityType "Money Market Fund") + , testCase "Precious Metal" + (PreciousMetal @=? runP parseSecurityType "Precious Metal") + , testCase "Commodity" + (Commodity @=? runP parseSecurityType "Commodity") + , testCase "Stock" + (Stock @=? runP parseSecurityType "Stock") + , testProperty "Security type serialization" + (standardSerializer parseSecurityType renderSecurityType) + ] + +-- ----------------------------------------------------------------------------- + +testBlocks :: TestTree +testBlocks = + testGroup "Standard Blocks" [ + testSecurity + , testAccount + , testCategory + , testTransaction + , testInvTransaction + ] + +testSecurity :: TestTree +testSecurity = + testGroup "Security Block" [ + testCase "Alaska Airlines" + (Security "Alaska Air Group, Inc" "ALK" Stock Nothing @=? + runP parseSecurity "NAlaska Air Group, Inc\nSALK\nTStock\n^\n") + , testCase "Vanguard S&P" + (Security "Vanguard S&P 500 Index,Investor Shares" "VFINX" + MutualFund Nothing + @=? + runP parseSecurity + "NVanguard S&P 500 Index,Investor Shares\nSVFINX\nTMutual Fund\n^\n") + , testCase "Vanguard ETF" + (Security "Vanguard ETF" "VET" ETF (Just "House") @=? + runP parseSecurity "NVanguard ETF\nSVET\nTETF\nGHouse\n^\n") + , testProperty "Security block serialization" + (standardSerializer parseSecurity renderSecurity) + ] + +testAccount :: TestTree +testAccount = + testGroup "Accounts" [ + testCase "Umpqua Account" + (Account "Umpqua Bank" BankAccount "Checking" Nothing Nothing 1234.12 @=? + runP parseAccount "NUmpqua Bank\nDChecking\nX\nTBank\nB$1234.12\n^\n") + , testCase "Blue Bank" + (Account "Blue Bank" CreditCardAccount "" (Just 40) + (Just (fromGregorian 2012 2 14)) (-520) + @=? + runP parseAccount + "NBlue Bank\nD\nX\nTCCard\n/2/14/12\nL40.0\nB-$520.\n^\n") + , testProperty "Account serialization" + (standardSerializer parseAccount renderAccount) + , testProperty "Account header serialization" + (standardSerializer parseAccountHeader renderAccountHeader) + ] + +testCategory :: TestTree +testCategory = + testGroup "Categories" [ + testCase "Auto" + (Category "Auto" "Automobile-related expenses" Expense False Nothing Nothing @=? + runP parseCategory "NAuto\nDAutomobile-related expenses\nE\n^\n") + , testCase "Registration" + (Category "Registration" "" Expense True Nothing (Just 535) @=? + runP parseCategory "NRegistration\nD\nT\nE\nR535\n^\n") + , testCase "Salary" + (Category "Salary" "Income" Income True Nothing Nothing @=? + runP parseCategory "NSalary\nDIncome\nT\nI\n^\n") + , testCase "Dinner" + (Category "Dinner" "Yum yum" Expense False (Just 200) Nothing @=? + runP parseCategory "NDinner\nDYum yum\nE\nB200.\n^\n") + , testProperty "Category serialization" + (standardSerializer parseCategory renderCategory) + ] + +testTransaction :: TestTree +testTransaction = + testGroup "Transactions" [ + testCase "Roost" + (Transaction (fromGregorian 2012 2 14) "Roost" "Yay fun" (-25) Nothing + (Just "Dining") True False [] @=? + (runP parseTransaction + "D2/14/12\nPRoost\nMYay fun\nT-25\nCX\nLDining\n^\n")) + , testCase "Uncleared Roost" + (Transaction (fromGregorian 2012 2 14) "Roost" "Yay fun" (-25) Nothing + (Just "Dining") False False [] @=? + (runP parseTransaction + "D2/14/12\nPRoost\nMYay fun\nT-25.\nLDining\n^\n")) + , testCase "Business Roost" + (Transaction (fromGregorian 2012 2 14) "Roost" "Yay fun" (-25) Nothing + (Just "Dining") True True [] @=? + (runP parseTransaction + "D2/14/12\nPRoost\nMYay fun\nT-25.00\nCX\nF\nLDining\n^\n")) + , testCase "Paycheck" + (Transaction (fromGregorian 2018 3 4) "Galois" "" 50 Nothing Nothing + True False [SplitItem "" (-30) "Checking", + SplitItem "" (-20) "Savings"] @=? + (runP parseTransaction + "D3/4/18\nPGalois\nM\nT50.0\nCX\nSChecking\nE\n$-30.0\nSSavings\nE\n$-20\n^\n")) + , testProperty "Transaction serialization" + (standardSerializer parseTransaction renderTransaction) + ] + +testInvTransaction :: TestTree +testInvTransaction = + testGroup "Interest Transactions" [ + testCase "Dividend" + (Dividend (TradeInfo (fromGregorian 2065 7 7) "SEC" Nothing (Just 0) (Just 0) 0) + @=? + (runP parseInvTransaction + "D7/7/65\nNDiv\nYSEC\nQ0\nO0.00\nT0\n^\n")) + , testCase "Dividend, with share price" + (Dividend (TradeInfo (fromGregorian 2065 7 7) "SEC" (Just 0) (Just 0) (Just 0) 0) + @=? + (runP parseInvTransaction + "D7/7/65\nNDiv\nYSEC\nI0\nQ0\nO0.00\nT0\n^\n")) + , testProperty "Interest transaction serialization" + (standardSerializer parseInvTransaction renderInvTransaction) + ] + +-- ----------------------------------------------------------------------------- + +testLists :: TestTree +testLists = + testGroup "Lists of structures" [ + testProperty "Account List" + (standardSerializer parseAccountList renderAccountList) + , testProperty "Category List" + (standardSerializer parseCategoryList renderCategoryList) + , testProperty "Investment Entries" + (standardSerializer parseInvestmentEntries renderInvestmentEntries) + , testProperty "Bank Entries" + (standardSerializer parseTransactionList renderTransactionList) + , testProperty "Credit Card Entries" + (standardSerializer parseCreditCardEntryList renderCreditCardEntryList) + , testProperty "Asset Entries" + (standardSerializer parseAssetEntryList renderAssetEntryList) + , testProperty "Liability Entries" + (standardSerializer parseLiabilityEntryList renderLiabilityEntryList) + , testProperty "Security list" + (standardSerializer parseSecurityList renderSecurityList) + ] + +-- ----------------------------------------------------------------------------- + +currencySerialization :: Bool -> Currency -> Property +currencySerialization doDollar amt = + amt === (runP parseCurrency (runR (renderCurrency doDollar) amt)) + +standardSerializer :: (Eq a, Show a) => + Parser a -> (a -> Builder) -> + a -> + Property +standardSerializer parser renderer x = + x === (runP parser (runR renderer x)) + +-- ----------------------------------------------------------------------------- + +runP :: Parser a -> Text -> a +runP parser txt = go (parse parser txt) + where + go (Fail _ _ err) = error ("Parser error: " ++ err) + go (Done _ res) = res + +runR :: (a -> Builder) -> a -> Text +runR builder v = toLazyText (builder v) + +-- ----------------------------------------------------------------------------- + +instance Arbitrary Day where + arbitrary = + do let base = fromGregorian 2000 1 1 + x <- choose (0, 36524) + return (addDays x base) + +instance Arbitrary SecurityType where + arbitrary = elements [ Stock, Bond, CD, MutualFund, Index, ETF, MoneyMarket, + PreciousMetal, Commodity, StockOption, Other ] + +instance Arbitrary Security where + arbitrary = Security <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + +instance Arbitrary S.Text where + arbitrary = + do len <- choose (0,150) + chrs <- replicateM len (suchThat arbitrary isPrint) + return (fromString chrs) + +instance Arbitrary AccountType where + arbitrary = elements [ BankAccount, CashAccount, CreditCardAccount, + InvestmentAccount, AssetAccount, LiabilityAccount ] + +instance Arbitrary Account where + arbitrary = Account <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Category where + arbitrary = Category <$> arbitrary <*> arbitrary <*> elements [Income,Expense] + <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary TradeInfo where + arbitrary = TradeInfo <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary TransferInfo where + arbitrary = TransferInfo <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + +instance Arbitrary InvTransaction where + arbitrary = oneof [ Buy <$> arbitrary + , Sell <$> arbitrary + , Transfer <$> arbitrary + , Dividend <$> arbitrary + , Interest <$> arbitrary <*> arbitrary + ] + +instance Arbitrary SplitItem where + arbitrary = SplitItem <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Transaction where + arbitrary = Transaction <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary diff --git a/qif.cabal b/qif.cabal new file mode 100644 --- /dev/null +++ b/qif.cabal @@ -0,0 +1,51 @@ +name: qif +version: 1.0.0 +synopsis: A simple QIF file format parser / printer +description: A handy little library for dealing with this awful little + QIF files in your life. +homepage: https://github.com/acw/qif +license: BSD3 +license-file: LICENSE +author: Adam Wick +maintainer: awick@uhsure.com +copyright: 2016 +category: Finance +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2 + +library + default-language: Haskell2010 + exposed-modules: Data.QIF + other-extensions: OverloadedStrings, + TemplateHaskell + hs-source-dirs: src + ghc-options: -Wall + build-depends: + attoparsec >= 0.13 && < 0.15, + base >= 4.7 && < 4.10, + microlens >= 0.4.7 && < 0.6, + microlens-th >= 0.4.1 && < 0.6, + text >= 1.2.2 && < 1.9, + time >= 1.7.0 && < 1.9 + +test-suite test-qif-serialization + type: exitcode-stdio-1.0 + main-is: Test.hs + default-language: Haskell2010 + other-extensions: OverloadedStrings + build-depends: + attoparsec >= 0.13 && < 0.15, + base >= 4.7 && < 4.10, + QuickCheck >= 2.9 && < 3.0, + tasty >= 0.11 && < 0.15, + tasty-hunit >= 0.9 && < 0.12, + tasty-quickcheck >= 0.8 && < 0.12, + text >= 1.2.2 && < 1.9, + time >= 1.7.0 && < 1.9, + qif + +source-repository head + type: git + location: https://github.com/acw/qif.git + diff --git a/src/Data/QIF.hs b/src/Data/QIF.hs new file mode 100644 --- /dev/null +++ b/src/Data/QIF.hs @@ -0,0 +1,744 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.QIF + where + +import Control.Monad(when) +import Data.Attoparsec.Text(Parser,char,choice,decimal,digit, + endOfInput,endOfLine,inClass,many', + many1,option,satisfy,string) +import qualified Data.Attoparsec.Text as Atto +import Data.Char(digitToInt,isPrint) +import Data.Fixed(Fixed,HasResolution(..),E2) +import Data.Monoid((<>)) +import qualified Data.Text as Text +import Data.Text(Text) +import Data.Text.Lazy.Builder(Builder,singleton,fromString,fromText) +import Data.Time(Day(..),fromGregorian,toGregorian) +import Data.Time.Format(defaultTimeLocale,parseTimeM,formatTime) +import Data.Word(Word) +import Lens.Micro(Lens',ASetter',lens,set,over) +import Lens.Micro.Extras(view) +import Lens.Micro.TH(makeLenses) + +-- Fixed-width Quantities: Currency and Share Counts --------------------------- + +data E4 +instance HasResolution E4 where + resolution _ = 10000 + +type Currency = Fixed E2 +type ShareQuantity = Fixed E4 + +parseQuantity :: HasResolution a => Parser (Fixed a) +parseQuantity = + do finally <- option id (char '-' >> return negate) + leader <- digitToNum `fmap` digit + firstbit <- beforePoint leader + option (finally firstbit) $ + do _ <- char '.' + posres <- afterPoint firstbit 10 + return (finally posres) + where + beforePoint acc = + option acc $ + choice [ + do _ <- char ',' + beforePoint acc + , do x <- digitToNum `fmap` digit + beforePoint ((acc * 10) + x) + ] + afterPoint acc place = + option acc $ + do d <- digitToNum `fmap` digit + afterPoint (acc + (d / place)) (place * 10) + +renderQuantity :: HasResolution a => Fixed a -> Builder +renderQuantity = fromString . show + +parseCurrency :: Parser Currency +parseCurrency = + do finally <- option id (char '-' *> return negate) -- kept to deal with -$1 + _ <- option '$' (char '$') + amount <- parseQuantity + return (finally amount) + +renderCurrency :: Bool -> Currency -> Builder +renderCurrency showDollar x = + neg <> (if showDollar then singleton '$' else mempty) <> renderQuantity x' + where + (x',neg) = if x < 0 then (negate x, singleton '-') else (x,mempty) + +parseShareQuantity :: Parser ShareQuantity +parseShareQuantity = parseQuantity + +renderShareQuantity :: ShareQuantity -> Builder +renderShareQuantity = renderQuantity + +digitToNum :: Num a => Char -> a +digitToNum = fromIntegral . digitToInt + +-- Account Types --------------------------------------------------------------- + +data AccountType = BankAccount + | CashAccount + | CreditCardAccount + | InvestmentAccount + | AssetAccount + | LiabilityAccount + deriving (Eq, Read, Show) + +parseAccountType :: Parser AccountType +parseAccountType = string "!Type:" *> parseShortAccountType + +parseShortAccountType :: Parser AccountType +parseShortAccountType = + choice [ string "Bank" *> return BankAccount + , string "Cash" *> return CashAccount + , string "CCard" *> return CreditCardAccount + , string "Invst" *> return InvestmentAccount + , string "Oth A" *> return AssetAccount + , string "Oth L" *> return LiabilityAccount + ] + +renderAccountType :: AccountType -> Builder +renderAccountType acc = fromText "!Type:" <> renderShortAccountType acc + +renderShortAccountType :: AccountType -> Builder +renderShortAccountType BankAccount = fromText "Bank" +renderShortAccountType CashAccount = fromText "Cash" +renderShortAccountType CreditCardAccount = fromText "CCard" +renderShortAccountType InvestmentAccount = fromText "Invst" +renderShortAccountType AssetAccount = fromText "Oth A" +renderShortAccountType LiabilityAccount = fromText "Oth L" + +-- Accounts -------------------------------------------------------------------- + +data Account = Account { + _accountName :: Text + , _accountType :: AccountType + , _accountDescription :: Text + , _accountCreditLimit :: Maybe Currency + , _accountBalanceDate :: Maybe Day + , _accountBalance :: Currency + } + deriving (Eq, Show) + +pennies :: Currency -> Integer +pennies x = truncate (x * 100.0) + +makeLenses ''Account + +emptyAccount :: Account +emptyAccount = Account { + _accountName = "" + , _accountType = BankAccount + , _accountDescription = "" + , _accountCreditLimit = Nothing + , _accountBalanceDate = Nothing + , _accountBalance = 0 + } + +parseAccount :: Parser Account +parseAccount = go emptyAccount + where + go base = + do label <- satisfy (inClass "NTDL/$BX^") + case label of + 'N' -> getP go base accountName parseString + 'T' -> getP go base accountType parseShortAccountType + 'D' -> getP go base accountDescription parseString + 'L' -> getP go base accountCreditLimit (Just `fmap` parseCurrency) + '/' -> getP go base accountBalanceDate (Just `fmap` parseDate) + '$' -> getP go base accountBalance parseCurrency + 'B' -> getP go base accountBalance parseCurrency + 'X' -> many1 endOfLine *> go base + '^' -> many1 endOfLine *> return base + _ -> fail "Unknown, out of scope account label." + +getP :: (s -> Parser s) -> s -> ASetter' s a -> Parser a -> Parser s +getP go base field getter = + do x <- getter + _ <- many1 endOfLine + go (set field x base) + +getP' :: (s -> Parser s) -> s -> ASetter' s (Maybe a) -> Parser a -> Parser s +getP' go base field getter = + do x <- option Nothing (Just `fmap` getter) + _ <- many1 endOfLine + go (set field x base) + +parseString :: Parser Text +parseString = Atto.takeWhile (not . inClass "\r\n") + +renderAccount :: Account -> Builder +renderAccount acc = mconcat [ + put 'N' acc accountName fromText + , put 'D' acc accountDescription fromText + , put 'T' acc accountType renderShortAccountType + , put 'B' acc accountBalance (renderCurrency True) + , putm 'L' acc accountCreditLimit (renderCurrency True) + , putm '/' acc accountBalanceDate renderDate + , singleton '^' <> singleton '\n' + ] + +put :: Char -> s -> Lens' s a -> (a -> Builder) -> Builder +put label acc field builder = + singleton label <> builder (view field acc) <> singleton '\n' + +putm :: Char -> s -> Lens' s (Maybe a) -> (a -> Builder) -> Builder +putm label acc field builder = + case view field acc of + Just x -> singleton label <> builder x <> singleton '\n' + Nothing -> mempty + +putm' :: Char -> s -> Lens' s (Maybe a) -> (a -> Builder) -> Builder +putm' label acc field builder = + case view field acc of + Just x -> singleton label <> builder x <> singleton '\n' + Nothing -> singleton label <> singleton '\n' + +-- Dates ----------------------------------------------------------------------- + +parseDate :: Parser Day +parseDate = + do str <- Atto.takeWhile isPrint + intime <- parseTimeM False defaultTimeLocale "%-m/%e/%y" (Text.unpack str) + let (year, mon, day) = toGregorian intime + if year < 2000 + then return (fromGregorian (2000 + (year `mod` 100)) mon day) + else return intime + +renderDate :: Day -> Builder +renderDate = fromString . formatTime defaultTimeLocale "%-m/%e/%y" + +-- ----------------------------------------------------------------------------- + +parseAccountList :: Parser [Account] +parseAccountList = + do _ <- string "!Option:AutoSwitch" *> many1 endOfLine + _ <- string "!Account" *> many1 endOfLine + accs <- many' parseAccount + _ <- string "!Clear:AutoSwitch" *> many1 endOfLine + return accs + +renderAccountList :: [Account] -> Builder +renderAccountList accs = + fromString "!Option:AutoSwitch\n" <> + fromString "!Account\n" <> + mconcat (map renderAccount accs) <> + fromString "!Clear:AutoSwitch\n" + +-- Categories ------------------------------------------------------------------ + +data Category = Category { + _catName :: Text + , _catDescription :: Text + , _catKind :: CategoryKind + , _catIsTaxRelated :: Bool + , _catBudgetAmount :: Maybe Currency + , _catTaxScheduleInfo :: Maybe Word + } + deriving (Eq, Show) + +data CategoryKind = Income | Expense + deriving (Eq, Show) + +emptyCategory :: Category +emptyCategory = Category { + _catName = "" + , _catDescription = "" + , _catKind = Expense + , _catIsTaxRelated = False + , _catBudgetAmount = Nothing + , _catTaxScheduleInfo = Nothing + } + +makeLenses ''Category + +parseCategory :: Parser Category +parseCategory = go emptyCategory + where + go base = + do label <- satisfy (inClass "NDTIEBR^") + case label of + 'N' -> getP go base catName parseString + 'D' -> getP go base catDescription parseString + 'B' -> getP go base catBudgetAmount (Just `fmap` parseCurrency) + 'R' -> getP go base catTaxScheduleInfo (Just `fmap` decimal) + -- + 'T' -> many1 endOfLine *> go (set catIsTaxRelated True base) + 'I' -> many1 endOfLine *> go (set catKind Income base) + 'E' -> many1 endOfLine *> go (set catKind Expense base) + -- + '^' -> many1 endOfLine *> return base + _ -> fail "Unknown, out of scope category label." + +renderCategory :: Category -> Builder +renderCategory cat = mconcat [ + put 'N' cat catName fromText + , put 'D' cat catDescription fromText + , if _catIsTaxRelated cat then fromString "T\n" else mempty + , if _catKind cat == Income then fromString "I\n" else "E\n" + , putm 'B' cat catBudgetAmount (renderCurrency True) + , putm 'R' cat catTaxScheduleInfo (fromString . show) + , fromString "^\n" + ] + +-- Category Lists -------------------------------------------------------------- + +parseCategoryList :: Parser [Category] +parseCategoryList = + do _ <- string "!Type:Cat" + _ <- many1 endOfLine + many' parseCategory + +renderCategoryList :: [Category] -> Builder +renderCategoryList cats = + fromString "!Type:Cat\n" <> mconcat (map renderCategory cats) + + +-- Account Headers ------------------------------------------------------------- + +parseAccountHeader :: Parser Account +parseAccountHeader = + do _ <- string "!Account" + _ <- many1 endOfLine + parseAccount + +renderAccountHeader :: Account -> Builder +renderAccountHeader acc = fromString "!Account\n" <> renderAccount acc + +-- Bank Entries ---------------------------------------------------------------- + +data SplitItem = SplitItem { + _entryMemo :: Text + , _entryAmount :: Currency + , _entryCategory :: Text + } + deriving (Eq, Show) + +emptySplitItem :: SplitItem +emptySplitItem = SplitItem "" 0 "" + +data Transaction = Transaction { + _entDate :: Day + , _entParty :: Text + , _entMemo :: Text + , _entAmount :: Currency + , _entNumber :: Maybe Word + , _entCategory :: Maybe Text + , _entCleared :: Bool + , _entReimbursable :: Bool + , _entSplits :: [SplitItem] + } + deriving (Eq, Show) + +emptyTransaction :: Transaction +emptyTransaction = + Transaction (fromGregorian 2000 1 1) "" "" 0 Nothing Nothing False False [] + +makeLenses ''SplitItem +makeLenses ''Transaction + +parseTransaction :: Parser Transaction +parseTransaction = go emptyTransaction + where + go base = + do label <- satisfy (inClass "DPMTUCLNSF^") + case label of + 'D' -> getP go base entDate parseDate + 'P' -> getP go base entParty parseString + 'M' -> getP go base entMemo parseString + 'T' -> getP go base entAmount parseCurrency + 'U' -> getP go base entAmount parseCurrency + 'C' -> getP go base entCleared parseCleared + 'L' -> getP go base entCategory (Just `fmap` parseString) + 'N' -> getP go base entNumber (Just `fmap` decimal) + -- + 'S' -> do cat <-parseString <* many1 endOfLine + ent <- parseSplit (emptySplitItem{ _entryCategory = cat }) + go (over entSplits (++ [ent]) base) + -- + 'F' -> many1 endOfLine *> go (set entReimbursable True base) + '^' -> many1 endOfLine *> return base + _ -> fail "Unknown, out of scope bank entry label." + + +renderTransaction :: Transaction -> Builder +renderTransaction be = + put 'D' be entDate renderDate <> + put 'P' be entParty fromText <> + put 'M' be entMemo fromText <> + put 'T' be entAmount (renderCurrency False) <> + putm 'N' be entNumber (fromString . show) <> + put 'C' be entCleared renderCleared <> + putm 'L' be entCategory fromText <> + (if view entReimbursable be then singleton 'F' <> newline else mempty) <> + mconcat (map renderSplit (view entSplits be)) <> + singleton '^' <> newline + where + +parseSplit :: SplitItem -> Parser SplitItem +parseSplit base = option base $ + do label <- satisfy (inClass "E$") + case label of + 'E' -> getP parseSplit base entryMemo parseString + '$' -> getP parseSplit base entryAmount parseCurrency + _ -> fail "Unknown, out of scope split entry label." + +renderSplit :: SplitItem -> Builder +renderSplit s = + put 'S' s entryCategory fromText <> + put 'E' s entryMemo fromText <> + put '$' s entryAmount (renderCurrency False) + +parseCleared :: Parser Bool +parseCleared = option False (char 'X' *> return True) + +renderCleared :: Bool -> Builder +renderCleared False = mempty +renderCleared True = fromText "X" + +newline :: Builder +newline = singleton '\n' + +-- Bank Entry Lists ------------------------------------------------------------ + +parseTransactionList :: Parser [Transaction] +parseTransactionList = + do _ <- string "!Type:Bank" >> many1 endOfLine + many' parseTransaction + +renderTransactionList :: [Transaction] -> Builder +renderTransactionList ls = + fromText "!Type:Bank" <> newline <> mconcat (map renderTransaction ls) + +-- Investment Entries --------------------------------------------------------- + +data TradeInfo = TradeInfo { + _tradeDate :: Day + , _tradeSecurity :: Text + , _tradeSharePrice :: Maybe Currency + , _tradeQuantity :: Maybe ShareQuantity + , _tradeCommission :: Maybe Currency + , _tradeTotalAmount :: Currency + } + deriving (Eq, Show) + +emptyTrade :: Day -> TradeInfo +emptyTrade day = TradeInfo day "" Nothing Nothing Nothing 0 + +makeLenses ''TradeInfo + +data TransferInfo = TransferInfo { + _transDate :: Day + , _transSummary :: Text + , _transMemo :: Text + , _transAmount :: Currency + , _transCleared :: Bool + , _transAccount :: Text + , _transSplits :: [SplitItem] + } + deriving (Eq, Show) + +emptyTransfer :: Day -> TransferInfo +emptyTransfer day = TransferInfo day "" "" 0 False "" [] + +makeLenses ''TransferInfo + +data InvTransaction = Buy TradeInfo + | Sell TradeInfo + | Transfer TransferInfo + | Dividend TradeInfo + | Interest Text TradeInfo + deriving (Eq, Show) + +invEntDate :: Lens' InvTransaction Day +invEntDate = lens dget dset + where + dget :: InvTransaction -> Day + dget (Buy tinfo) = view tradeDate tinfo + dget (Sell tinfo) = view tradeDate tinfo + dget (Transfer tinfo) = view transDate tinfo + dget (Dividend tinfo) = view tradeDate tinfo + dget (Interest _ tinfo) = view tradeDate tinfo + dset :: InvTransaction -> Day -> InvTransaction + dset (Buy tinfo) x = Buy (set tradeDate x tinfo) + dset (Sell tinfo) x = Sell (set tradeDate x tinfo) + dset (Transfer tinfo) x = Transfer (set transDate x tinfo) + dset (Dividend tinfo) x = Dividend (set tradeDate x tinfo) + dset (Interest a tinfo) x = Interest a (set tradeDate x tinfo) + +parseInvTransaction :: Parser InvTransaction +parseInvTransaction = + do date <- char 'D' *> parseDate <* many1 endOfLine + choice [ Transfer `fmap` tranTransaction (emptyTransfer date) + , Buy `fmap` buyTransaction (emptyTrade date) + , Sell `fmap` sellTransaction (emptyTrade date) + , Dividend `fmap` divTransaction (emptyTrade date) + , intTransaction (emptyTrade date) + ] + where + tranTransaction base = + do label <- satisfy (inClass "PMTCLNS^") + case label of + 'P' -> getP tranTransaction base transSummary parseString + 'M' -> getP tranTransaction base transMemo parseString + 'T' -> getP tranTransaction base transAmount parseCurrency + '$' -> getP tranTransaction base transAmount parseCurrency + 'C' -> getP tranTransaction base transCleared parseCleared + 'L' -> getP tranTransaction base transAccount parseString + 'N' -> many1 digit *> many1 endOfLine *> tranTransaction base + 'S' -> do cat <- parseString <* many1 endOfLine + ent <- parseSplit (emptySplitItem{ _entryCategory = cat }) + tranTransaction (over transSplits (++ [ent]) base) + '^' -> many1 endOfLine *> return base + _ -> fail "Unknown, out of scope transfer investment transaction" + -- + buyTransaction base = string "NBuy" >> many1 endOfLine >> trade base + sellTransaction base = string "NSell" >> many1 endOfLine >> trade base + divTransaction base = string "NDiv" >> many1 endOfLine >> trade base + trade base = + do label <- satisfy (inClass "YIQOTN^") + case label of + 'Y' -> getP trade base tradeSecurity parseString + 'I' -> getP' trade base tradeSharePrice parseCurrency + 'Q' -> getP' trade base tradeQuantity parseQuantity + 'O' -> getP' trade base tradeCommission parseCurrency + 'T' -> getP trade base tradeTotalAmount parseCurrency + '^' -> many1 endOfLine *> return base + _ -> fail "Unknown, out of scope trade investment transaction" + -- + intTransaction base = + do label <- char 'N' *> parseString <* many1 endOfLine + when (label `elem` ["Buy","Sell"]) $ fail "Shouldn't be here." + tr <- trade base + return (Interest label tr) + +renderInvTransaction :: InvTransaction -> Builder +renderInvTransaction ent = + singleton 'D' <> renderDate (view invEntDate ent) <> singleton '\n' <> + case ent of + Buy t -> renderTradeInfo "Buy" t + Sell t -> renderTradeInfo "Sell" t + Transfer t -> renderTransferInfo t + Dividend t -> renderTradeInfo "Div" t + Interest n t -> renderTradeInfo n t + +renderTradeInfo :: Text -> TradeInfo -> Builder +renderTradeInfo name t = + singleton 'N' <> fromText name <> newline <> + put 'Y' t tradeSecurity fromText <> + putm' 'I' t tradeSharePrice (renderCurrency False) <> + putm' 'Q' t tradeQuantity renderShareQuantity <> + putm' 'O' t tradeCommission (renderCurrency False) <> + put 'T' t tradeTotalAmount (renderCurrency False) <> + singleton '^' <> newline + +renderTransferInfo :: TransferInfo -> Builder +renderTransferInfo t = + put 'P' t transSummary fromText <> + put 'M' t transMemo fromText <> + put 'T' t transAmount (renderCurrency False) <> + put 'C' t transCleared renderCleared <> + put 'L' t transAccount fromText <> + mconcat (map renderSplit (view transSplits t)) <> + singleton '^' <> newline + +-- Investment Entry Lists ------------------------------------------------------ + +parseInvestmentEntries :: Parser [InvTransaction] +parseInvestmentEntries = + do _ <- string "!Type:Invst" >> many1 endOfLine + many' parseInvTransaction + +renderInvestmentEntries :: [InvTransaction] -> Builder +renderInvestmentEntries ents = + fromText "!Type:Invst" <> newline <> mconcat (map renderInvTransaction ents) + + +-- Cash Entry Lists ------------------------------------------------------------ + +parseCashEntryList :: Parser [Transaction] +parseCashEntryList = + do _ <- string "!Type:Cash" >> many1 endOfLine + many' parseTransaction + +renderCashEntryList :: [Transaction] -> Builder +renderCashEntryList ls = + fromText "!Type:Cash" <> newline <> mconcat (map renderTransaction ls) + +-- Credit Card Entry Lists ----------------------------------------------------- + +parseCreditCardEntryList :: Parser [Transaction] +parseCreditCardEntryList = + do _ <- string "!Type:CCard" >> many1 endOfLine + many' parseTransaction + +renderCreditCardEntryList :: [Transaction] -> Builder +renderCreditCardEntryList ls = + fromText "!Type:CCard" <> newline <> mconcat (map renderTransaction ls) + +-- Asset Entry Lists ----------------------------------------------------------- + +parseAssetEntryList :: Parser [Transaction] +parseAssetEntryList = + do _ <- string "!Type:Oth A" >> many1 endOfLine + many' parseTransaction + +renderAssetEntryList :: [Transaction] -> Builder +renderAssetEntryList ls = + fromText "!Type:Oth A" <> newline <> mconcat (map renderTransaction ls) + +-- Liability Entry Lists ------------------------------------------------------- + +parseLiabilityEntryList :: Parser [Transaction] +parseLiabilityEntryList = + do _ <- string "!Type:Oth L" >> many1 endOfLine + many' parseTransaction + +renderLiabilityEntryList :: [Transaction] -> Builder +renderLiabilityEntryList ls = + fromText "!Type:Oth L" <> newline <> mconcat (map renderTransaction ls) + +-- Security Types -------------------------------------------------------------- + +data SecurityType = Stock | Bond | CD | MutualFund | Index | ETF | MoneyMarket + | PreciousMetal | Commodity | StockOption | Other + deriving (Eq, Show) + +parseSecurityType :: Parser SecurityType +parseSecurityType = choice [ + -- these are intentionally out of order; "Stock Option" *MUST* precede + -- "Stock", or this will shortcut + string "Stock Option" *> return StockOption + , string "Bond" *> return Bond + , string "CD" *> return CD + , string "Mutual Fund" *> return MutualFund + , string "Index" *> return Index + , string "ETF" *> return ETF + , string "Money Market Fund" *> return MoneyMarket + , string "Precious Metal" *> return PreciousMetal + , string "Commodity" *> return Commodity + , string "Stock" *> return Stock + , string "Other" *> return Other + ] + +renderSecurityType :: SecurityType -> Builder +renderSecurityType st = + case st of + Stock -> fromText "Stock" + Bond -> fromText "Bond" + CD -> fromText "CD" + MutualFund -> fromText "Mutual Fund" + Index -> fromText "Index" + ETF -> fromText "ETF" + MoneyMarket -> fromText "Money Market Fund" + PreciousMetal -> fromText "Precious Metal" + Commodity -> fromText "Commodity" + StockOption -> fromText "Stock Option" + Other -> fromText "Other" + +-- Securities ------------------------------------------------------------------ + +data Security = Security { + _secName :: Text + , _secTicker :: Text + , _secType :: SecurityType + , _secGoal :: Maybe Text + } + deriving (Eq, Show) + +emptySecurity :: Security +emptySecurity = Security "" "" Stock Nothing + +makeLenses ''Security + +parseSecurity :: Parser Security +parseSecurity = go emptySecurity + where + go base = + do label <- satisfy (inClass "NSTG^") + case label of + 'N' -> getP go base secName parseString + 'S' -> getP go base secTicker parseString + 'T' -> getP go base secType parseSecurityType + 'G' -> getP go base secGoal (Just `fmap` parseString) + '^' -> many1 endOfLine *> return base + _ -> fail "Unknown, out of scope security label." + +renderSecurity :: Security -> Builder +renderSecurity s = + put 'N' s secName fromText <> + put 'S' s secTicker fromText <> + put 'T' s secType renderSecurityType <> + putm 'G' s secGoal fromText <> + singleton '^' <> newline + +-- Securities Lists ------------------------------------------------------------ + +parseSecurityList :: Parser [Security] +parseSecurityList = + do _ <- string "!Type:Security" >> many1 endOfLine + many' parseSecurity + +renderSecurityList :: [Security] -> Builder +renderSecurityList ls = + fromText "!Type:Security" <> newline <> mconcat (map renderSecurity ls) + +-- Securities Lists ------------------------------------------------------------ + +data QIF = QIF { + _qifAccounts :: [Account] + , _qifCategories :: [Category] + , _qifSecurities :: [Security] + , _qifInvestmentActions :: [(Account, [InvTransaction])] + , _qifNormalActions :: [(Account, [Transaction])] + } + deriving (Eq, Show) + +emptyQIF :: QIF +emptyQIF = QIF [] [] [] [] [] + +makeLenses ''QIF + +parseQIF :: Parser QIF +parseQIF = go emptyQIF + where + go base = choice [ add' base qifAccounts parseAccountList + , add' base qifCategories parseCategoryList + , add' base qifSecurities parseSecurityList + , getTransactions base + , endOfInput >> return base + ] + -- + add' :: QIF -> ASetter' QIF [a] -> Parser [a] -> Parser QIF + add' base field getter = + do list <- getter + go (over field (++ list) base) + -- + getTransactions base = + do acc <- parseAccountHeader + case view accountType acc of + BankAccount -> + getts parseTransactionList qifNormalActions base acc + CashAccount -> + getts parseCashEntryList qifNormalActions base acc + CreditCardAccount -> + getts parseCreditCardEntryList qifNormalActions base acc + InvestmentAccount -> + getts parseInvestmentEntries qifInvestmentActions base acc + AssetAccount -> + getts parseAssetEntryList qifNormalActions base acc + LiabilityAccount -> + getts parseLiabilityEntryList qifNormalActions base acc + -- + getts :: Parser [a] -> ASetter' QIF [(Account,[a])] -> + QIF -> Account -> + Parser QIF + getts listParser field base account = + do list <- listParser + go (over field (++ [(account, list)]) base) +