diff --git a/Models.hs b/Models.hs index 808ca6494..1890e587d 100644 --- a/Models.hs +++ b/Models.hs @@ -4,7 +4,7 @@ module Models ( module AccountName, module Transaction, module Entry, - module TimeLogEntry, + module TimeLog, module EntryTransaction, module Ledger, module Account @@ -16,7 +16,7 @@ import BasicTypes import AccountName import Transaction import Entry -import TimeLogEntry +import TimeLog import EntryTransaction import Ledger import Account diff --git a/Options.hs b/Options.hs index e2f51f0fa..693ce1229 100644 --- a/Options.hs +++ b/Options.hs @@ -1,86 +1,76 @@ - -module Options (module Options, usageInfo) +module Options where import System.Console.GetOpt +import System.Directory import System.Environment (getEnv) import Data.Maybe (fromMaybe) import Utils -usageHeader = "Usage: hledger [OPTIONS] register|balance [MATCHARGS]" - -getOptions :: [String] -> IO ([Flag], [String]) -getOptions argv = - case getOpt RequireOrder options argv of - (o,n,[] ) -> return (o,n) - (_,_,errs) -> ioError (userError (concat errs ++ usageInfo usageHeader options)) +usage = "Usage: hledger [OPTIONS] "++commands++" [ACCTPATTERNS] [-- DESCPATTERNS]\nOptions:" +commands = "register|balance" +defaultcmd = "register" +ledgerFilePath = findFileFromOpts "~/ledger.dat" "LEDGER" options :: [OptDescr Flag] options = [ - Option ['v'] ["version"] (NoArg Version) "show version number" - , Option ['f'] ["file"] (OptArg readFileOpt "FILE") "ledger file, or - to read stdin" - , Option ['s'] ["subtotal"] (NoArg ShowSubs) "balance: show sub-accounts" --; register: show subtotals" - ] + Option ['f'] ["file"] (ReqArg File "FILE") "ledger file; - means use standard input", + Option ['s'] ["showsubs"] (NoArg ShowSubs) "balance report: show subaccounts" -- register: show subtotals + --Option ['V'] ["version"] (NoArg Version) "show version" + ] -data Flag = Version | File String | ShowSubs deriving (Show,Eq) - -readFileOpt :: Maybe String -> Flag -readFileOpt = File . fromMaybe "stdin" - -getFile :: Flag -> String -getFile (File s) = s -getFile _ = [] +data Flag = + File String | + ShowSubs | + Version + deriving (Show,Eq) -getLedgerFilePath :: [Flag] -> IO String -getLedgerFilePath opts = do - defaultpath <- tildeExpand "~/ledger.dat" - envordefault <- getEnv "LEDGER" `catch` \_ -> return defaultpath - path <- tildeExpand envordefault - return $ last $ [envordefault] ++ (filter (/= "") (map getFile opts)) +parseOptions :: [String] -> IO ([Flag], [String]) +parseOptions argv = + case getOpt RequireOrder options argv of + (opts,[],[]) -> return (opts, [defaultcmd]) + (opts,args,[]) -> return (opts, args) + (_,_,errs) -> ioError (userError (concat errs ++ showusage)) --- ledger pattern args are a list of account patterns optionally followed --- by -- and a list of description patterns -ledgerPatternArgs :: [String] -> ([String],[String]) -ledgerPatternArgs args = +-- testoptions RequireOrder ["foo","-v"] +-- testoptions Permute ["foo","-v"] +-- testoptions (ReturnInOrder Arg) ["foo","-v"] +-- testoptions Permute ["foo","--","-v"] +-- testoptions Permute ["-?o","--name","bar","--na=baz"] +-- testoptions Permute ["--ver","foo"] +testoptions order cmdline = putStr $ + case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n + (_,_,errs) -> concat errs ++ showusage + +showusage = usageInfo usage options + +-- find a file path from options, an env var or a default value +findFileFromOpts :: FilePath -> String -> [Flag] -> IO String +findFileFromOpts defaultpath envvar opts = do + envordefault <- getEnv envvar `catch` \_ -> return defaultpath + paths <- mapM tildeExpand $ [envordefault] ++ (concatMap getfile opts) + return $ last paths + where + getfile (File s) = [s] + getfile _ = [] + +tildeExpand :: FilePath -> IO FilePath +tildeExpand ('~':[]) = getHomeDirectory +tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) +-- -- ~name, requires -fvia-C or ghc 6.8 +-- --import System.Posix.User +-- -- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs +-- -- pw <- getUserEntryForName user +-- -- return (homeDirectory pw ++ path) +tildeExpand xs = return xs +-- -- courtesy of allberry_b + +-- ledger pattern args are 0 or more account patterns optionally followed +-- by -- and 0 or more description patterns +parseLedgerPatternArgs :: [String] -> ([String],[String]) +parseLedgerPatternArgs args = case "--" `elem` args of True -> ((takeWhile (/= "--") args), tail $ (dropWhile (/= "--") args)) False -> (args,[]) - -getDepth :: [Flag] -> Int -getDepth opts = - maximum $ [1] ++ map depthval opts where - depthval (ShowSubs) = 9999 - depthval _ = 1 - - --- example: --- module Opts where - --- import System.Console.GetOpt --- import Data.Maybe ( fromMaybe ) - --- data Flag --- = Verbose | Version --- | Input String | Output String | LibDir String --- deriving Show - --- options :: [OptDescr Flag] --- options = --- [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" --- , Option ['V','?'] ["version"] (NoArg Version) "show version number" --- , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" --- , Option ['c'] [] (OptArg inp "FILE") "input FILE" --- , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" --- ] - --- inp,outp :: Maybe String -> Flag --- outp = Output . fromMaybe "stdout" --- inp = Input . fromMaybe "stdin" - --- compilerOpts :: [String] -> IO ([Flag], [String]) --- compilerOpts argv = --- case getOpt Permute options argv of --- (o,n,[] ) -> return (o,n) --- (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) --- where header = "Usage: ic [OPTION...] files..." diff --git a/Parse.hs b/Parse.hs index 20efa0a18..19cefaddb 100644 --- a/Parse.hs +++ b/Parse.hs @@ -1,14 +1,46 @@ - module Parse where import qualified Data.Map as Map import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Language import qualified Text.ParserCombinators.Parsec.Token as P +import System.IO import Utils import Models + +-- set up token parsing, though we're not yet using these much +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 + + +ledgerfile :: Parser Ledger +ledgerfile = ledger <|> ledgerfromtimelog + + +-- standard ledger file parser {- Here's the ledger 2.5 grammar: "The ledger file format is quite simple, but also very flexible. It supports @@ -109,33 +141,6 @@ i, o, b, h -- parsec example: http://pandoc.googlecode.com/svn/trunk/src/Text/Pandoc/Readers/RST.hs -- sample data in Tests.hs --- set up token parsing, though we're not yet using these much -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 file parsers - ledger :: Parser Ledger ledger = do ledgernondatalines @@ -245,6 +250,7 @@ whiteSpace1 :: Parser () whiteSpace1 = do space; whiteSpace +-- timelog file parser {- timelog grammar, from timeclock.el 2.6 @@ -281,7 +287,16 @@ o 2007/03/10 17:26:02 -} --- timelog file parsers +ledgerfromtimelog :: Parser Ledger +ledgerfromtimelog = do + tl <- timelog + return $ ledgerFromTimeLog tl + +timelog :: Parser TimeLog +timelog = do + entries <- many timelogentry + eof + return $ TimeLog entries timelogentry :: Parser TimeLogEntry timelogentry = do @@ -306,5 +321,6 @@ printParseResult r = case r of Left e -> parseError e Right v -> print v parseLedgerFile :: String -> IO (Either ParseError Ledger) -parseLedgerFile f = parseFromFile ledger f - +parseLedgerFile "-" = fmap (parse ledgerfile "-") $ hGetContents stdin +parseLedgerFile f = parseFromFile ledgerfile f + diff --git a/TODO b/TODO index 7286dd453..f2b6316dc 100644 --- a/TODO +++ b/TODO @@ -1,7 +1,10 @@ feature: read timelog files timelog parser - convert timelog entries to ledger entries - read whole file + handle time amounts + fix arithmetic + calculate time intervals + find datetime type + auto-generate missing clock-out optimization: add CookedLedger caching txns etc. profile again diff --git a/Tests.hs b/Tests.hs index 720497ad1..61cd79f5b 100644 --- a/Tests.hs +++ b/Tests.hs @@ -225,12 +225,19 @@ ledger7 = Ledger ] timelogentry1_str = "i 2007/03/11 16:19:00 hledger\n" -timelogentry2_str = "o 2007/03/11 16:30:00\n" - timelogentry1 = TimeLogEntry 'i' "2007/03/11 16:19:00" "hledger" + +timelogentry2_str = "o 2007/03/11 16:30:00\n" timelogentry2 = TimeLogEntry 'o' "2007/03/11 16:30:00" "" - +timelog1_str = concat [ + timelogentry1_str, + timelogentry2_str + ] +timelog1 = TimeLog [ + timelogentry1, + timelogentry2 + ] -- utils @@ -304,14 +311,16 @@ props = "expenses:phone","expenses:vacation","liabilities","liabilities:credit cards", "liabilities:credit cards:discover"] , - ledgerPatternArgs [] == ([],[]) - ,ledgerPatternArgs ["a"] == (["a"],[]) - ,ledgerPatternArgs ["a","b"] == (["a","b"],[]) - ,ledgerPatternArgs ["a","b","--"] == (["a","b"],[]) - ,ledgerPatternArgs ["a","b","--","c","b"] == (["a","b"],["c","b"]) - ,ledgerPatternArgs ["--","c"] == ([],["c"]) - ,ledgerPatternArgs ["--"] == ([],[]) + parseLedgerPatternArgs [] == ([],[]) + ,parseLedgerPatternArgs ["a"] == (["a"],[]) + ,parseLedgerPatternArgs ["a","b"] == (["a","b"],[]) + ,parseLedgerPatternArgs ["a","b","--"] == (["a","b"],[]) + ,parseLedgerPatternArgs ["a","b","--","c","b"] == (["a","b"],["c","b"]) + ,parseLedgerPatternArgs ["--","c"] == ([],["c"]) + ,parseLedgerPatternArgs ["--"] == ([],[]) ,parse' timelogentry timelogentry1_str `parseEquals` timelogentry1 ,parse' timelogentry timelogentry2_str `parseEquals` timelogentry2 + ,parse' timelog timelog1_str `parseEquals` timelog1 ] + diff --git a/TimeLog.hs b/TimeLog.hs new file mode 100644 index 000000000..40d10befe --- /dev/null +++ b/TimeLog.hs @@ -0,0 +1,59 @@ +module TimeLog +where +import Utils +import BasicTypes +import Transaction +import Entry +import Ledger + +data TimeLogEntry = TimeLogEntry { + tcode :: Char, + tdatetime :: DateTime, + tcomment :: String + } deriving (Eq,Ord) + +instance Show TimeLogEntry where + show t = printf "%s %s %s" (show $ tcode t) (tdatetime t) (tcomment t) + +data TimeLog = TimeLog { + timelog_entries :: [TimeLogEntry] + } deriving (Eq) + +instance Show TimeLog where + show tl = printf "TimeLog with %d entries" $ length $ timelog_entries tl + +ledgerFromTimeLog :: TimeLog -> Ledger +ledgerFromTimeLog tl = + Ledger [] [] (entriesFromTimeLogEntries $ timelog_entries tl) + +entriesFromTimeLogEntries :: [TimeLogEntry] -> [Entry] + +entriesFromTimeLogEntries [clockin] = + entriesFromTimeLogEntries [clockin, clockoutNowEntry] + +entriesFromTimeLogEntries [clockin,clockout] = + [ + Entry { + edate = indate, + estatus = True, + ecode = "", + edescription = accountname, + etransactions = [ + Transaction accountname amount, + Transaction "TIME" (-amount) + ]} + ] + where + accountname = (tcomment clockin) + intime = tdatetime clockin + indate = dateFrom $ tdatetime clockin + outtime = tdatetime clockout + amount = timeAmount $ 0 -- read $ outtime - intime + +entriesFromTimeLogEntries many = + (entriesFromTimeLogEntries $ take 2 many) ++ + (entriesFromTimeLogEntries $ drop 2 many) + +clockoutNowEntry = TimeLogEntry ' ' "" "" +timeAmount = Amount "h" +dateFrom = id diff --git a/Utils.hs b/Utils.hs index e4335e3fb..76ab6d351 100644 --- a/Utils.hs +++ b/Utils.hs @@ -8,7 +8,6 @@ module Utils ( quickCheck, ) where -import System.Directory import Data.List import Data.Tree import Debug.Trace @@ -25,17 +24,6 @@ splitAtElement e l = where (first,rest) = break (e==) l' --- courtesy of allberry_b -tildeExpand :: FilePath -> IO FilePath -tildeExpand ('~':[]) = getHomeDirectory -tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) --- ~name, requires -fvia-C or ghc 6.8 ---import System.Posix.User --- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs --- pw <- getUserEntryForName user --- return (homeDirectory pw ++ path) -tildeExpand xs = return xs - -- tree tools diff --git a/hledger.hs b/hledger.hs index eaf53f0be..5be8dafcd 100644 --- a/hledger.hs +++ b/hledger.hs @@ -11,6 +11,8 @@ hledger Tests Parse Models + TimeLog + TimeLogEntry Account Ledger EntryTransaction @@ -22,7 +24,6 @@ hledger -} --- application logic & most IO module Main where import System @@ -38,21 +39,43 @@ import Parse import Tests import Utils + main :: IO () main = do - (opts, args) <- (getArgs >>= getOptions) - if args == [] - then register [] [] - else - let (command, args') = (head args, tail args) in - if "reg" `isPrefixOf` command then (register opts args') - else if "bal" `isPrefixOf` command then balance opts args' - else if "test" `isPrefixOf` command then test - else putStr $ usageInfo usageHeader options + (opts, (cmd:args)) <- getArgs >>= parseOptions + run cmd opts args + where run cmd opts args + | cmd `isPrefixOf` "register" = register opts args + | cmd `isPrefixOf` "balance" = balance opts args + | cmd `isPrefixOf` "test" = test + | otherwise = putStr showusage -- commands -test :: IO () +register :: [Flag] -> [String] -> IO () +register opts args = do + doWithLedger opts $ printRegister + where + printRegister ledger = + putStr $ showTransactionsWithBalances + (ledgerTransactionsMatching (acctpats,descpats) ledger) + 0 + where (acctpats,descpats) = parseLedgerPatternArgs args + +balance :: [Flag] -> [String] -> IO () +balance opts args = do + doWithLedger opts $ printBalance + where + printBalance ledger = + putStr $ showLedgerAccounts ledger acctpats showsubs maxdepth + where + (acctpats,_) = parseLedgerPatternArgs args + showsubs = (ShowSubs `elem` opts) + maxdepth = case (acctpats, showsubs) of + ([],False) -> 1 + otherwise -> 9999 + +test :: IO () test = do hcounts <- runTestTT tests qcounts <- mapM quickCheck props @@ -60,45 +83,20 @@ test = do where showHunitCounts c = reverse $ tail $ reverse ("passed " ++ (unwords $ drop 5 $ words (show c))) -register :: [Flag] -> [String] -> IO () -register opts args = do - getLedgerFilePath opts >>= parseLedgerFile >>= doWithParsed (printRegister opts args) - -balance :: [Flag] -> [String] -> IO () -balance opts args = do - getLedgerFilePath opts >>= parseLedgerFile >>= doWithParsed (printBalance opts args) - -- utils --- doWithLedgerFile = --- getLedgerFilePath >>= parseLedgerFile >>= doWithParsed +doWithLedger :: [Flag] -> (Ledger -> IO ()) -> IO () +doWithLedger opts cmd = do + ledgerFilePath opts >>= parseLedgerFile >>= doWithParsed cmd doWithParsed :: Show a => (a -> IO ()) -> (Either ParseError a) -> IO () -doWithParsed a p = do - case p of Left e -> parseError e - Right v -> a v - -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 - putStr $ showLedgerAccounts ledger acctpats showsubs maxdepth - where - (acctpats,_) = ledgerPatternArgs args - showsubs = (ShowSubs `elem` opts) - maxdepth = case (acctpats, showsubs) of - ([],False) -> 1 - otherwise -> 9999 - +doWithParsed action parsed = do + case parsed of Left e -> parseError e + Right l -> action l -- interactive testing: -- --- p <- getLedgerFilePath [] >>= parseLedgerFile +-- p <- ledgerFilePath [] >>= parseLedgerFile -- let l = either (\_ -> Ledger [] [] []) id p -- let ant = ledgerAccountNameTree l -- let at = ledgerAccountTreeMatching l [] True 999