big overhaul of options, support -f-, rudimentary timelog file handling

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

Options.hs

@@ -1,86 +1,76 @@
-
+module Options
-module Options (module Options, usageInfo)
 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]"
+usage          = "Usage: hledger [OPTIONS] "++commands++" [ACCTPATTERNS] [-- DESCPATTERNS]\nOptions:"
-
+commands       = "register|balance"
-getOptions :: [String] -> IO ([Flag], [String])
+defaultcmd     = "register"
-getOptions argv =
+ledgerFilePath = findFileFromOpts "~/ledger.dat" "LEDGER"
-    case getOpt RequireOrder options argv of
-      (o,n,[]  ) -> return (o,n)
-      (_,_,errs) -> ioError (userError (concat errs ++ usageInfo usageHeader options))
 
 options :: [OptDescr Flag]
 options = [
-            Option ['v'] ["version"] (NoArg Version)     "show version number"
+ Option ['f'] ["file"]     (ReqArg File "FILE") "ledger file; - means use standard input",
-          , Option ['f'] ["file"]    (OptArg readFileOpt "FILE") "ledger file, or - to read stdin"
+ Option ['s'] ["showsubs"] (NoArg ShowSubs)     "balance report: show subaccounts" -- register: show subtotals
-          , Option ['s'] ["subtotal"] (NoArg ShowSubs)     "balance: show sub-accounts" --; register: show subtotals"
+ --Option ['V'] ["version"]  (NoArg Version)      "show version"
-          ]
+ ]
 
-data Flag = Version | File String | ShowSubs deriving (Show,Eq)
+data Flag = 
+    File String | 
+    ShowSubs |
+    Version
+    deriving (Show,Eq)
 
-readFileOpt :: Maybe String -> Flag
+parseOptions :: [String] -> IO ([Flag], [String])
-readFileOpt  = File . fromMaybe "stdin"
+parseOptions argv =
+    case getOpt RequireOrder options argv of
+      (opts,[],[])   -> return (opts, [defaultcmd])
+      (opts,args,[]) -> return (opts, args)
+      (_,_,errs)     -> ioError (userError (concat errs ++ showusage))
 
-getFile :: Flag -> String
+-- testoptions RequireOrder ["foo","-v"]
-getFile (File s) = s
+-- testoptions Permute ["foo","-v"]
-getFile _ = []
+-- 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
 
-getLedgerFilePath :: [Flag] -> IO String
+showusage = usageInfo usage options
-getLedgerFilePath opts = do
-  defaultpath <- tildeExpand "~/ledger.dat"
-  envordefault <- getEnv "LEDGER" `catch` \_ -> return defaultpath
-  path <- tildeExpand envordefault
-  return $ last $ [envordefault] ++ (filter (/= "") (map getFile opts))
 
--- ledger pattern args are a list of account patterns optionally followed
+-- find a file path from options, an env var or a default value
--- by -- and a list of description patterns
+findFileFromOpts :: FilePath -> String -> [Flag] -> IO String
-ledgerPatternArgs :: [String] -> ([String],[String])
+findFileFromOpts defaultpath envvar opts = do
-ledgerPatternArgs args = 
+  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..."

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
     

TODO

@@ -1,7 +1,10 @@
 feature: read timelog files
  timelog parser
-  convert timelog entries to ledger entries
+  handle time amounts
-  read whole file
+   fix arithmetic
+  calculate time intervals
+   find datetime type
+  auto-generate missing clock-out
 
 optimization: add CookedLedger caching txns etc.
  profile again

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 [] == ([],[])
+     parseLedgerPatternArgs [] == ([],[])
-    ,ledgerPatternArgs ["a"] == (["a"],[])
+    ,parseLedgerPatternArgs ["a"] == (["a"],[])
-    ,ledgerPatternArgs ["a","b"] == (["a","b"],[])
+    ,parseLedgerPatternArgs ["a","b"] == (["a","b"],[])
-    ,ledgerPatternArgs ["a","b","--"] == (["a","b"],[])
+    ,parseLedgerPatternArgs ["a","b","--"] == (["a","b"],[])
-    ,ledgerPatternArgs ["a","b","--","c","b"] == (["a","b"],["c","b"])
+    ,parseLedgerPatternArgs ["a","b","--","c","b"] == (["a","b"],["c","b"])
-    ,ledgerPatternArgs ["--","c"] == ([],["c"])
+    ,parseLedgerPatternArgs ["--","c"] == ([],["c"])
-    ,ledgerPatternArgs ["--"] == ([],[])
+    ,parseLedgerPatternArgs ["--"] == ([],[])
     ,parse' timelogentry timelogentry1_str `parseEquals` timelogentry1
     ,parse' timelogentry timelogentry2_str `parseEquals` timelogentry2
+    ,parse' timelog timelog1_str `parseEquals` timelog1
     ]
 
+

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

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
 

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,20 +39,42 @@ import Parse
 import Tests
 import Utils
 
+
 main :: IO ()
 main = do
-  (opts, args) <- (getArgs >>= getOptions)
+  (opts, (cmd:args)) <- getArgs >>= parseOptions
-  if args == []
+  run cmd opts args
-    then register [] []
+  where run cmd opts args 
-    else
+            | cmd `isPrefixOf` "register" = register opts args
-      let (command, args') = (head args, tail args) in
+            | cmd `isPrefixOf` "balance"  = balance opts args
-      if "reg" `isPrefixOf` command then (register opts args')
+            | cmd `isPrefixOf` "test"     = test
-      else if "bal" `isPrefixOf` command then balance opts args'
+            | otherwise                   = putStr showusage
-           else if "test" `isPrefixOf` command then test
-                else putStr $ usageInfo usageHeader options
 
 -- commands
 
+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
@@ -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 =
+doWithLedger :: [Flag] -> (Ledger -> IO ()) -> IO ()
---     getLedgerFilePath >>= parseLedgerFile >>= doWithParsed
+doWithLedger opts cmd = do
+    ledgerFilePath opts >>= parseLedgerFile >>= doWithParsed cmd
 
 doWithParsed :: Show a => (a -> IO ()) -> (Either ParseError a) -> IO ()
-doWithParsed a p = do
+doWithParsed action parsed = do
-  case p of Left e -> parseError e
+  case parsed of Left e -> parseError e
-            Right v -> a v
+                 Right l -> action l
-
-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
-
 
 -- interactive testing:
 --
--- p <- getLedgerFilePath [] >>= parseLedgerFile
+-- p <- ledgerFilePath [] >>= parseLedgerFile
 -- let l = either (\_ -> Ledger [] [] []) id p
 -- let ant = ledgerAccountNameTree l
 -- let at = ledgerAccountTreeMatching l [] True 999