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

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
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.
-}

49
Options.hs
View File

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

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
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."

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

2
hledger.cabal
View File

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

27
hledger.hs
View File

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