{-# 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)