diff --git a/Ledger.hs b/Ledger.hs index 325efd1ec..f3a56994e 100644 --- a/Ledger.hs +++ b/Ledger.hs @@ -11,6 +11,7 @@ module Ledger ( module Ledger.Amount, module Ledger.Commodity, module Ledger.Dates, + module Ledger.IO, module Ledger.LedgerTransaction, module Ledger.Ledger, module Ledger.Parse, @@ -27,6 +28,7 @@ import Ledger.AccountName import Ledger.Amount import Ledger.Commodity import Ledger.Dates +import Ledger.IO import Ledger.LedgerTransaction import Ledger.Ledger import Ledger.Parse diff --git a/Ledger/IO.hs b/Ledger/IO.hs new file mode 100644 index 000000000..fed44d48c --- /dev/null +++ b/Ledger/IO.hs @@ -0,0 +1,94 @@ +{-| +Utilities for doing I/O with ledger files. +-} + +module Ledger.IO +where +import Control.Monad.Error +import Data.Time.Clock +import Data.Time.LocalTime (LocalTime) +import Ledger.Ledger (cacheLedger) +import Ledger.Parse (parseLedger) +import Ledger.RawLedger (canonicaliseAmounts,filterRawLedger) +import Ledger.Types (DateSpan(..),RawLedger,Ledger(..)) +import Ledger.Utils (getCurrentLocalTime) +import System.Directory (getHomeDirectory) +import System.Environment (getEnv) +import System.IO +import Text.ParserCombinators.Parsec +import qualified Data.Map as Map (lookup) + + +ledgerdefaultpath = "~/.ledger" +timelogdefaultpath = "~/.timelog" +ledgerenvvar = "LEDGER" +timelogenvvar = "TIMELOG" + +-- | A set of arguments specifying how to filter a ledger file. +type IOArgs = (DateSpan -- ^ only in this date span + ,Maybe Bool -- ^ only cleared/uncleared/don't care + ,Bool -- ^ only real/don't care + ,Bool -- ^ convert amounts to cost basis + ,[String] -- ^ account patterns + ,[String] -- ^ description patterns + ) + +noioargs = (DateSpan Nothing Nothing, Nothing, False, False, [], []) + +-- | Get the user's default ledger file path. +myLedgerPath :: IO String +myLedgerPath = + getEnv ledgerenvvar `catch` \_ -> return ledgerdefaultpath >>= tildeExpand + +-- | Get the user's default timelog file path. +myTimelogPath :: IO String +myTimelogPath = + getEnv timelogenvvar `catch` \_ -> return timelogdefaultpath >>= tildeExpand + +-- | Read the user's default ledger file, or give an error. +myLedger :: IO Ledger +myLedger = myLedgerPath >>= readLedger + +-- | Read the user's default timelog file, or give an error. +myTimelog :: IO Ledger +myTimelog = myTimelogPath >>= readLedger + +-- | Read a ledger from this file, with no filtering, or give an error. +readLedger :: FilePath -> IO Ledger +readLedger = readLedgerWithIOArgs noioargs + +-- | Read a ledger from this file, filtering according to the io args, +-- | or give an error. +readLedgerWithIOArgs :: IOArgs -> FilePath -> IO Ledger +readLedgerWithIOArgs ioargs f = do + t <- getCurrentLocalTime + s <- readFile f + rl <- rawLedgerFromString s + return $ filterAndCacheLedger ioargs s rl + +-- | Read a RawLedger from the given string, using the current time as +-- reference time, or give a parse error. +rawLedgerFromString :: String -> IO RawLedger +rawLedgerFromString s = do + t <- getCurrentLocalTime + liftM (either error id) $ runErrorT $ parseLedger t "(string)" s + +-- | Convert a RawLedger to a canonicalised, cached and filtered Ledger. +filterAndCacheLedger :: IOArgs -> String -> RawLedger -> Ledger +filterAndCacheLedger (span,cleared,real,costbasis,apats,dpats) rawtext rl = + (cacheLedger apats + $ filterRawLedger span dpats cleared real + $ canonicaliseAmounts costbasis rl + ){rawledgertext=rawtext} + +-- | Expand ~ in a file path (does not handle ~name). +tildeExpand :: FilePath -> IO FilePath +tildeExpand ('~':[]) = getHomeDirectory +tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) +--handle ~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 + diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs index 5aadf7379..58a1f8f51 100644 --- a/Ledger/Utils.hs +++ b/Ledger/Utils.hs @@ -1,8 +1,7 @@ {-| -This is the bottom of the module hierarchy. It provides a number of -standard modules and utilities which are useful everywhere (or, are needed -low in the hierarchy). The "hledger prelude". +Provide standard imports and utilities which are useful everywhere, or +needed low in the module hierarchy. This is the bottom of the dependency graph. -} diff --git a/Options.hs b/Options.hs index 239bd0109..12956f96f 100644 --- a/Options.hs +++ b/Options.hs @@ -1,24 +1,26 @@ {-# OPTIONS_GHC -cpp #-} +{-| +Command-line options for the application. +-} + module Options where import System import System.Console.GetOpt -import System.Directory import System.Environment import Text.Printf import Text.RegexPR (gsubRegexPRBy) import Data.Char (toLower) +import Ledger.IO (IOArgs, + ledgerenvvar,ledgerdefaultpath,myLedgerPath, + timelogenvvar,timelogdefaultpath,myTimelogPath) import Ledger.Parse import Ledger.Utils import Ledger.Types import Ledger.Dates progname = "hledger" -ledgerpath = "~/.ledger" -ledgerenvvar = "LEDGER" timeprogname = "hours" -timelogpath = "~/.timelog" -timelogenvvar = "TIMELOG" usagehdr = printf ( "Usage: one of\n" ++ @@ -84,7 +86,7 @@ options = [ filehelp = printf (intercalate "\n" ["ledger file; default is the %s env. variable's" ,"value, or %s. - means use standard input." - ]) ledgerenvvar ledgerpath + ]) ledgerenvvar ledgerdefaultpath -- | An option value from a command-line flag. data Opt = @@ -209,6 +211,12 @@ displayFromOpts opts = listtomaybe $ optValuesForConstructor Display opts listtomaybe [] = Nothing listtomaybe vs = Just $ last vs +-- | Get a maybe boolean representing the last cleared/uncleared option if any. +clearedValueFromOpts opts | null os = Nothing + | last os == Cleared = Just True + | otherwise = Just False + where os = optsWithConstructors [Cleared,UnCleared] opts + -- | Was the program invoked via the \"hours\" alias ? usingTimeProgramName :: IO Bool usingTimeProgramName = do @@ -219,23 +227,8 @@ usingTimeProgramName = do ledgerFilePathFromOpts :: [Opt] -> IO String ledgerFilePathFromOpts opts = do istimequery <- usingTimeProgramName - let (e,d) = if istimequery - then (timelogenvvar,timelogpath) - else (ledgerenvvar,ledgerpath) - envordefault <- getEnv e `catch` \_ -> return d - paths <- mapM tildeExpand $ [envordefault] ++ optValuesForConstructor File opts - return $ last paths - --- | Expand ~ in a file path (does not handle ~name). -tildeExpand :: FilePath -> IO FilePath -tildeExpand ('~':[]) = getHomeDirectory -tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) ---handle ~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 + f <- if istimequery then myTimelogPath else myLedgerPath + return $ last $ f:(optValuesForConstructor File opts) -- | Gather any pattern arguments into a list of account patterns and a -- list of description patterns. For now we interpret pattern arguments as @@ -250,3 +243,13 @@ parseAccountDescriptionArgs opts args = (as, ds') (ds, as) = partition (descprefix `isPrefixOf`) args ds' = map (drop (length descprefix)) ds +-- | Convert application options to more generic types for the library. +optsToIOArgs :: [Opt] -> [String] -> LocalTime -> IOArgs +optsToIOArgs opts args t = (dateSpanFromOpts (localDay t) opts + ,clearedValueFromOpts opts + ,Real `elem` opts + ,CostBasis `elem` opts + ,apats + ,dpats + ) where (apats,dpats) = parseAccountDescriptionArgs [] args + diff --git a/Tests.hs b/Tests.hs index 454818fcc..4a136070a 100644 --- a/Tests.hs +++ b/Tests.hs @@ -135,14 +135,17 @@ a `is` e = assertEqual "" a e parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion parse `parseis` expected = either printParseError (`is` expected) parse +parseWithCtx :: GenParser Char LedgerFileCtx a -> String -> Either ParseError a +parseWithCtx p ts = runParser p emptyCtx "" ts + ------------------------------------------------------------------------------ -- | Tests for any function or topic. Mostly ordered by test name. tests :: [Test] tests = [ "account directive" ~: - let sameParse str1 str2 = do l1 <- rawledgerfromstring str1 - l2 <- rawledgerfromstring str2 + let sameParse str1 str2 = do l1 <- rawLedgerFromString str1 + l2 <- rawLedgerFromString str2 l1 `is` l2 in TestList [ @@ -320,7 +323,7 @@ tests = [ ] ,"balance report with cost basis" ~: do - rl <- rawledgerfromstring $ unlines + rl <- rawLedgerFromString $ unlines ["" ,"2008/1/1 test " ," a:b 10h @ $50" @@ -337,7 +340,7 @@ tests = [ ] ,"balance report elides zero-balance root account(s)" ~: do - l <- ledgerfromstringwithopts [] [] sampletime + l <- ledgerFromStringWithOpts [] [] sampletime (unlines ["2008/1/1 one" ," test:a 1" @@ -445,7 +448,7 @@ tests = [ "assets:bank" `isSubAccountNameOf` "my assets" `is` False ,"default year" ~: do - rl <- rawledgerfromstring defaultyear_ledger_str + rl <- rawLedgerFromString defaultyear_ledger_str (ltdate $ head $ ledger_txns rl) `is` fromGregorian 2009 1 1 return () @@ -539,7 +542,7 @@ tests = [ ,"register report with cleared arg" ~: do - l <- ledgerfromstringwithopts [Cleared] [] sampletime sample_ledger_str + l <- ledgerFromStringWithOpts [Cleared] [] sampletime sample_ledger_str showRegisterReport [Cleared] [] l `is` unlines ["2008/06/03 eat & shop expenses:food $1 $1" ," expenses:supplies $1 $2" @@ -550,7 +553,7 @@ tests = [ ,"register report with uncleared arg" ~: do - l <- ledgerfromstringwithopts [UnCleared] [] sampletime sample_ledger_str + l <- ledgerFromStringWithOpts [UnCleared] [] sampletime sample_ledger_str showRegisterReport [UnCleared] [] l `is` unlines ["2008/01/01 income assets:bank:checking $1 $1" ," income:salary $-1 0" @@ -562,7 +565,7 @@ tests = [ ,"register report sorts by date" ~: do - l <- ledgerfromstringwithopts [] [] sampletime $ unlines + l <- ledgerFromStringWithOpts [] [] sampletime $ unlines ["2008/02/02 a" ," b 1" ," c" @@ -747,8 +750,8 @@ tests = [ sampledate = parsedate "2008/11/26" sampletime = LocalTime sampledate midday -sampleledger = ledgerfromstringwithopts [] [] sampletime sample_ledger_str -sampleledgerwithopts opts args = ledgerfromstringwithopts opts args sampletime sample_ledger_str +sampleledger = ledgerFromStringWithOpts [] [] sampletime sample_ledger_str +sampleledgerwithopts opts args = ledgerFromStringWithOpts opts args sampletime sample_ledger_str sample_ledger_str = unlines ["; A sample ledger file." diff --git a/Utils.hs b/Utils.hs index a035b677c..d53a1863b 100644 --- a/Utils.hs +++ b/Utils.hs @@ -1,61 +1,48 @@ {-| -Utilities for top-level modules and/or ghci. See also "Ledger.Utils". +Utilities for top-level modules and ghci. See also "Ledger.IO" and +"Ledger.Utils". -} module Utils where import Control.Monad.Error -import qualified Data.Map as Map (lookup) import Data.Time.Clock -import Text.ParserCombinators.Parsec -import System.IO -import Options import Ledger +import Options (Opt,ledgerFilePathFromOpts,optsToIOArgs) +import System.IO +import Text.ParserCombinators.Parsec +import qualified Data.Map as Map (lookup) --- | Convert a RawLedger to a canonicalised, cached and filtered Ledger --- based on the command-line options/arguments and the current date/time. -prepareLedger :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger -prepareLedger opts args reftime rawtext rl = l{rawledgertext=rawtext} - where - l = cacheLedger apats $ filterRawLedger span dpats c r $ canonicaliseAmounts cb rl - (apats,dpats) = parseAccountDescriptionArgs [] args - span = dateSpanFromOpts (localDay reftime) opts - r = Real `elem` opts - cb = CostBasis `elem` opts - c = clearedValueFromOpts opts - where clearedValueFromOpts opts | null os = Nothing - | last os == Cleared = Just True - | otherwise = Just False - where os = optsWithConstructors [Cleared,UnCleared] opts - --- | Get a RawLedger from the given string, or raise an error. --- This uses the current local time as the reference time (for closing --- open timelog entries). -rawledgerfromstring :: String -> IO RawLedger -rawledgerfromstring s = do +-- | parse the user's specified ledger file and run a hledger command on it, +-- or report a parse error. This function makes the whole thing go. +withLedgerDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO () +withLedgerDo opts args cmd = do + f <- ledgerFilePathFromOpts opts + -- kludgily read the file a second time to get the full text, + -- kludgily try not to fail if it's stdin. XXX + rawtext <- readFile $ if f == "-" then "/dev/null" else f t <- getCurrentLocalTime - liftM (either error id) $ runErrorT $ parseLedger t "(string)" s + let runcmd = cmd opts args . filterAndCacheLedgerWithOpts opts args t rawtext + + return f >>= runErrorT . parseLedgerFile t >>= either (hPutStrLn stderr) runcmd -- | Get a Ledger from the given string and options, or raise an error. -ledgerfromstringwithopts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger -ledgerfromstringwithopts opts args reftime s = - liftM (prepareLedger opts args reftime s) $ rawledgerfromstring s +ledgerFromStringWithOpts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger +ledgerFromStringWithOpts opts args reftime s = + liftM (filterAndCacheLedgerWithOpts opts args reftime s) $ rawLedgerFromString s --- | Get a Ledger from the given file path and options, or raise an error. -ledgerfromfilewithopts :: [Opt] -> [String] -> FilePath -> IO Ledger -ledgerfromfilewithopts opts args f = do - s <- readFile f - rl <- rawledgerfromstring s - reftime <- getCurrentLocalTime - return $ prepareLedger opts args reftime s rl +-- | Read a Ledger from the given file, filtering according to the +-- options, or give an error. +readLedgerWithOpts :: [Opt] -> [String] -> FilePath -> IO Ledger +readLedgerWithOpts opts args f = do + t <- getCurrentLocalTime + readLedgerWithIOArgs (optsToIOArgs opts args t) f --- | Get a Ledger from your default ledger file, or raise an error. --- Assumes no options. -myledger :: IO Ledger -myledger = ledgerFilePathFromOpts [] >>= ledgerfromfilewithopts [] [] +-- | Convert a RawLedger to a canonicalised, cached and filtered Ledger +-- based on the command-line options/arguments and a reference time. +filterAndCacheLedgerWithOpts :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger +filterAndCacheLedgerWithOpts opts args t = filterAndCacheLedger (optsToIOArgs opts args t) -parseWithCtx :: GenParser Char LedgerFileCtx a -> String -> Either ParseError a -parseWithCtx p ts = runParser p emptyCtx "" ts \ No newline at end of file diff --git a/hledger.cabal b/hledger.cabal index 2f5afaced..9a930cb99 100644 --- a/hledger.cabal +++ b/hledger.cabal @@ -36,6 +36,7 @@ Library Ledger.Amount Ledger.Commodity Ledger.Dates + Ledger.IO Ledger.LedgerTransaction Ledger.RawLedger Ledger.Ledger @@ -68,6 +69,7 @@ Executable hledger Ledger.Amount Ledger.Commodity Ledger.Dates + Ledger.IO Ledger.LedgerTransaction Ledger.Ledger Ledger.Parse diff --git a/hledger.hs b/hledger.hs index ce6363ff8..50b1702c2 100644 --- a/hledger.hs +++ b/hledger.hs @@ -40,6 +40,9 @@ module Main ( module BalanceCommand, module PrintCommand, module RegisterCommand, +#ifdef VTY + module UICommand, +#endif #ifdef HAPPS module WebCommand, #endif @@ -51,7 +54,7 @@ import System.IO import Version (versionmsg) import Ledger -import Utils +import Utils (withLedgerDo) import Options import Tests import BalanceCommand @@ -73,27 +76,15 @@ main = do run cmd opts args | Help `elem` opts = putStr $ usage | Version `elem` opts = putStr versionmsg - | cmd `isPrefixOf` "balance" = parseLedgerAndDo opts args balance - | cmd `isPrefixOf` "print" = parseLedgerAndDo opts args print' - | cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register + | cmd `isPrefixOf` "balance" = withLedgerDo opts args balance + | cmd `isPrefixOf` "print" = withLedgerDo opts args print' + | cmd `isPrefixOf` "register" = withLedgerDo opts args register #ifdef VTY - | cmd `isPrefixOf` "ui" = parseLedgerAndDo opts args ui + | cmd `isPrefixOf` "ui" = withLedgerDo opts args ui #endif #ifdef HAPPS - | cmd `isPrefixOf` "web" = parseLedgerAndDo opts args web + | cmd `isPrefixOf` "web" = withLedgerDo opts args web #endif | cmd `isPrefixOf` "test" = runtests opts args >> return () | otherwise = putStr $ usage --- | parse the user's specified ledger file and do some action with it --- (or report a parse error). This function makes the whole thing go. -parseLedgerAndDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO () -parseLedgerAndDo opts args cmd = do - f <- ledgerFilePathFromOpts opts - -- XXX we read the file twice - inelegant - -- and, doesn't work with stdin. kludge it, stdin won't work with ui command - let f' = if f == "-" then "/dev/null" else f - rawtext <- readFile f' - t <- getCurrentLocalTime - let runcmd = cmd opts args . prepareLedger opts args t rawtext - return f >>= runErrorT . parseLedgerFile t >>= either (hPutStrLn stderr) runcmd