slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions 2 Packages Projects Releases Wiki Activity

refactor, moving generic io functions into Ledger.IO

Browse Source
This commit is contained in:
Simon Michael 2009-04-04 08:50:36 +00:00
parent ab94a6e9a2
commit b60f9187c0
8 changed files with 178 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Ledger.hs
View File

@ -11,6 +11,7 @@ module Ledger (
module Ledger.Amount, module Ledger.Amount,
module Ledger.Commodity, module Ledger.Commodity,
module Ledger.Dates, module Ledger.Dates,
module Ledger.IO,
module Ledger.LedgerTransaction, module Ledger.LedgerTransaction,
module Ledger.Ledger, module Ledger.Ledger,
module Ledger.Parse, module Ledger.Parse,
@ -27,6 +28,7 @@ import Ledger.AccountName
import Ledger.Amount import Ledger.Amount
import Ledger.Commodity import Ledger.Commodity
import Ledger.Dates import Ledger.Dates
import Ledger.IO
import Ledger.LedgerTransaction import Ledger.LedgerTransaction
import Ledger.Ledger import Ledger.Ledger
import Ledger.Parse import Ledger.Parse

94
Ledger/IO.hs Normal file
View File

@ -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

5
Ledger/Utils.hs
View File

@ -1,8 +1,7 @@
{-| {-|
This is the bottom of the module hierarchy. It provides a number of Provide standard imports and utilities which are useful everywhere, or
standard modules and utilities which are useful everywhere (or, are needed needed low in the module hierarchy. This is the bottom of the dependency graph.
low in the hierarchy). The "hledger prelude".
-} -}

49
Options.hs
View File

@ -1,24 +1,26 @@
{-# OPTIONS_GHC -cpp #-} {-# OPTIONS_GHC -cpp #-}
{-|
Command-line options for the application.
-}
module Options module Options
where where
import System import System
import System.Console.GetOpt import System.Console.GetOpt
import System.Directory
import System.Environment import System.Environment
import Text.Printf import Text.Printf
import Text.RegexPR (gsubRegexPRBy) import Text.RegexPR (gsubRegexPRBy)
import Data.Char (toLower) import Data.Char (toLower)
import Ledger.IO (IOArgs,
ledgerenvvar,ledgerdefaultpath,myLedgerPath,
timelogenvvar,timelogdefaultpath,myTimelogPath)
import Ledger.Parse import Ledger.Parse
import Ledger.Utils import Ledger.Utils
import Ledger.Types import Ledger.Types
import Ledger.Dates import Ledger.Dates
progname = "hledger" progname = "hledger"
ledgerpath = "~/.ledger"
ledgerenvvar = "LEDGER"
timeprogname = "hours" timeprogname = "hours"
timelogpath = "~/.timelog"
timelogenvvar = "TIMELOG"
usagehdr = printf ( usagehdr = printf (
"Usage: one of\n" ++ "Usage: one of\n" ++
@ -84,7 +86,7 @@ options = [
filehelp = printf (intercalate "\n" filehelp = printf (intercalate "\n"
["ledger file; default is the %s env. variable's" ["ledger file; default is the %s env. variable's"
,"value, or %s. - means use standard input." ,"value, or %s. - means use standard input."
]) ledgerenvvar ledgerpath ]) ledgerenvvar ledgerdefaultpath
-- | An option value from a command-line flag. -- | An option value from a command-line flag.
data Opt = data Opt =
@ -209,6 +211,12 @@ displayFromOpts opts = listtomaybe $ optValuesForConstructor Display opts
listtomaybe [] = Nothing listtomaybe [] = Nothing
listtomaybe vs = Just $ last vs 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 ? -- | Was the program invoked via the \"hours\" alias ?
usingTimeProgramName :: IO Bool usingTimeProgramName :: IO Bool
usingTimeProgramName = do usingTimeProgramName = do
@ -219,23 +227,8 @@ usingTimeProgramName = do
ledgerFilePathFromOpts :: [Opt] -> IO String ledgerFilePathFromOpts :: [Opt] -> IO String
ledgerFilePathFromOpts opts = do ledgerFilePathFromOpts opts = do
istimequery <- usingTimeProgramName istimequery <- usingTimeProgramName
let (e,d) = if istimequery f <- if istimequery then myTimelogPath else myLedgerPath
then (timelogenvvar,timelogpath) return $ last $ f:(optValuesForConstructor File opts)
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
-- | Gather any pattern arguments into a list of account patterns and a -- | Gather any pattern arguments into a list of account patterns and a
-- list of description patterns. For now we interpret pattern arguments as -- 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, as) = partition (descprefix `isPrefixOf`) args
ds' = map (drop (length descprefix)) ds 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

23
Tests.hs
View File

@ -135,14 +135,17 @@ a `is` e = assertEqual "" a e
parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
parse `parseis` expected = either printParseError (`is` expected) parse 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 for any function or topic. Mostly ordered by test name.
tests :: [Test] tests :: [Test]
tests = [ tests = [
"account directive" ~: "account directive" ~:
let sameParse str1 str2 = do l1 <- rawledgerfromstring str1 let sameParse str1 str2 = do l1 <- rawLedgerFromString str1
l2 <- rawledgerfromstring str2 l2 <- rawLedgerFromString str2
l1 `is` l2 l1 `is` l2
in TestList in TestList
[ [
@ -320,7 +323,7 @@ tests = [
] ]
,"balance report with cost basis" ~: do ,"balance report with cost basis" ~: do
rl <- rawledgerfromstring $ unlines rl <- rawLedgerFromString $ unlines
["" [""
,"2008/1/1 test " ,"2008/1/1 test "
," a:b 10h @ $50" ," a:b 10h @ $50"
@ -337,7 +340,7 @@ tests = [
] ]
,"balance report elides zero-balance root account(s)" ~: do ,"balance report elides zero-balance root account(s)" ~: do
l <- ledgerfromstringwithopts [] [] sampletime l <- ledgerFromStringWithOpts [] [] sampletime
(unlines (unlines
["2008/1/1 one" ["2008/1/1 one"
," test:a 1" ," test:a 1"
@ -445,7 +448,7 @@ tests = [
"assets:bank" `isSubAccountNameOf` "my assets" `is` False "assets:bank" `isSubAccountNameOf` "my assets" `is` False
,"default year" ~: do ,"default year" ~: do
rl <- rawledgerfromstring defaultyear_ledger_str rl <- rawLedgerFromString defaultyear_ledger_str
(ltdate $ head $ ledger_txns rl) `is` fromGregorian 2009 1 1 (ltdate $ head $ ledger_txns rl) `is` fromGregorian 2009 1 1
return () return ()
@ -539,7 +542,7 @@ tests = [
,"register report with cleared arg" ~: ,"register report with cleared arg" ~:
do do
l <- ledgerfromstringwithopts [Cleared] [] sampletime sample_ledger_str l <- ledgerFromStringWithOpts [Cleared] [] sampletime sample_ledger_str
showRegisterReport [Cleared] [] l `is` unlines showRegisterReport [Cleared] [] l `is` unlines
["2008/06/03 eat & shop expenses:food $1 $1" ["2008/06/03 eat & shop expenses:food $1 $1"
," expenses:supplies $1 $2" ," expenses:supplies $1 $2"
@ -550,7 +553,7 @@ tests = [
,"register report with uncleared arg" ~: ,"register report with uncleared arg" ~:
do do
l <- ledgerfromstringwithopts [UnCleared] [] sampletime sample_ledger_str l <- ledgerFromStringWithOpts [UnCleared] [] sampletime sample_ledger_str
showRegisterReport [UnCleared] [] l `is` unlines showRegisterReport [UnCleared] [] l `is` unlines
["2008/01/01 income assets:bank:checking $1 $1" ["2008/01/01 income assets:bank:checking $1 $1"
," income:salary $-1 0" ," income:salary $-1 0"
@ -562,7 +565,7 @@ tests = [
,"register report sorts by date" ~: ,"register report sorts by date" ~:
do do
l <- ledgerfromstringwithopts [] [] sampletime $ unlines l <- ledgerFromStringWithOpts [] [] sampletime $ unlines
["2008/02/02 a" ["2008/02/02 a"
," b 1" ," b 1"
," c" ," c"
@ -747,8 +750,8 @@ tests = [
sampledate = parsedate "2008/11/26" sampledate = parsedate "2008/11/26"
sampletime = LocalTime sampledate midday sampletime = LocalTime sampledate midday
sampleledger = ledgerfromstringwithopts [] [] sampletime sample_ledger_str sampleledger = ledgerFromStringWithOpts [] [] sampletime sample_ledger_str
sampleledgerwithopts opts args = ledgerfromstringwithopts opts args sampletime sample_ledger_str sampleledgerwithopts opts args = ledgerFromStringWithOpts opts args sampletime sample_ledger_str
sample_ledger_str = unlines sample_ledger_str = unlines
["; A sample ledger file." ["; A sample ledger file."

73
Utils.hs
View File

@ -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 module Utils
where where
import Control.Monad.Error import Control.Monad.Error
import qualified Data.Map as Map (lookup)
import Data.Time.Clock import Data.Time.Clock
import Text.ParserCombinators.Parsec
import System.IO
import Options
import Ledger 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 -- | parse the user's specified ledger file and run a hledger command on it,
-- based on the command-line options/arguments and the current date/time. -- or report a parse error. This function makes the whole thing go.
prepareLedger :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger withLedgerDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO ()
prepareLedger opts args reftime rawtext rl = l{rawledgertext=rawtext} withLedgerDo opts args cmd = do
where f <- ledgerFilePathFromOpts opts
l = cacheLedger apats $ filterRawLedger span dpats c r $ canonicaliseAmounts cb rl -- kludgily read the file a second time to get the full text,
(apats,dpats) = parseAccountDescriptionArgs [] args -- kludgily try not to fail if it's stdin. XXX
span = dateSpanFromOpts (localDay reftime) opts rawtext <- readFile $ if f == "-" then "/dev/null" else f
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
t <- getCurrentLocalTime 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. -- | Get a Ledger from the given string and options, or raise an error.
ledgerfromstringwithopts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger ledgerFromStringWithOpts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger
ledgerfromstringwithopts opts args reftime s = ledgerFromStringWithOpts opts args reftime s =
liftM (prepareLedger opts args reftime s) $ rawledgerfromstring s liftM (filterAndCacheLedgerWithOpts opts args reftime s) $ rawLedgerFromString s
-- | Get a Ledger from the given file path and options, or raise an error. -- | Read a Ledger from the given file, filtering according to the
ledgerfromfilewithopts :: [Opt] -> [String] -> FilePath -> IO Ledger -- options, or give an error.
ledgerfromfilewithopts opts args f = do readLedgerWithOpts :: [Opt] -> [String] -> FilePath -> IO Ledger
s <- readFile f readLedgerWithOpts opts args f = do
rl <- rawledgerfromstring s t <- getCurrentLocalTime
reftime <- getCurrentLocalTime readLedgerWithIOArgs (optsToIOArgs opts args t) f
return $ prepareLedger opts args reftime s rl
-- | Get a Ledger from your default ledger file, or raise an error. -- | Convert a RawLedger to a canonicalised, cached and filtered Ledger
-- Assumes no options. -- based on the command-line options/arguments and a reference time.
myledger :: IO Ledger filterAndCacheLedgerWithOpts :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger
myledger = ledgerFilePathFromOpts [] >>= ledgerfromfilewithopts [] [] 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

2
hledger.cabal
View File

@ -36,6 +36,7 @@ Library
Ledger.Amount Ledger.Amount
Ledger.Commodity Ledger.Commodity
Ledger.Dates Ledger.Dates
Ledger.IO
Ledger.LedgerTransaction Ledger.LedgerTransaction
Ledger.RawLedger Ledger.RawLedger
Ledger.Ledger Ledger.Ledger
@ -68,6 +69,7 @@ Executable hledger
Ledger.Amount Ledger.Amount
Ledger.Commodity Ledger.Commodity
Ledger.Dates Ledger.Dates
Ledger.IO
Ledger.LedgerTransaction Ledger.LedgerTransaction
Ledger.Ledger Ledger.Ledger
Ledger.Parse Ledger.Parse

27
hledger.hs
View File

@ -40,6 +40,9 @@ module Main (
module BalanceCommand, module BalanceCommand,
module PrintCommand, module PrintCommand,
module RegisterCommand, module RegisterCommand,
#ifdef VTY
module UICommand,
#endif
#ifdef HAPPS #ifdef HAPPS
module WebCommand, module WebCommand,
#endif #endif
@ -51,7 +54,7 @@ import System.IO
import Version (versionmsg) import Version (versionmsg)
import Ledger import Ledger
import Utils import Utils (withLedgerDo)
import Options import Options
import Tests import Tests
import BalanceCommand import BalanceCommand
@ -73,27 +76,15 @@ main = do
run cmd opts args run cmd opts args
| Help `elem` opts = putStr $ usage | Help `elem` opts = putStr $ usage
| Version `elem` opts = putStr versionmsg | Version `elem` opts = putStr versionmsg
| cmd `isPrefixOf` "balance" = parseLedgerAndDo opts args balance | cmd `isPrefixOf` "balance" = withLedgerDo opts args balance
| cmd `isPrefixOf` "print" = parseLedgerAndDo opts args print' | cmd `isPrefixOf` "print" = withLedgerDo opts args print'
| cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register | cmd `isPrefixOf` "register" = withLedgerDo opts args register
#ifdef VTY #ifdef VTY
| cmd `isPrefixOf` "ui" = parseLedgerAndDo opts args ui | cmd `isPrefixOf` "ui" = withLedgerDo opts args ui
#endif #endif
#ifdef HAPPS #ifdef HAPPS
| cmd `isPrefixOf` "web" = parseLedgerAndDo opts args web | cmd `isPrefixOf` "web" = withLedgerDo opts args web
#endif #endif
| cmd `isPrefixOf` "test" = runtests opts args >> return () | cmd `isPrefixOf` "test" = runtests opts args >> return ()
| otherwise = putStr $ usage | 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