a partly-working parser for the ledger file format
This commit is contained in:
Simon Michael
parent
85864b414e
commit
55eb391f50
244
hledger.hs
244
hledger.hs
@ -1,26 +1,230 @@
|
||||
-- ledger-compatible money management tools
|
||||
-- (c) 2007 Simon Michael & contributors, released under GPL v3 or later
|
||||
-- hledger - ledger-like money management utilities
|
||||
-- GPLv3, (c) Simon Michael & contributors,
|
||||
-- ledger is at http://newartisans.com/ledger.html
|
||||
|
||||
import System.Directory (getHomeDirectory)
|
||||
import System.Environment (getEnv)
|
||||
import Control.Exception (assert)
|
||||
|
||||
-- data model
|
||||
type Date = String
|
||||
type Account = String
|
||||
type Money = Float
|
||||
-- a transaction records a movement of money between two accounts
|
||||
data Transaction = Transaction {
|
||||
date :: Date,
|
||||
account :: Account, -- debit this
|
||||
other_account :: Account, -- credit this
|
||||
description :: String,
|
||||
amount :: Money
|
||||
}
|
||||
import Text.ParserCombinators.Parsec
|
||||
import qualified Text.ParserCombinators.Parsec.Token as P
|
||||
import Text.ParserCombinators.Parsec.Language (haskellDef)
|
||||
--import TildeExpand -- confuses my ghc 6.7
|
||||
|
||||
-- sample data
|
||||
t1 = Transaction "2007-01-01" "checking" "food" "joe's diner" 8.50
|
||||
|
||||
-- tests
|
||||
sample_entry = "\
|
||||
\2007/01/27 * joes diner\n\
|
||||
\ expenses:food:dining $10.00\n\
|
||||
\ expenses:gifts $10.00\n\
|
||||
\ assets:checking $-20.00\n\
|
||||
\\n\" --"
|
||||
|
||||
sample_entry2 = "\
|
||||
\2007/01/28 coopportunity\n\
|
||||
\ expenses:food:groceries $47.18\n\
|
||||
\ assets:checking\n\
|
||||
\\n" --"
|
||||
|
||||
sample_periodic_entry = "\
|
||||
\~ monthly from 2007/2/2\n\
|
||||
\ assets:saving $200.00\n\
|
||||
\ assets:checking\n\
|
||||
\\n" --"
|
||||
|
||||
sample_periodic_entry2 = "\
|
||||
\~ monthly from 2007/2/2\n\
|
||||
\ assets:saving $200.00 ;auto savings\n\
|
||||
\ assets:checking\n\
|
||||
\\n" --"
|
||||
|
||||
sample_transaction = " expenses:food:dining $10.00\n"
|
||||
|
||||
sample_transaction2 = " assets:checking\n"
|
||||
|
||||
sample_ledger = "\
|
||||
\\n\
|
||||
\2007/01/27 * joes diner\n\
|
||||
\ expenses:food:dining $10.00\n\
|
||||
\ expenses:gifts $10.00\n\
|
||||
\ assets:checking $-20.00\n\
|
||||
\\n\
|
||||
\\n\
|
||||
\2007/01/28 coopportunity\n\
|
||||
\ expenses:food:groceries $47.18\n\
|
||||
\ assets:checking $-47.18\n\
|
||||
\\n\
|
||||
\" --"
|
||||
|
||||
sample_ledger2 = "\
|
||||
\;comment\n\
|
||||
\2007/01/27 * joes diner\n\
|
||||
\ expenses:food:dining $10.00\n\
|
||||
\ assets:checking $-47.18\n\
|
||||
\\n" --"
|
||||
|
||||
sample_ledger3 = "\
|
||||
\2007/01/27 * joes diner\n\
|
||||
\ expenses:food:dining $10.00\n\
|
||||
\;intra-entry comment\n\
|
||||
\ assets:checking $-47.18\n\
|
||||
\\n" --"
|
||||
|
||||
sample_ledger4 = "\
|
||||
\!include \"somefile\"\n\
|
||||
\2007/01/27 * joes diner\n\
|
||||
\ expenses:food:dining $10.00\n\
|
||||
\ assets:checking $-47.18\n\
|
||||
\\n" --"
|
||||
|
||||
sample_ledger5 = ""
|
||||
|
||||
-- a data model
|
||||
|
||||
data Ledger = Ledger {
|
||||
modifier_entries :: [ModifierEntry],
|
||||
periodic_entries :: [PeriodicEntry],
|
||||
entries :: [Entry]
|
||||
} deriving (Show, Eq)
|
||||
data Entry = Entry {
|
||||
date :: Date,
|
||||
status :: Bool,
|
||||
code :: String,
|
||||
description :: String,
|
||||
transactions :: [Transaction]
|
||||
} deriving (Show, Eq)
|
||||
data ModifierEntry = ModifierEntry {
|
||||
valueexpr :: String,
|
||||
m_transactions :: [Transaction]
|
||||
} deriving (Show, Eq)
|
||||
data PeriodicEntry = PeriodicEntry {
|
||||
periodexpr :: String,
|
||||
p_transactions :: [Transaction]
|
||||
} deriving (Show, Eq)
|
||||
data Transaction = Transaction {
|
||||
account :: Account,
|
||||
amount :: Amount
|
||||
} deriving (Show, Eq)
|
||||
data Amount = Amount {
|
||||
currency :: String,
|
||||
quantity :: Float
|
||||
} deriving (Read, Show, Eq)
|
||||
type Date = String
|
||||
type Account = String
|
||||
|
||||
-- ledger file parsing
|
||||
|
||||
ledger = do
|
||||
ledgernondatalines
|
||||
-- unlike ledger these must be first for now
|
||||
modifier_entries <- many ledgermodifierentry
|
||||
periodic_entries <- many ledgerperiodicentry
|
||||
--
|
||||
entries <- (many ledgerentry) <?> "entry"
|
||||
eof
|
||||
return (Ledger modifier_entries periodic_entries entries)
|
||||
|
||||
ledgernondatalines = many (ledgercomment <|> ledgerdirective <|> do {space; return []})
|
||||
|
||||
ledgercomment = char ';' >> anyChar `manyTill` newline <?> "comment"
|
||||
|
||||
ledgerdirective = char '!' >> anyChar `manyTill` newline <?> "directive"
|
||||
|
||||
ledgermodifierentry = do
|
||||
ledgernondatalines
|
||||
char '=' <?> "entry"
|
||||
valueexpr <- anyChar `manyTill` newline
|
||||
transactions <- (ledgertransaction <?> "transaction") `manyTill` (newline <?> "blank line")
|
||||
spaces
|
||||
return (ModifierEntry valueexpr transactions)
|
||||
|
||||
ledgerperiodicentry = do
|
||||
ledgernondatalines
|
||||
char '~' <?> "entry"
|
||||
periodexpr <- anyChar `manyTill` newline
|
||||
transactions <- (ledgertransaction <?> "transaction") `manyTill` (newline <?> "blank line")
|
||||
spaces
|
||||
return (PeriodicEntry periodexpr transactions)
|
||||
|
||||
ledgerentry = do
|
||||
ledgernondatalines
|
||||
date <- ledgerdate
|
||||
many1 spacenonewline
|
||||
status <- ledgerstatus
|
||||
code <- ledgercode
|
||||
description <- anyChar `manyTill` ledgereol
|
||||
transactions <- (ledgertransaction <?> "transaction") `manyTill` (newline <?> "blank line")
|
||||
-- unlike ledger, we need the file to end with a blank line
|
||||
spaces
|
||||
return (Entry date status code description transactions)
|
||||
|
||||
ledgerdate = many1 (digit <|> char '/')
|
||||
|
||||
ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False
|
||||
|
||||
ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
|
||||
|
||||
ledgertransaction = do
|
||||
many (ledgercomment <|> ledgerdirective)
|
||||
many1 spacenonewline
|
||||
account <- ledgeraccount <?> "account"
|
||||
amount <- ledgeramount <?> "amount"
|
||||
return (Transaction account amount)
|
||||
|
||||
--ledgeraccount = do {alphaNum; many (alphaNum <|> char ':' <|> try (do {spacenonewline; notFollowedBy spacenonewline; return ' '}))}
|
||||
ledgeraccount = many1 (alphaNum <|> char ':' <|> try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}))
|
||||
|
||||
twoormorespaces = do spacenonewline; many1 spacenonewline
|
||||
|
||||
ledgeramount = try (do
|
||||
many1 spacenonewline --twoormorespaces
|
||||
currency <- many (noneOf "-.0123456789\n") <?> "currency"
|
||||
quantity <- (oneOf "-.0123456789") `manyTill` ledgereol <?> "quantity"
|
||||
return (Amount currency (read quantity))
|
||||
) <|> do
|
||||
ledgereol
|
||||
return (Amount "" 0) -- change later to balance entry
|
||||
|
||||
ledgereol = do {newline; return []} <|> ledgercomment
|
||||
|
||||
spacenonewline = satisfy (\c -> c `elem` " \v\f\t")
|
||||
|
||||
-- run tests
|
||||
|
||||
parseMyLedgerFile = do
|
||||
fname <- ledgerFilePath
|
||||
parsed <- parseFromFile ledger fname
|
||||
return parsed
|
||||
where
|
||||
ledgerFilePath = do
|
||||
filepath <- getEnv "LEDGER" `catch` \_ -> return "ledger.dat"
|
||||
-- don't know how to accomplish this great feat
|
||||
--ledger_file <- tildeExpand filepath
|
||||
let ledger_file = filepath
|
||||
return ledger_file
|
||||
|
||||
main = do
|
||||
assert_ $ amount t1 == 8.50
|
||||
putStrLn "ok"
|
||||
where assert_ e = assert e return ()
|
||||
showParseResult (parse ledgertransaction "" sample_transaction)
|
||||
showParseResult (parse ledgertransaction "" sample_transaction2)
|
||||
showParseResult (parse ledgerentry "" sample_entry)
|
||||
showParseResult (parse ledgerentry "" sample_entry2)
|
||||
showParseResult (parse ledgerperiodicentry "" sample_periodic_entry)
|
||||
showParseResult (parse ledgerperiodicentry "" sample_periodic_entry2)
|
||||
showParseResult (parse ledger "" sample_ledger)
|
||||
showParseResult (parse ledger "" sample_ledger2)
|
||||
showParseResult (parse ledger "" sample_ledger3)
|
||||
showParseResult (parse ledger "" sample_ledger4)
|
||||
showParseResult (parse ledger "" sample_ledger5)
|
||||
showParseResult (parse ledger "" sample_periodic_entry)
|
||||
showParseResult (parse ledger "" sample_periodic_entry2)
|
||||
parseMyLedgerFile >>= showParseResult
|
||||
where
|
||||
showParseResult r =
|
||||
case r of
|
||||
Left err -> do putStr "ledger parse error at "; print err
|
||||
Right x -> print x
|
||||
|
||||
|
||||
|
||||
-- assert_ $ amount t1 == 8.50
|
||||
-- putStrLn "ok"
|
||||
-- where assert_ e = assert e return ()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user