qif (empty) → 1.0.0
raw patch · 5 files changed
+1151/−0 lines, 5 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed
Dependencies added: QuickCheck, attoparsec, base, microlens, microlens-th, qif, tasty, tasty-hunit, tasty-quickcheck, text, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Test.hs +324/−0
- qif.cabal +51/−0
- src/Data/QIF.hs +744/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test.hs view
@@ -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
+ qif.cabal view
@@ -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+
+ src/Data/QIF.hs view
@@ -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)+