2007-02-10 22:16:56 +03:00
|
|
|
#!/usr/bin/env runhaskell
|
2007-02-10 20:36:50 +03:00
|
|
|
-- hledger - ledger-compatible money management utilities (& haskell study)
|
2007-01-28 11:26:25 +03:00
|
|
|
-- GPLv3, (c) Simon Michael & contributors,
|
2007-02-16 14:51:30 +03:00
|
|
|
-- John Wiegley's ledger is at http://newartisans.com/ledger.html
|
2007-01-28 13:30:24 +03:00
|
|
|
|
2007-02-16 14:51:30 +03:00
|
|
|
-- application logic & most IO
|
|
|
|
module Main
|
2007-02-10 22:16:56 +03:00
|
|
|
where
|
2007-02-11 02:24:33 +03:00
|
|
|
import System
|
2007-02-16 14:51:30 +03:00
|
|
|
import System.Environment (withArgs) -- for testing in old hugs
|
2007-02-10 20:36:50 +03:00
|
|
|
import Test.HUnit (runTestTT)
|
2007-02-10 22:16:56 +03:00
|
|
|
import Test.QuickCheck (quickCheck)
|
2007-02-16 14:51:30 +03:00
|
|
|
import Text.ParserCombinators.Parsec (ParseError)
|
2007-01-28 00:51:59 +03:00
|
|
|
|
2007-01-30 12:07:12 +03:00
|
|
|
import Options
|
2007-02-11 02:10:04 +03:00
|
|
|
import Models
|
2007-02-09 04:23:12 +03:00
|
|
|
import Parse
|
|
|
|
import Tests
|
2007-02-16 14:51:30 +03:00
|
|
|
import Utils
|
2007-02-09 03:18:20 +03:00
|
|
|
|
|
|
|
main :: IO ()
|
2007-01-30 12:07:12 +03:00
|
|
|
main = do
|
2007-02-10 08:09:42 +03:00
|
|
|
(opts, args) <- (getArgs >>= getOptions)
|
|
|
|
if args == []
|
2007-02-15 05:08:18 +03:00
|
|
|
then register [] []
|
2007-02-10 08:09:42 +03:00
|
|
|
else
|
2007-02-10 22:16:56 +03:00
|
|
|
let (command, args') = (head args, tail args) in
|
2007-02-15 05:08:18 +03:00
|
|
|
if "reg" `isPrefixOf` command then (register opts args')
|
|
|
|
else if "bal" `isPrefixOf` command then balance opts args'
|
2007-02-10 22:16:56 +03:00
|
|
|
else if "test" `isPrefixOf` command then test
|
2007-02-16 12:00:17 +03:00
|
|
|
else putStr $ usageInfo usageHeader options
|
2007-02-09 06:17:12 +03:00
|
|
|
|
|
|
|
-- commands
|
|
|
|
|
2007-02-10 20:36:50 +03:00
|
|
|
test :: IO ()
|
|
|
|
test = do
|
2007-02-11 02:24:33 +03:00
|
|
|
hcounts <- runTestTT tests
|
|
|
|
qcounts <- mapM quickCheck props
|
2007-02-10 20:36:50 +03:00
|
|
|
return ()
|
2007-02-11 02:24:33 +03:00
|
|
|
where showHunitCounts c =
|
|
|
|
reverse $ tail $ reverse ("passed " ++ (unwords $ drop 5 $ words (show c)))
|
2007-02-10 20:36:50 +03:00
|
|
|
|
2007-02-15 05:08:18 +03:00
|
|
|
register :: [Flag] -> [String] -> IO ()
|
|
|
|
register opts args = do
|
2007-02-16 15:24:13 +03:00
|
|
|
getLedgerFilePath opts >>= parseLedgerFile >>= doWithParsed (printRegister opts args)
|
2007-02-10 08:09:42 +03:00
|
|
|
|
2007-02-15 05:08:18 +03:00
|
|
|
balance :: [Flag] -> [String] -> IO ()
|
|
|
|
balance opts args = do
|
2007-02-16 15:24:13 +03:00
|
|
|
getLedgerFilePath opts >>= parseLedgerFile >>= doWithParsed (printBalance opts args)
|
2007-02-10 20:36:50 +03:00
|
|
|
|
|
|
|
-- utils
|
|
|
|
|
2007-02-11 02:24:33 +03:00
|
|
|
-- doWithLedgerFile =
|
|
|
|
-- getLedgerFilePath >>= parseLedgerFile >>= doWithParsed
|
2007-02-10 20:36:50 +03:00
|
|
|
|
2007-02-11 02:24:33 +03:00
|
|
|
doWithParsed :: (a -> IO ()) -> (Either ParseError a) -> IO ()
|
2007-02-15 05:08:18 +03:00
|
|
|
doWithParsed a p = do
|
2007-02-11 02:24:33 +03:00
|
|
|
case p of Left e -> parseError e
|
|
|
|
Right v -> a v
|
2007-02-09 06:17:12 +03:00
|
|
|
|
2007-02-15 05:08:18 +03:00
|
|
|
printRegister :: [Flag] -> [String] -> Ledger -> IO ()
|
|
|
|
printRegister opts args ledger = do
|
|
|
|
putStr $ showTransactionsWithBalances
|
|
|
|
(ledgerTransactionsMatching (acctpats,descpats) ledger)
|
|
|
|
0
|
|
|
|
where (acctpats,descpats) = ledgerPatternArgs args
|
|
|
|
|
|
|
|
printBalance :: [Flag] -> [String] -> Ledger -> IO ()
|
|
|
|
printBalance opts args ledger = do
|
2007-02-16 14:51:30 +03:00
|
|
|
-- putStr $ showLedgerAccounts ledger acctpats depth
|
|
|
|
-- where
|
|
|
|
-- (acctpats,_) = ledgerPatternArgs args
|
|
|
|
-- showsubs = (ShowSubs `elem` opts)
|
|
|
|
-- depth = case showsubs of
|
|
|
|
-- True -> 999
|
|
|
|
-- False -> depthOption opts
|
|
|
|
putStr $ case showsubs of
|
|
|
|
True -> showLedgerAccounts ledger 999
|
|
|
|
False -> showLedgerAccounts ledger (getDepth opts)
|
2007-02-15 05:08:18 +03:00
|
|
|
where
|
2007-02-16 14:51:30 +03:00
|
|
|
showsubs = (ShowSubs `elem` opts)
|
2007-02-15 05:08:18 +03:00
|
|
|
(acctpats,_) = ledgerPatternArgs args
|