hledger/hledger.hs

-- 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)
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
--import TildeExpand -- confuses my ghc 6.7

-- sample data

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
-- struggling.. easier with a token parser ?

ledgerLanguageDef = LanguageDef {
   commentStart   = ""
   , commentEnd     = ""
   , commentLine    = ";"
   , nestedComments = False
   , identStart     = letter <|> char '_'
   , identLetter    = alphaNum <|> oneOf "_':"
   , opStart        = opLetter emptyDef
   , opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~"
   , reservedOpNames= []
   , reservedNames  = []
   , caseSensitive  = False
   }

lexer  = P.makeTokenParser ledgerLanguageDef
whiteSpace = P.whiteSpace lexer
lexeme     = P.lexeme lexer
symbol     = P.symbol lexer
natural    = P.natural lexer
parens     = P.parens lexer
semi       = P.semi lexer
identifier = P.identifier lexer
reserved   = P.reserved lexer
reservedOp = P.reservedOp lexer




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 []})
--ledgernondatalines = many (ledgerdirective <|> do {whiteSpace; 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"
  many spacenonewline
  ledgereol
  return (Transaction account amount)

--ledgeraccount = many1 (alphaNum <|> char ':')
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 <- many1 (oneOf "-.0123456789") <?> "quantity"
                      return (Amount currency (read quantity))
                   ) <|> 
                    return (Amount "" 0) -- change later to balance the entry

ledgereol = ledgercomment <|> do {newline; return []}

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
  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 ()