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

optionsgeddon.. port to cmdargs and a fully modal cli

Browse Source
This commit is contained in:
Simon Michael 2011-08-15 22:50:09 +00:00
parent c3954cad43
commit 059825a9b2
34 changed files with 1048 additions and 716 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
hledger-chart/Hledger/Chart/Main.hs
View File

@ -18,78 +18,49 @@ import Data.Maybe
import Data.Ord import Data.Ord
import Data.Tree import Data.Tree
import Graphics.Rendering.Chart import Graphics.Rendering.Chart
import Safe (readDef)
import System.Console.GetOpt
import System.Exit (exitFailure) import System.Exit (exitFailure)
import Text.Printf
import Hledger import Hledger
import Prelude hiding (putStr, putStrLn) import Hledger.Cli hiding (progname,progversion)
import Hledger.Utils.UTF8 (putStr, putStrLn) import Prelude hiding (putStrLn)
import Hledger.Cli.Options import Hledger.Utils.UTF8 (putStrLn)
import Hledger.Cli.Utils (withJournalDo)
import Hledger.Cli.Version
import Hledger.Chart.Options
progname_chart = progname_cli ++ "-chart"
defchartoutput = "hledger.png"
defchartitems = 10
defchartsize = "600x400"
options_chart :: [OptDescr Opt]
options_chart = [
Option "o" ["output"] (ReqArg ChartOutput "FILE") ("output filename (default: "++defchartoutput++")")
,Option "" ["items"] (ReqArg ChartItems "N") ("number of accounts to show (default: "++show defchartitems++")")
,Option "" ["size"] (ReqArg ChartSize "WIDTHxHEIGHT") ("image size (default: "++defchartsize++")")
]
usage_preamble_chart =
"Usage: hledger-chart [OPTIONS] [PATTERNS]\n" ++
"\n" ++
"Reads your ~/.journal file, or another specified by $LEDGER or -f, and\n" ++
"generates simple pie chart images.\n" ++
"\n"
usage_options_chart = usageInfo "hledger-chart options:" options_chart ++ "\n"
usage_chart = concat [
usage_preamble_chart
,usage_options_chart
,usage_options_cli
,usage_postscript_cli
]
main :: IO () main :: IO ()
main = do main = do
(opts, args) <- parseArgumentsWith $ options_cli++options_chart opts <- getHledgerChartOpts
run opts args when (debug_ $ cliopts_ opts) $ printf "%s\n" progversion >> printf "opts: %s\n" (show opts)
runWith opts
runWith :: ChartOpts -> IO ()
runWith opts = run opts
where where
run opts args run opts
| Help `elem` opts = putStr usage_chart | "help" `in_` (rawopts_ $ cliopts_ opts) = printModeHelpAndExit chartmode
| Version `elem` opts = putStrLn $ progversionstr progname_chart | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
| BinaryFilename `elem` opts = putStrLn $ binaryfilename progname_chart | otherwise = withJournalDo' opts chart
| otherwise = withJournalDo opts args "chart" chart
withJournalDo' :: ChartOpts -> (ChartOpts -> Journal -> IO ()) -> IO ()
withJournalDo' opts cmd = do
journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing >>=
either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))
-- | Generate an image with the pie chart and write it to a file -- | Generate an image with the pie chart and write it to a file
chart :: [Opt] -> [String] -> Journal -> IO () chart :: ChartOpts -> Journal -> IO ()
chart opts args j = do chart opts j = do
d <- getCurrentDay d <- getCurrentDay
if null $ jtxns j if null $ jtxns j
then putStrLn "This journal has no transactions, can't make a chart." >> exitFailure then putStrLn "This journal has no transactions, can't make a chart." >> exitFailure
else do else do
let chart = genPie opts (optsToFilterSpec opts args d) j let chart = genPie opts (optsToFilterSpec ropts d) j
renderableToPNGFile (toRenderable chart) w h filename renderableToPNGFile (toRenderable chart) w h filename
return () return ()
where where
filename = getOption opts ChartOutput defchartoutput filename = chart_output_ opts
(w,h) = parseSize $ getOption opts ChartSize defchartsize (w,h) = parseSize $ chart_size_ opts
ropts = reportopts_ $ cliopts_ opts
-- | Extract string option value from a list of options or use the default
getOption :: [Opt] -> (String->Opt) -> String -> String
getOption opts opt def =
case reverse $ optValuesForConstructor opt opts of
[] -> def
x:_ -> x
-- | Parse image size from a command-line option -- | Parse image size from a command-line option
parseSize :: String -> (Int,Int) parseSize :: String -> (Int,Int)
@ -99,26 +70,28 @@ parseSize str = (read w, read h)
(w,_:h) = splitAt x str (w,_:h) = splitAt x str
-- | Generate pie chart -- | Generate pie chart
genPie :: [Opt] -> FilterSpec -> Journal -> PieLayout genPie :: ChartOpts -> FilterSpec -> Journal -> PieLayout
genPie opts filterspec j = defaultPieLayout { pie_background_ = solidFillStyle $ opaque $ white genPie opts filterspec j = defaultPieLayout { pie_background_ = solidFillStyle $ opaque $ white
, pie_plot_ = pie_chart } , pie_plot_ = pie_chart }
where where
pie_chart = defaultPieChart { pie_data_ = map (uncurry accountPieItem) chartitems' pie_chart = defaultPieChart { pie_data_ = map (uncurry accountPieItem) chartitems
, pie_start_angle_ = (-90) , pie_start_angle_ = (-90)
, pie_colors_ = mkColours hue , pie_colors_ = mkColours hue
, pie_label_style_ = defaultFontStyle{font_size_=12} , pie_label_style_ = defaultFontStyle{font_size_=12}
} }
chartitems' = debug "chart" $ top num samesignitems chartitems = debug "chart" $ top num samesignitems
(samesignitems, sign) = sameSignNonZero rawitems (samesignitems, sign) = sameSignNonZero rawitems
rawitems = debug "raw" $ flatten $ balances $ rawitems = debug "raw" $ flatten $ balances $
ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) $ journalToLedger filterspec j ledgerAccountTree (fromMaybe 99999 $ depth_ ropts) $ journalToLedger filterspec j
top n t = topn ++ [other] top n t = topn ++ [other]
where where
(topn,rest) = splitAt n $ reverse $ sortBy (comparing snd) t (topn,rest) = splitAt n $ reverse $ sortBy (comparing snd) t
other = ("other", sum $ map snd rest) other = ("other", sum $ map snd rest)
num = readDef (fromIntegral defchartitems) (getOption opts ChartItems (show defchartitems)) num = chart_items_ opts
hue = if sign > 0 then red else green where (red, green) = (0, 110) hue = if sign > 0 then red else green where (red, green) = (0, 110)
debug s = if Debug `elem` opts then ltrace s else id debug s = if debug_ copts then ltrace s else id
copts = cliopts_ opts
ropts = reportopts_ copts
-- | Select the nonzero items with same sign as the first, and make -- | Select the nonzero items with same sign as the first, and make
-- them positive. Also return a 1 or -1 corresponding to the original sign. -- them positive. Also return a 1 or -1 corresponding to the original sign.

68
hledger-chart/Hledger/Chart/Options.hs Normal file
View File

@ -0,0 +1,68 @@
{-|
-}
module Hledger.Chart.Options
where
import Data.Maybe
import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit
import Hledger.Cli hiding (progname,progversion)
import qualified Hledger.Cli (progname)
progname = Hledger.Cli.progname ++ "-chart"
progversion = progversionstr progname
defchartoutput = "hledger.png"
defchartitems = 10
defchartsize = "600x400"
chartflags = [
flagReq ["chart-output","o"] (\s opts -> Right $ setopt "chart-output" s opts) "IMGFILE" ("output filename (default: "++defchartoutput++")")
,flagReq ["chart-items"] (\s opts -> Right $ setopt "chart-items" s opts) "N" ("number of accounts to show (default: "++show defchartitems++")")
,flagReq ["chart-size"] (\s opts -> Right $ setopt "chart-size" s opts) "WIDTHxHEIGHT" ("image size (default: "++defchartsize++")")
]
chartmode = (mode "hledger-chart" [("command","chart")]
"generate a pie chart image for the top account balances (of one sign only)"
commandargsflag (chartflags++generalflags1)){
modeHelpSuffix=[
-- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui."
]
}
-- hledger-chart options, used in hledger-chart and above
data ChartOpts = ChartOpts {
chart_output_ :: FilePath
,chart_items_ :: Int
,chart_size_ :: String
,cliopts_ :: CliOpts
} deriving (Show)
defchartopts = ChartOpts
def
def
def
def
-- instance Default CliOpts where def = defcliopts
toChartOpts :: RawOpts -> IO ChartOpts
toChartOpts rawopts = do
cliopts <- toCliOpts rawopts
return defchartopts {
chart_output_ = fromMaybe defchartoutput $ maybestringopt "debug-chart" rawopts
,chart_items_ = fromMaybe defchartitems $ maybeintopt "debug-items" rawopts
,chart_size_ = fromMaybe defchartsize $ maybestringopt "debug-size" rawopts
,cliopts_ = cliopts
}
checkChartOpts :: ChartOpts -> IO ChartOpts
checkChartOpts opts = do
checkCliOpts $ cliopts_ opts
return opts
getHledgerChartOpts :: IO ChartOpts
getHledgerChartOpts = processArgs chartmode >>= return . decodeRawOpts >>= toChartOpts >>= checkChartOpts

1
hledger-chart/hledger-chart.cabal
View File

@ -35,6 +35,7 @@ executable hledger-chart
,hledger-lib == 0.15 ,hledger-lib == 0.15
-- ,HUnit -- ,HUnit
,base >= 3 && < 5 ,base >= 3 && < 5
,cmdargs >= 0.7 && < 0.8
,containers ,containers
-- ,csv -- ,csv
-- ,directory -- ,directory

3
hledger-lib/Hledger/Data/Dates.hs
View File

@ -115,6 +115,9 @@ orDatesFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b
parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan) parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan)
parsePeriodExpr refdate = parsewith (periodexpr refdate) parsePeriodExpr refdate = parsewith (periodexpr refdate)
maybePeriod :: Day -> String -> Maybe (Interval,DateSpan)
maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate
-- | Show a DateSpan as a human-readable pseudo-period-expression string. -- | Show a DateSpan as a human-readable pseudo-period-expression string.
dateSpanAsText :: DateSpan -> String dateSpanAsText :: DateSpan -> String
dateSpanAsText (DateSpan Nothing Nothing) = "all" dateSpanAsText (DateSpan Nothing Nothing) = "all"

2
hledger-lib/Hledger/Data/Matching.hs
View File

@ -53,7 +53,7 @@ data Matcher = MatchAny -- ^ always match
-- | A query option changes a query's/report's behaviour and output in some way. -- | A query option changes a query's/report's behaviour and output in some way.
-- XXX could use regular cli Opts ? -- XXX could use regular CliOpts ?
data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account
| QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register | QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register
-- | QueryOptCostBasis -- ^ show amounts converted to cost where possible -- | QueryOptCostBasis -- ^ show amounts converted to cost where possible

2
hledger-lib/Hledger/Data/Types.hs
View File

@ -36,7 +36,7 @@ import Control.Monad.Error (ErrorT)
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Data.Tree import Data.Tree
import Data.Typeable (Typeable) import Data.Typeable
import qualified Data.Map as Map import qualified Data.Map as Map
import System.Time (ClockTime) import System.Time (ClockTime)

2
hledger-lib/Hledger/Read.hs
View File

@ -15,6 +15,8 @@ module Hledger.Read (
myJournal, myJournal,
myTimelog, myTimelog,
someamount, someamount,
journalenvvar,
journaldefaultfilename
) )
where where
import Control.Monad.Error import Control.Monad.Error

81
hledger-vty/Hledger/Vty/Main.hs
View File

@ -12,48 +12,34 @@ import Data.List
import Data.Maybe import Data.Maybe
import Data.Time.Calendar import Data.Time.Calendar
import Graphics.Vty import Graphics.Vty
import Safe (headDef) import Safe
import System.Console.GetOpt import Text.Printf
import Hledger import Hledger
import Prelude hiding (putStr, putStrLn) import Hledger.Cli hiding (progname,progversion)
import Hledger.Utils.UTF8 (putStr, putStrLn) import Hledger.Vty.Options
import Hledger.Cli import Prelude hiding (putStrLn)
import Hledger.Utils.UTF8 (putStrLn)
progname_vty = progname_cli ++ "-vty"
options_vty :: [OptDescr Opt]
options_vty = [
Option "" ["debug-vty"] (NoArg DebugVty) "run with no terminal output, showing console"
]
usage_preamble_vty =
"Usage: hledger-vty [OPTIONS] [PATTERNS]\n" ++
"\n" ++
"Reads your ~/.journal file, or another specified by $LEDGER or -f, and\n" ++
"starts the full-window curses ui.\n" ++
"\n"
usage_options_vty = usageInfo "hledger-vty options:" options_vty ++ "\n"
usage_vty = concat [
usage_preamble_vty
,usage_options_vty
,usage_options_cli
,usage_postscript_cli
]
main :: IO () main :: IO ()
main = do main = do
(opts, args) <- parseArgumentsWith $ options_cli++options_vty opts <- getHledgerVtyOpts
run opts args when (debug_ $ cliopts_ opts) $ printf "%s\n" progversion >> printf "opts: %s\n" (show opts)
runWith opts
runWith :: VtyOpts -> IO ()
runWith opts = run opts
where where
run opts args run opts
| Help `elem` opts = putStr usage_vty | "help" `in_` (rawopts_ $ cliopts_ opts) = printModeHelpAndExit vtymode
| Version `elem` opts = putStrLn $ progversionstr progname_vty | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
| BinaryFilename `elem` opts = putStrLn $ binaryfilename progname_vty | otherwise = withJournalDo' opts vty
| otherwise = withJournalDo opts args "vty" vty
withJournalDo' :: VtyOpts -> (VtyOpts -> Journal -> IO ()) -> IO ()
withJournalDo' opts cmd = do
journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing >>=
either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))
helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit" helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit"
@ -62,10 +48,10 @@ instance Show Vty where show = const "a Vty"
-- | The application state when running the vty command. -- | The application state when running the vty command.
data AppState = AppState { data AppState = AppState {
av :: Vty -- ^ the vty context av :: Vty -- ^ the vty context
,aw :: Int -- ^ window width ,aw :: Int -- ^ window width
,ah :: Int -- ^ window height ,ah :: Int -- ^ window height
,amsg :: String -- ^ status message ,amsg :: String -- ^ status message
,aopts :: [Opt] -- ^ command-line opts ,aopts :: VtyOpts -- ^ command-line opts
,aargs :: [String] -- ^ command-line args at startup ,aargs :: [String] -- ^ command-line args at startup
,ajournal :: Journal -- ^ parsed journal ,ajournal :: Journal -- ^ parsed journal
,abuf :: [String] -- ^ lines of the current buffered view ,abuf :: [String] -- ^ lines of the current buffered view
@ -89,19 +75,19 @@ data Screen = BalanceScreen -- ^ like hledger balance, shows accounts
deriving (Eq,Show) deriving (Eq,Show)
-- | Run the vty (curses-style) ui. -- | Run the vty (curses-style) ui.
vty :: [Opt] -> [String] -> Journal -> IO () vty :: VtyOpts -> Journal -> IO ()
vty opts args j = do vty opts j = do
v <- mkVty v <- mkVty
DisplayRegion w h <- display_bounds $ terminal v DisplayRegion w h <- display_bounds $ terminal v
d <- getCurrentDay d <- getCurrentDay
let a = enter d BalanceScreen args let a = enter d BalanceScreen (patterns_ $ reportopts_ $ cliopts_ opts)
AppState { AppState {
av=v av=v
,aw=fromIntegral w ,aw=fromIntegral w
,ah=fromIntegral h ,ah=fromIntegral h
,amsg=helpmsg ,amsg=helpmsg
,aopts=opts ,aopts=opts
,aargs=args ,aargs=patterns_ $ reportopts_ $ cliopts_ opts
,ajournal=j ,ajournal=j
,abuf=[] ,abuf=[]
,alocs=[] ,alocs=[]
@ -111,7 +97,7 @@ vty opts args j = do
-- | Update the screen, wait for the next event, repeat. -- | Update the screen, wait for the next event, repeat.
go :: AppState -> IO () go :: AppState -> IO ()
go a@AppState{av=av,aopts=opts} = do go a@AppState{av=av,aopts=opts} = do
when (notElem DebugVty opts) $ update av (renderScreen a) when (not $ debug_vty_ opts) $ update av (renderScreen a)
k <- next_event av k <- next_event av
d <- getCurrentDay d <- getCurrentDay
case k of case k of
@ -268,10 +254,11 @@ resetTrailAndEnter d scr a = enter d scr (aargs a) $ clearLocs a
updateData :: Day -> AppState -> AppState updateData :: Day -> AppState -> AppState
updateData d a@AppState{aopts=opts,ajournal=j} = updateData d a@AppState{aopts=opts,ajournal=j} =
case screen a of case screen a of
BalanceScreen -> a{abuf=accountsReportAsText opts $ accountsReport opts fspec j} BalanceScreen -> a{abuf=accountsReportAsText ropts $ accountsReport ropts fspec j}
RegisterScreen -> a{abuf=lines $ postingsReportAsText opts $ postingsReport opts fspec j} RegisterScreen -> a{abuf=lines $ postingsReportAsText ropts $ postingsReport ropts fspec j}
PrintScreen -> a{abuf=lines $ showTransactions opts fspec j} PrintScreen -> a{abuf=lines $ showTransactions ropts fspec j}
where fspec = optsToFilterSpec opts (currentArgs a) d where fspec = optsToFilterSpec ropts{patterns_=currentArgs a} d
ropts = reportopts_ $ cliopts_ opts
backout :: Day -> AppState -> AppState backout :: Day -> AppState -> AppState
backout d a | screen a == BalanceScreen = a backout d a | screen a == BalanceScreen = a

55
hledger-vty/Hledger/Vty/Options.hs Normal file
View File

@ -0,0 +1,55 @@
{-|
-}
module Hledger.Vty.Options
where
import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit
import Hledger.Cli hiding (progname,progversion)
import qualified Hledger.Cli (progname)
progname = Hledger.Cli.progname ++ "-vty"
progversion = progversionstr progname
vtyflags = [
flagNone ["debug-vty"] (\opts -> setboolopt "rules-file" opts) "run with no terminal output, showing console"
]
vtymode = (mode "hledger-vty" [("command","vty")]
"browse accounts, postings and entries in a full-window curses interface"
commandargsflag (vtyflags++generalflags1)){
modeHelpSuffix=[
-- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui."
]
}
-- hledger-vty options, used in hledger-vty and above
data VtyOpts = VtyOpts {
debug_vty_ :: Bool
,cliopts_ :: CliOpts
} deriving (Show)
defvtyopts = VtyOpts
def
def
-- instance Default CliOpts where def = defcliopts
toVtyOpts :: RawOpts -> IO VtyOpts
toVtyOpts rawopts = do
cliopts <- toCliOpts rawopts
return defvtyopts {
debug_vty_ = boolopt "debug-vty" rawopts
,cliopts_ = cliopts
}
checkVtyOpts :: VtyOpts -> IO VtyOpts
checkVtyOpts opts = do
checkCliOpts $ cliopts_ opts
return opts
getHledgerVtyOpts :: IO VtyOpts
getHledgerVtyOpts = processArgs vtymode >>= return . decodeRawOpts >>= toVtyOpts >>= checkVtyOpts

1
hledger-vty/hledger-vty.cabal
View File

@ -35,6 +35,7 @@ executable hledger-vty
,hledger-lib == 0.15 ,hledger-lib == 0.15
-- ,HUnit -- ,HUnit
,base >= 3 && < 5 ,base >= 3 && < 5
,cmdargs >= 0.7 && < 0.8
-- ,containers -- ,containers
-- ,csv -- ,csv
-- ,directory -- ,directory

2
hledger-web/Hledger/Web.hs
View File

@ -7,6 +7,7 @@ module Hledger.Web (
module Hledger.Web.AppRun, module Hledger.Web.AppRun,
module Hledger.Web.EmbeddedFiles, module Hledger.Web.EmbeddedFiles,
module Hledger.Web.Handlers, module Hledger.Web.Handlers,
module Hledger.Web.Options,
module Hledger.Web.Settings, module Hledger.Web.Settings,
module Hledger.Web.StaticFiles, module Hledger.Web.StaticFiles,
tests_Hledger_Web tests_Hledger_Web
@ -18,6 +19,7 @@ import Hledger.Web.App
import Hledger.Web.AppRun import Hledger.Web.AppRun
import Hledger.Web.EmbeddedFiles import Hledger.Web.EmbeddedFiles
import Hledger.Web.Handlers import Hledger.Web.Handlers
import Hledger.Web.Options
import Hledger.Web.Settings import Hledger.Web.Settings
import Hledger.Web.StaticFiles import Hledger.Web.StaticFiles

7
hledger-web/Hledger/Web/App.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Web.App module Hledger.Web.App
( App (..) ( App (..)
, AppRoute (..) , AppRoute (..)
@ -22,8 +21,8 @@ import Text.Hamlet hiding (hamletFile)
import Yesod.Core import Yesod.Core
import Yesod.Helpers.Static import Yesod.Helpers.Static
import Hledger.Cli.Options
import Hledger.Data import Hledger.Data
import Hledger.Web.Options
import Hledger.Web.Settings import Hledger.Web.Settings
import Hledger.Web.StaticFiles import Hledger.Web.StaticFiles
@ -34,7 +33,7 @@ import Hledger.Web.StaticFiles
data App = App data App = App
{getStatic :: Static -- ^ Settings for static file serving. {getStatic :: Static -- ^ Settings for static file serving.
,appRoot :: T.Text ,appRoot :: T.Text
,appOpts :: [Opt] ,appOpts :: WebOpts
,appArgs :: [String] ,appArgs :: [String]
,appJournal :: Journal ,appJournal :: Journal
} }

5
hledger-web/Hledger/Web/AppRun.hs
View File

@ -18,6 +18,7 @@ import Hledger
import Hledger.Cli import Hledger.Cli
import Hledger.Web.App import Hledger.Web.App
import Hledger.Web.Handlers import Hledger.Web.Handlers
import Hledger.Web.Options
import Hledger.Web.Settings import Hledger.Web.Settings
-- This line actually creates our YesodSite instance. It is the second half -- This line actually creates our YesodSite instance. It is the second half
@ -38,7 +39,7 @@ withDevelApp = toDyn (withApp a :: (Application -> IO ()) -> IO ())
where a = App{ where a = App{
getStatic=static Hledger.Web.Settings.staticdir getStatic=static Hledger.Web.Settings.staticdir
,appRoot=Hledger.Web.Settings.defapproot ,appRoot=Hledger.Web.Settings.defapproot
,appOpts=[] ,appOpts=defwebopts
,appArgs=[] ,appArgs=[]
,appJournal=nulljournal ,appJournal=nulljournal
} }
@ -53,7 +54,7 @@ withWaiHandlerDevelApp func = do
let a = App{ let a = App{
getStatic=static Hledger.Web.Settings.staticdir getStatic=static Hledger.Web.Settings.staticdir
,appRoot=Settings.defapproot ,appRoot=Settings.defapproot
,appOpts=[File f] ,appOpts=defwebopts{cliopts_=defcliopts{file_=Just f}}
,appArgs=[] ,appArgs=[]
,appJournal=j ,appJournal=j
} }

37
hledger-web/Hledger/Web/Handlers.hs
View File

@ -29,6 +29,7 @@ import Yesod.Json
import Hledger hiding (today) import Hledger hiding (today)
import Hledger.Cli import Hledger.Cli
import Hledger.Web.App import Hledger.Web.App
import Hledger.Web.Options
import Hledger.Web.Settings import Hledger.Web.Settings
@ -60,7 +61,7 @@ getJournalR = do
where andsubs = if subs then " (and subaccounts)" else "" where andsubs = if subs then " (and subaccounts)" else ""
where where
filter = if filtering then ", filtered" else "" filter = if filtering then ", filtered" else ""
maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport opts j m maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web journal" setTitle "hledger-web journal"
addHamlet [$hamlet| addHamlet [$hamlet|
@ -93,7 +94,7 @@ getJournalEntriesR = do
let let
sidecontent = sidebar vd sidecontent = sidebar vd
title = "Journal entries" ++ if m /= MatchAny then ", filtered" else "" :: String title = "Journal entries" ++ if m /= MatchAny then ", filtered" else "" :: String
maincontent = entriesReportAsHtml opts vd $ entriesReport opts nullfilterspec $ filterJournalTransactions2 m j maincontent = entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web journal" setTitle "hledger-web journal"
addHamlet [$hamlet| addHamlet [$hamlet|
@ -117,7 +118,7 @@ getJournalOnlyR = do
vd@VD{..} <- getViewData vd@VD{..} <- getViewData
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web journal only" setTitle "hledger-web journal only"
addHamlet $ entriesReportAsHtml opts vd $ entriesReport opts nullfilterspec $ filterJournalTransactions2 m j addHamlet $ entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j
---------------------------------------------------------------------- ----------------------------------------------------------------------
@ -133,7 +134,7 @@ getRegisterR = do
(a,subs) = fromMaybe ("all accounts",False) $ inAccount qopts (a,subs) = fromMaybe ("all accounts",False) $ inAccount qopts
andsubs = if subs then " (and subaccounts)" else "" andsubs = if subs then " (and subaccounts)" else ""
filter = if filtering then ", filtered" else "" filter = if filtering then ", filtered" else ""
maincontent = registerReportHtml opts vd $ accountTransactionsReport opts j m $ fromMaybe MatchAny $ inAccountMatcher qopts maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe MatchAny $ inAccountMatcher qopts
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web register" setTitle "hledger-web register"
addHamlet [$hamlet| addHamlet [$hamlet|
@ -158,8 +159,8 @@ getRegisterOnlyR = do
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web register only" setTitle "hledger-web register only"
addHamlet $ addHamlet $
case inAccountMatcher qopts of Just m' -> registerReportHtml opts vd $ accountTransactionsReport opts j m m' case inAccountMatcher qopts of Just m' -> registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m m'
Nothing -> registerReportHtml opts vd $ journalTransactionsReport opts j m Nothing -> registerReportHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
---------------------------------------------------------------------- ----------------------------------------------------------------------
@ -171,7 +172,7 @@ getAccountsR = do
let j' = filterJournalPostings2 m j let j' = filterJournalPostings2 m j
html = do html = do
setTitle "hledger-web accounts" setTitle "hledger-web accounts"
addHamlet $ accountsReportAsHtml opts vd $ accountsReport2 opts am j' addHamlet $ accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j'
json = jsonMap [("accounts", toJSON $ journalAccountNames j')] json = jsonMap [("accounts", toJSON $ journalAccountNames j')]
defaultLayoutJson html json defaultLayoutJson html json
@ -187,10 +188,10 @@ getAccountsJsonR = do
-- | Render the sidebar used on most views. -- | Render the sidebar used on most views.
sidebar :: ViewData -> Hamlet AppRoute sidebar :: ViewData -> Hamlet AppRoute
sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport2 opts am j sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j
-- | Render a "AccountsReport" as HTML. -- | Render a "AccountsReport" as HTML.
accountsReportAsHtml :: [Opt] -> ViewData -> AccountsReport -> Hamlet AppRoute accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> Hamlet AppRoute
accountsReportAsHtml _ vd@VD{..} (items',total) = accountsReportAsHtml _ vd@VD{..} (items',total) =
[$hamlet| [$hamlet|
<div#accountsheading <div#accountsheading
@ -271,7 +272,7 @@ accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRe
accountUrl r a = (r, [("q",pack $ accountQuery a)]) accountUrl r a = (r, [("q",pack $ accountQuery a)])
-- | Render a "EntriesReport" as HTML for the journal entries view. -- | Render a "EntriesReport" as HTML for the journal entries view.
entriesReportAsHtml :: [Opt] -> ViewData -> EntriesReport -> Hamlet AppRoute entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> Hamlet AppRoute
entriesReportAsHtml _ vd items = [$hamlet| entriesReportAsHtml _ vd items = [$hamlet|
<table.journalreport> <table.journalreport>
$forall i <- numbered items $forall i <- numbered items
@ -289,7 +290,7 @@ entriesReportAsHtml _ vd items = [$hamlet|
txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse
-- | Render an "TransactionsReport" as HTML for the formatted journal view. -- | Render an "TransactionsReport" as HTML for the formatted journal view.
journalTransactionsReportAsHtml :: [Opt] -> ViewData -> TransactionsReport -> Hamlet AppRoute journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute
journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet| journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|
<table.journalreport <table.journalreport
<tr.headings <tr.headings
@ -327,14 +328,14 @@ $forall p <- tpostings t
showamt = not split || not (isZeroMixedAmount amt) showamt = not split || not (isZeroMixedAmount amt)
-- Generate html for an account register, including a balance chart and transaction list. -- Generate html for an account register, including a balance chart and transaction list.
registerReportHtml :: [Opt] -> ViewData -> TransactionsReport -> Hamlet AppRoute registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute
registerReportHtml opts vd r@(_,items) = [$hamlet| registerReportHtml opts vd r@(_,items) = [$hamlet|
^{registerChartHtml items} ^{registerChartHtml items}
^{registerItemsHtml opts vd r} ^{registerItemsHtml opts vd r}
|] |]
-- Generate html for a transaction list from an "TransactionsReport". -- Generate html for a transaction list from an "TransactionsReport".
registerItemsHtml :: [Opt] -> ViewData -> TransactionsReport -> Hamlet AppRoute registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute
registerItemsHtml _ vd (balancelabel,items) = [$hamlet| registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
<table.registerreport <table.registerreport
<tr.headings <tr.headings
@ -825,7 +826,7 @@ nulltemplate = [$hamlet||]
-- | A bundle of data useful for hledger-web request handlers and templates. -- | A bundle of data useful for hledger-web request handlers and templates.
data ViewData = VD { data ViewData = VD {
opts :: [Opt] -- ^ the command-line options at startup opts :: WebOpts -- ^ the command-line options at startup
,here :: AppRoute -- ^ the current route ,here :: AppRoute -- ^ the current route
,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request ,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request
,today :: Day -- ^ today's date (for queries containing relative dates) ,today :: Day -- ^ today's date (for queries containing relative dates)
@ -848,7 +849,7 @@ viewdataWithDateAndParams d q a p =
let (querymatcher,queryopts) = parseQuery d q let (querymatcher,queryopts) = parseQuery d q
(acctsmatcher,acctsopts) = parseQuery d a (acctsmatcher,acctsopts) = parseQuery d a
in VD { in VD {
opts = [NoElide] opts = defwebopts{cliopts_=defcliopts{reportopts_=defreportopts{no_elide_=True}}}
,j = nulljournal ,j = nulljournal
,here = RootR ,here = RootR
,msg = Nothing ,msg = Nothing
@ -865,8 +866,8 @@ viewdataWithDateAndParams d q a p =
getViewData :: Handler ViewData getViewData :: Handler ViewData
getViewData = do getViewData = do
app <- getYesod app <- getYesod
let opts = appOpts app ++ [NoElide] let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app
(j, err) <- getCurrentJournal opts (j, err) <- getCurrentJournal $ copts{reportopts_=ropts{no_elide_=True}}
msg <- getMessageOr err msg <- getMessageOr err
Just here <- getCurrentRoute Just here <- getCurrentRoute
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
@ -884,7 +885,7 @@ getViewData = do
-- | Update our copy of the journal if the file changed. If there is an -- | Update our copy of the journal if the file changed. If there is an
-- error while reloading, keep the old one and return the error, and set a -- error while reloading, keep the old one and return the error, and set a
-- ui message. -- ui message.
getCurrentJournal :: [Opt] -> Handler (Journal, Maybe String) getCurrentJournal :: CliOpts -> Handler (Journal, Maybe String)
getCurrentJournal opts = do getCurrentJournal opts = do
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
(jE, changed) <- liftIO $ journalReloadIfChanged opts j (jE, changed) <- liftIO $ journalReloadIfChanged opts j

66
hledger-web/Hledger/Web/Options.hs Normal file
View File

@ -0,0 +1,66 @@
{-|
-}
module Hledger.Web.Options
where
import Data.Maybe
import Data.Text (unpack)
import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit
import Hledger.Cli hiding (progname,progversion)
import qualified Hledger.Cli (progname)
import Hledger.Web.Settings
progname = Hledger.Cli.progname ++ "-web"
progversion = progversionstr progname
defbaseurl = unpack defapproot
defbaseurl' = (reverse $ drop 4 $ reverse defbaseurl) ++ "PORT"
webflags = [
flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "URL" ("set the base url (default: "++defbaseurl'++")")
,flagReq ["port"] (\s opts -> Right $ setopt "port" s opts) "PORT" ("listen on this tcp port (default: "++show defport++")")
]
webmode = (mode "hledger-web" [("command","web")]
"start serving the hledger web interface"
commandargsflag (webflags++generalflags1)){
modeHelpSuffix=[
-- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui."
]
}
-- hledger-web options, used in hledger-web and above
data WebOpts = WebOpts {
base_url_ :: String
,port_ :: Int
,cliopts_ :: CliOpts
} deriving (Show)
defwebopts = WebOpts
def
def
def
-- instance Default WebOpts where def = defwebopts
toWebOpts :: RawOpts -> IO WebOpts
toWebOpts rawopts = do
cliopts <- toCliOpts rawopts
return defwebopts {
base_url_ = fromMaybe defbaseurl $ maybestringopt "base-url" rawopts
,port_ = fromMaybe defport $ maybeintopt "port" rawopts
,cliopts_ = cliopts
}
checkWebOpts :: WebOpts -> IO WebOpts
checkWebOpts opts = do
checkCliOpts $ cliopts_ opts
return opts
getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts = processArgs webmode >>= return . decodeRawOpts >>= toWebOpts >>= checkWebOpts

1
hledger-web/hledger-web.cabal
View File

@ -64,6 +64,7 @@ executable hledger-web
,HUnit ,HUnit
,base >= 4 && < 5 ,base >= 4 && < 5
,bytestring ,bytestring
,cmdargs >= 0.7 && < 0.8
-- ,containers -- ,containers
-- ,csv -- ,csv
,directory ,directory

78
hledger-web/hledger-web.hs
View File

@ -9,6 +9,7 @@ module Main
where where
-- import Control.Concurrent (forkIO, threadDelay) -- import Control.Concurrent (forkIO, threadDelay)
import Control.Monad
import Data.Maybe import Data.Maybe
import Data.Text(pack) import Data.Text(pack)
import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.Warp (run)
@ -16,58 +17,41 @@ import Network.Wai.Handler.Warp (run)
#else #else
import Network.Wai.Middleware.Debug (debug) import Network.Wai.Middleware.Debug (debug)
#endif #endif
import System.Console.GetOpt
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.IO.Storage (withStore, putValue) import System.IO.Storage (withStore, putValue)
import Text.Printf import Text.Printf
import Yesod.Helpers.Static import Yesod.Helpers.Static
import Hledger.Cli import Hledger
import Hledger.Cli.Tests (runTestsOrExit) import Hledger.Cli hiding (progname,progversion)
import Hledger.Data import Hledger.Cli.Tests
import Prelude hiding (putStr, putStrLn) import Prelude hiding (putStrLn)
import Hledger.Utils.UTF8 (putStr, putStrLn) import Hledger.Utils.UTF8 (putStrLn)
import Hledger.Web import Hledger.Web
progname_web = progname_cli ++ "-web"
options_web :: [OptDescr Opt]
options_web = [
Option "" ["base-url"] (ReqArg BaseUrl "URL") "use this base url (default http://localhost:PORT)"
,Option "" ["port"] (ReqArg Port "N") "serve on tcp port N (default 5000)"
]
usage_preamble_web =
"Usage: hledger-web [OPTIONS] [PATTERNS]\n" ++
"\n" ++
"Reads your ~/.journal file, or another specified by $LEDGER or -f, and\n" ++
"starts a web ui server. Also attempts to start a web browser (unless --debug).\n" ++
"\n"
usage_options_web = usageInfo "hledger-web options:" options_web ++ "\n"
usage_web = concat [
usage_preamble_web
,usage_options_web
,usage_options_cli
,usage_postscript_cli
]
main :: IO () main :: IO ()
main = do main = do
(opts, args) <- parseArgumentsWith $ options_cli++options_web opts <- getHledgerWebOpts
run opts args when (debug_ $ cliopts_ opts) $ printf "%s\n" progversion >> printf "opts: %s\n" (show opts)
runWith opts
runWith :: WebOpts -> IO ()
runWith opts = run opts
where where
run opts args run opts
| Help `elem` opts = putStr usage_web | "help" `in_` (rawopts_ $ cliopts_ opts) = printModeHelpAndExit webmode
| Version `elem` opts = putStrLn $ progversionstr progname_web | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
| BinaryFilename `elem` opts = putStrLn $ binaryfilename progname_web | otherwise = withJournalDo' opts web
| otherwise = withJournalDo opts args "web" web
withJournalDo' :: WebOpts -> (WebOpts -> Journal -> IO ()) -> IO ()
withJournalDo' opts cmd = do
journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing >>=
either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))
-- | The web command. -- | The web command.
web :: [Opt] -> [String] -> Journal -> IO () web :: WebOpts -> Journal -> IO ()
web opts args j = do web opts j = do
created <- createFilesIfMissing created <- createFilesIfMissing
if created if created
then do then do
@ -75,13 +59,10 @@ web opts args j = do
exitFailure exitFailure
else do else do
putStrLn $ "Running self-tests..." putStrLn $ "Running self-tests..."
runTestsOrExit opts args runTestsOrExit $ cliopts_ opts
putStrLn $ "Using support files in "++datadir putStrLn $ "Using support files in "++datadir
let host = defhost -- unless (debug_ $ cliopts_ opts) $ forkIO (browser baseurl) >> return ()
port = fromMaybe defport $ portFromOpts opts server (base_url_ opts) (port_ opts) opts j
baseurl = fromMaybe (printf "http://%s:%d" host port) $ baseUrlFromOpts opts
-- unless (Debug `elem` opts) $ forkIO (browser baseurl) >> return ()
server baseurl port opts args j
-- browser :: String -> IO () -- browser :: String -> IO ()
-- browser baseurl = do -- browser baseurl = do
@ -89,17 +70,18 @@ web opts args j = do
-- putStrLn "Attempting to start a web browser" -- putStrLn "Attempting to start a web browser"
-- openBrowserOn baseurl >> return () -- openBrowserOn baseurl >> return ()
server :: String -> Int -> [Opt] -> [String] -> Journal -> IO () server :: String -> Int -> WebOpts -> Journal -> IO ()
server baseurl port opts args j = do server baseurl port opts j = do
printf "Starting http server on port %d with base url %s\n" port baseurl printf "Starting http server on port %d with base url %s\n" port baseurl
let a = App{getStatic=static staticdir let a = App{getStatic=static staticdir
,appRoot=pack baseurl ,appRoot=pack baseurl
,appOpts=opts ,appOpts=opts
,appArgs=args ,appArgs=patterns_ $ reportopts_ $ cliopts_ opts
,appJournal=j ,appJournal=j
} }
withStore "hledger" $ do withStore "hledger" $ do
putValue "hledger" "journal" j putValue "hledger" "journal" j
return ()
#if PRODUCTION #if PRODUCTION
withApp a (run port) withApp a (run port)
#else #else

93
hledger/Hledger/Cli.hs
View File

@ -37,7 +37,6 @@ import Hledger.Cli.Options
import Hledger.Cli.Utils import Hledger.Cli.Utils
import Hledger.Cli.Version import Hledger.Cli.Version
-- | hledger and hledger-lib's unit tests aggregated from all modules -- | hledger and hledger-lib's unit tests aggregated from all modules
-- plus some more which are easier to define here for now. -- plus some more which are easier to define here for now.
tests_Hledger_Cli :: Test tests_Hledger_Cli :: Test
@ -108,15 +107,14 @@ tests_Hledger_Cli = TestList
"liabilities","liabilities:credit cards","liabilities:credit cards:discover"] "liabilities","liabilities:credit cards","liabilities:credit cards:discover"]
,"balance report tests" ~: ,"balance report tests" ~:
let (opts,args) `gives` es = do let opts `gives` es = do
j <- samplejournal j <- samplejournal
d <- getCurrentDay d <- getCurrentDay
accountsReportAsText opts (accountsReport opts (optsToFilterSpec opts args d) j) `is` es accountsReportAsText opts (accountsReport opts (optsToFilterSpec opts d) j) `is` es
in TestList in TestList
[ [
"balance report with no args" ~: "balance report with no args" ~:
([], []) `gives` defreportopts `gives`
[" $-1 assets" [" $-1 assets"
," $1 bank:saving" ," $1 bank:saving"
," $-2 cash" ," $-2 cash"
@ -132,7 +130,7 @@ tests_Hledger_Cli = TestList
] ]
,"balance report can be limited with --depth" ~: ,"balance report can be limited with --depth" ~:
([Depth "1"], []) `gives` defreportopts{depth_=Just 1} `gives`
[" $-1 assets" [" $-1 assets"
," $2 expenses" ," $2 expenses"
," $-2 income" ," $-2 income"
@ -142,7 +140,7 @@ tests_Hledger_Cli = TestList
] ]
,"balance report with account pattern o" ~: ,"balance report with account pattern o" ~:
([], ["o"]) `gives` defreportopts{patterns_=["o"]} `gives`
[" $1 expenses:food" [" $1 expenses:food"
," $-2 income" ," $-2 income"
," $-1 gifts" ," $-1 gifts"
@ -152,7 +150,7 @@ tests_Hledger_Cli = TestList
] ]
,"balance report with account pattern o and --depth 1" ~: ,"balance report with account pattern o and --depth 1" ~:
([Depth "1"], ["o"]) `gives` defreportopts{patterns_=["o"],depth_=Just 1} `gives`
[" $1 expenses" [" $1 expenses"
," $-2 income" ," $-2 income"
,"--------------------" ,"--------------------"
@ -160,7 +158,7 @@ tests_Hledger_Cli = TestList
] ]
,"balance report with account pattern a" ~: ,"balance report with account pattern a" ~:
([], ["a"]) `gives` defreportopts{patterns_=["a"]} `gives`
[" $-1 assets" [" $-1 assets"
," $1 bank:saving" ," $1 bank:saving"
," $-2 cash" ," $-2 cash"
@ -171,7 +169,7 @@ tests_Hledger_Cli = TestList
] ]
,"balance report with account pattern e" ~: ,"balance report with account pattern e" ~:
([], ["e"]) `gives` defreportopts{patterns_=["e"]} `gives`
[" $-1 assets" [" $-1 assets"
," $1 bank:saving" ," $1 bank:saving"
," $-2 cash" ," $-2 cash"
@ -187,7 +185,7 @@ tests_Hledger_Cli = TestList
] ]
,"balance report with unmatched parent of two matched subaccounts" ~: ,"balance report with unmatched parent of two matched subaccounts" ~:
([], ["cash","saving"]) `gives` defreportopts{patterns_=["cash","saving"]} `gives`
[" $-1 assets" [" $-1 assets"
," $1 bank:saving" ," $1 bank:saving"
," $-2 cash" ," $-2 cash"
@ -196,14 +194,14 @@ tests_Hledger_Cli = TestList
] ]
,"balance report with multi-part account name" ~: ,"balance report with multi-part account name" ~:
([], ["expenses:food"]) `gives` defreportopts{patterns_=["expenses:food"]} `gives`
[" $1 expenses:food" [" $1 expenses:food"
,"--------------------" ,"--------------------"
," $1" ," $1"
] ]
,"balance report with negative account pattern" ~: ,"balance report with negative account pattern" ~:
([], ["not:assets"]) `gives` defreportopts{patterns_=["not:assets"]} `gives`
[" $2 expenses" [" $2 expenses"
," $1 food" ," $1 food"
," $1 supplies" ," $1 supplies"
@ -216,20 +214,20 @@ tests_Hledger_Cli = TestList
] ]
,"balance report negative account pattern always matches full name" ~: ,"balance report negative account pattern always matches full name" ~:
([], ["not:e"]) `gives` defreportopts{patterns_=["not:e"]} `gives`
["--------------------" ["--------------------"
," 0" ," 0"
] ]
,"balance report negative patterns affect totals" ~: ,"balance report negative patterns affect totals" ~:
([], ["expenses","not:food"]) `gives` defreportopts{patterns_=["expenses","not:food"]} `gives`
[" $1 expenses:supplies" [" $1 expenses:supplies"
,"--------------------" ,"--------------------"
," $1" ," $1"
] ]
,"balance report with -E shows zero-balance accounts" ~: ,"balance report with -E shows zero-balance accounts" ~:
([Empty], ["assets"]) `gives` defreportopts{patterns_=["assets"],empty_=True} `gives`
[" $-1 assets" [" $-1 assets"
," $1 bank" ," $1 bank"
," 0 checking" ," 0 checking"
@ -247,7 +245,7 @@ tests_Hledger_Cli = TestList
," c:d " ," c:d "
]) >>= either error' return ]) >>= either error' return
let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment
accountsReportAsText [] (accountsReport [] nullfilterspec j') `is` accountsReportAsText defreportopts (accountsReport defreportopts nullfilterspec j') `is`
[" $500 a:b" [" $500 a:b"
," $-500 c:d" ," $-500 c:d"
,"--------------------" ,"--------------------"
@ -261,7 +259,7 @@ tests_Hledger_Cli = TestList
," test:a 1" ," test:a 1"
," test:b" ," test:b"
]) ])
accountsReportAsText [] (accountsReport [] nullfilterspec j) `is` accountsReportAsText defreportopts (accountsReport defreportopts nullfilterspec j) `is`
[" 1 test:a" [" 1 test:a"
," -1 test:b" ," -1 test:b"
,"--------------------" ,"--------------------"
@ -294,11 +292,10 @@ tests_Hledger_Cli = TestList
"print expenses" ~: "print expenses" ~:
do do
let args = ["expenses"] let opts = defreportopts{patterns_=["expenses"]}
opts = []
j <- samplejournal j <- samplejournal
d <- getCurrentDay d <- getCurrentDay
showTransactions opts (optsToFilterSpec opts args d) j `is` unlines showTransactions opts (optsToFilterSpec opts d) j `is` unlines
["2008/06/03 * eat & shop" ["2008/06/03 * eat & shop"
," expenses:food $1" ," expenses:food $1"
," expenses:supplies $1" ," expenses:supplies $1"
@ -308,9 +305,10 @@ tests_Hledger_Cli = TestList
, "print report with depth arg" ~: , "print report with depth arg" ~:
do do
let opts = defreportopts{depth_=Just 2}
j <- samplejournal j <- samplejournal
d <- getCurrentDay d <- getCurrentDay
showTransactions [] (optsToFilterSpec [Depth "2"] [] d) j `is` unlines showTransactions opts (optsToFilterSpec opts d) j `is` unlines
["2008/01/01 income" ["2008/01/01 income"
," income:salary $-1" ," income:salary $-1"
,"" ,""
@ -338,7 +336,8 @@ tests_Hledger_Cli = TestList
"register report with no args" ~: "register report with no args" ~:
do do
j <- samplejournal j <- samplejournal
(postingsReportAsText [] $ postingsReport [] (optsToFilterSpec [] [] date1) j) `is` unlines let opts = defreportopts
(postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `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"
,"2008/06/01 gift assets:bank:checking $1 $1" ,"2008/06/01 gift assets:bank:checking $1 $1"
@ -354,9 +353,9 @@ tests_Hledger_Cli = TestList
,"register report with cleared option" ~: ,"register report with cleared option" ~:
do do
let opts = [Cleared] let opts = defreportopts{cleared_=True}
j <- readJournal' sample_journal_str j <- readJournal' sample_journal_str
(postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] date1) j) `is` unlines (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `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"
," assets:cash $-2 0" ," assets:cash $-2 0"
@ -366,9 +365,9 @@ tests_Hledger_Cli = TestList
,"register report with uncleared option" ~: ,"register report with uncleared option" ~:
do do
let opts = [UnCleared] let opts = defreportopts{uncleared_=True}
j <- readJournal' sample_journal_str j <- readJournal' sample_journal_str
(postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] date1) j) `is` unlines (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `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"
,"2008/06/01 gift assets:bank:checking $1 $1" ,"2008/06/01 gift assets:bank:checking $1 $1"
@ -388,19 +387,22 @@ tests_Hledger_Cli = TestList
," e 1" ," e 1"
," f" ," f"
] ]
registerdates (postingsReportAsText [] $ postingsReport [] (optsToFilterSpec [] [] date1) j) `is` ["2008/01/01","2008/02/02"] let opts = defreportopts
registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` ["2008/01/01","2008/02/02"]
,"register report with account pattern" ~: ,"register report with account pattern" ~:
do do
j <- samplejournal j <- samplejournal
(postingsReportAsText [] $ postingsReport [] (optsToFilterSpec [] ["cash"] date1) j) `is` unlines let opts = defreportopts{patterns_=["cash"]}
(postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines
["2008/06/03 eat & shop assets:cash $-2 $-2" ["2008/06/03 eat & shop assets:cash $-2 $-2"
] ]
,"register report with account pattern, case insensitive" ~: ,"register report with account pattern, case insensitive" ~:
do do
j <- samplejournal j <- samplejournal
(postingsReportAsText [] $ postingsReport [] (optsToFilterSpec [] ["cAsH"] date1) j) `is` unlines let opts = defreportopts{patterns_=["cAsH"]}
(postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines
["2008/06/03 eat & shop assets:cash $-2 $-2" ["2008/06/03 eat & shop assets:cash $-2 $-2"
] ]
@ -408,8 +410,8 @@ tests_Hledger_Cli = TestList
do do
j <- samplejournal j <- samplejournal
let gives displayexpr = let gives displayexpr =
(registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] date1) j) `is`) (registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is`)
where opts = [Display displayexpr] where opts = defreportopts{display_=Just displayexpr}
"d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"] "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"]
"d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"] "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]
"d=[2008/6/2]" `gives` ["2008/06/02"] "d=[2008/6/2]" `gives` ["2008/06/02"]
@ -421,16 +423,16 @@ tests_Hledger_Cli = TestList
j <- samplejournal j <- samplejournal
let periodexpr `gives` dates = do let periodexpr `gives` dates = do
j' <- samplejournal j' <- samplejournal
registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] date1) j') `is` dates registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j') `is` dates
where opts = [Period periodexpr] where opts = defreportopts{period_=maybePeriod date1 periodexpr}
"" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]
"2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]
"2007" `gives` [] "2007" `gives` []
"june" `gives` ["2008/06/01","2008/06/02","2008/06/03"] "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"]
"monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"] "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]
"quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"] "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"]
let opts = [Period "yearly"] let opts = defreportopts{period_=maybePeriod date1 "yearly"}
(postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] date1) j) `is` unlines (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines
["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1" ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1"
," assets:cash $-2 $-1" ," assets:cash $-2 $-1"
," expenses:food $1 0" ," expenses:food $1 0"
@ -439,18 +441,18 @@ tests_Hledger_Cli = TestList
," income:salary $-1 $-1" ," income:salary $-1 $-1"
," liabilities:debts $1 0" ," liabilities:debts $1 0"
] ]
let opts = [Period "quarterly"] let opts = defreportopts{period_=maybePeriod date1 "quarterly"}
registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] date1) j) `is` ["2008/01/01","2008/04/01","2008/10/01"] registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` ["2008/01/01","2008/04/01","2008/10/01"]
let opts = [Period "quarterly",Empty] let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True}
registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] date1) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]
] ]
, "register report with depth arg" ~: , "register report with depth arg" ~:
do do
j <- samplejournal j <- samplejournal
let opts = [Depth "2"] let opts = defreportopts{depth_=Just 2}
(postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] date1) j) `is` unlines (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines
["2008/01/01 income assets:bank $1 $1" ["2008/01/01 income assets:bank $1 $1"
," income:salary $-1 0" ," income:salary $-1 0"
,"2008/06/01 gift assets:bank $1 $1" ,"2008/06/01 gift assets:bank $1 $1"
@ -471,7 +473,8 @@ tests_Hledger_Cli = TestList
,"unicode in balance layout" ~: do ,"unicode in balance layout" ~: do
j <- readJournal' j <- readJournal'
"2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
accountsReportAsText [] (accountsReport [] (optsToFilterSpec [] [] date1) j) `is` let opts = defreportopts
accountsReportAsText opts (accountsReport opts (optsToFilterSpec opts date1) j) `is`
[" -100 актив:наличные" [" -100 актив:наличные"
," 100 расходы:покупки" ," 100 расходы:покупки"
,"--------------------" ,"--------------------"
@ -481,7 +484,8 @@ tests_Hledger_Cli = TestList
,"unicode in register layout" ~: do ,"unicode in register layout" ~: do
j <- readJournal' j <- readJournal'
"2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
(postingsReportAsText [] $ postingsReport [] (optsToFilterSpec [] [] date1) j) `is` unlines let opts = defreportopts
(postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines
["2009/01/01 медвежья шкура расходы:покупки 100 100" ["2009/01/01 медвежья шкура расходы:покупки 100 100"
," актив:наличные -100 0"] ," актив:наличные -100 0"]
@ -921,4 +925,3 @@ journalWithAmounts as =
[] []
(TOD 0 0) (TOD 0 0)
where parse = fromparse . parseWithCtx nullctx someamount where parse = fromparse . parseWithCtx nullctx someamount

30
hledger/Hledger/Cli/Add.hs
View File

@ -49,8 +49,8 @@ data PostingState = PostingState {
-- | Read transactions from the terminal, prompting for each field, -- | Read transactions from the terminal, prompting for each field,
-- and append them to the journal file. If the journal came from stdin, this -- and append them to the journal file. If the journal came from stdin, this
-- command has no effect. -- command has no effect.
add :: [Opt] -> [String] -> Journal -> IO () add :: CliOpts -> Journal -> IO ()
add opts args j add opts j
| f == "-" = return () | f == "-" = return ()
| otherwise = do | otherwise = do
hPutStrLn stderr $ hPutStrLn stderr $
@ -58,7 +58,7 @@ add opts args j
++"To complete a transaction, enter . when prompted for an account.\n" ++"To complete a transaction, enter . when prompted for an account.\n"
++"To quit, press control-d or control-c." ++"To quit, press control-d or control-c."
today <- getCurrentDay today <- getCurrentDay
getAndAddTransactions j opts args today getAndAddTransactions j opts today
`catch` (\e -> unless (isEOFError e) $ ioError e) `catch` (\e -> unless (isEOFError e) $ ioError e)
where f = journalFilePath j where f = journalFilePath j
@ -66,29 +66,29 @@ add opts args j
-- validating, displaying and appending them to the journal file, until -- validating, displaying and appending them to the journal file, until
-- end of input (then raise an EOF exception). Any command-line arguments -- end of input (then raise an EOF exception). Any command-line arguments
-- are used as the first transaction's description. -- are used as the first transaction's description.
getAndAddTransactions :: Journal -> [Opt] -> [String] -> Day -> IO () getAndAddTransactions :: Journal -> CliOpts -> Day -> IO ()
getAndAddTransactions j opts args defaultDate = do getAndAddTransactions j opts defaultDate = do
(t, d) <- getTransaction j opts args defaultDate (t, d) <- getTransaction j opts defaultDate
j <- journalAddTransaction j opts t j <- journalAddTransaction j opts t
getAndAddTransactions j opts args d getAndAddTransactions j opts d
-- | Read a transaction from the command line, with history-aware prompting. -- | Read a transaction from the command line, with history-aware prompting.
getTransaction :: Journal -> [Opt] -> [String] -> Day getTransaction :: Journal -> CliOpts -> Day
-> IO (Transaction,Day) -> IO (Transaction,Day)
getTransaction j opts args defaultDate = do getTransaction j opts defaultDate = do
today <- getCurrentDay today <- getCurrentDay
datestr <- runInteractionDefault $ askFor "date" datestr <- runInteractionDefault $ askFor "date"
(Just $ showDate defaultDate) (Just $ showDate defaultDate)
(Just $ \s -> null s || (Just $ \s -> null s ||
isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s)) isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
description <- runInteractionDefault $ askFor "description" (Just "") Nothing description <- runInteractionDefault $ askFor "description" (Just "") Nothing
let historymatches = transactionsSimilarTo j args description let historymatches = transactionsSimilarTo j (patterns_ $ reportopts_ opts) description
bestmatch | null historymatches = Nothing bestmatch | null historymatches = Nothing
| otherwise = Just $ snd $ head historymatches | otherwise = Just $ snd $ head historymatches
bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch
date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr
accept x = x == "." || (not . null) x && accept x = x == "." || (not . null) x &&
if NoNewAccts `elem` opts if no_new_accounts_ opts
then isJust $ Foldable.find (== x) ant then isJust $ Foldable.find (== x) ant
else True else True
where (ant,_,_,_) = groupPostings $ journalPostings j where (ant,_,_,_) = groupPostings $ journalPostings j
@ -190,11 +190,11 @@ askFor prompt def validator = do
-- | Append this transaction to the journal's file, and to the journal's -- | Append this transaction to the journal's file, and to the journal's
-- transaction list. -- transaction list.
journalAddTransaction :: Journal -> [Opt] -> Transaction -> IO Journal journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal
journalAddTransaction j@Journal{jtxns=ts} opts t = do journalAddTransaction j@Journal{jtxns=ts} opts t = do
let f = journalFilePath j let f = journalFilePath j
appendToJournalFile f $ showTransaction t appendToJournalFile f $ showTransaction t
when (Debug `elem` opts) $ do when (debug_ opts) $ do
putStrLn $ printf "\nAdded transaction to %s:" f putStrLn $ printf "\nAdded transaction to %s:" f
putStrLn =<< registerFromString (show t) putStrLn =<< registerFromString (show t)
return j{jtxns=ts++[t]} return j{jtxns=ts++[t]}
@ -219,8 +219,8 @@ registerFromString :: String -> IO String
registerFromString s = do registerFromString s = do
d <- getCurrentDay d <- getCurrentDay
j <- readJournal' s j <- readJournal' s
return $ postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts [] d) j return $ postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts d) j
where opts = [Empty] where opts = defreportopts{empty_=True}
-- | Return a similarity measure, from 0 to 1, for two strings. -- | Return a similarity measure, from 0 to 1, for two strings.
-- This is Simon White's letter pairs algorithm from -- This is Simon White's letter pairs algorithm from

35
hledger/Hledger/Cli/Balance.hs
View File

@ -115,26 +115,27 @@ import Hledger.Cli.Reports
-- | Print a balance report. -- | Print a balance report.
balance :: [Opt] -> [String] -> Journal -> IO () balance :: CliOpts -> Journal -> IO ()
balance opts args j = do balance CliOpts{reportopts_=ropts} j = do
d <- getCurrentDay d <- getCurrentDay
let lines = case parseFormatFromOpts opts of let lines = case formatFromOpts ropts of
Left err -> [err] Left err -> [err]
Right _ -> accountsReportAsText opts $ accountsReport opts (optsToFilterSpec opts args d) j Right _ -> accountsReportAsText ropts $ accountsReport ropts (optsToFilterSpec ropts d) j
putStr $ unlines lines putStr $ unlines lines
-- | Render a balance report as plain text suitable for console output. -- | Render a balance report as plain text suitable for console output.
accountsReportAsText :: [Opt] -> AccountsReport -> [String] accountsReportAsText :: ReportOpts -> AccountsReport -> [String]
accountsReportAsText opts (items, total) = concat lines ++ t accountsReportAsText opts (items, total) = concat lines ++ t
where where
lines = map (accountsReportItemAsText opts format) items lines = case formatFromOpts opts of
format = formatFromOpts opts Right f -> map (accountsReportItemAsText opts f) items
t = if NoTotal `elem` opts Left err -> [[err]]
then [] t = if no_total_ opts
else ["--------------------" then []
-- TODO: This must use the format somehow else ["--------------------"
, padleft 20 $ showMixedAmountWithoutPrice total -- TODO: This must use the format somehow
] ,padleft 20 $ showMixedAmountWithoutPrice total
]
{- {-
This implementation turned out to be a bit convoluted but implements the following algorithm for formatting: This implementation turned out to be a bit convoluted but implements the following algorithm for formatting:
@ -147,7 +148,7 @@ This implementation turned out to be a bit convoluted but implements the followi
b USD -1 ; Account 'b' has two amounts. The account name is printed on the last line. b USD -1 ; Account 'b' has two amounts. The account name is printed on the last line.
-} -}
-- | Render one balance report line item as plain text. -- | Render one balance report line item as plain text.
accountsReportItemAsText :: [Opt] -> [FormatString] -> AccountsReportItem -> [String] accountsReportItemAsText :: ReportOpts -> [FormatString] -> AccountsReportItem -> [String]
accountsReportItemAsText opts format (_, accountName, depth, Mixed amounts) = accountsReportItemAsText opts format (_, accountName, depth, Mixed amounts) =
case amounts of case amounts of
[] -> [] [] -> []
@ -159,7 +160,7 @@ accountsReportItemAsText opts format (_, accountName, depth, Mixed amounts) =
asText [a] = [formatAccountsReportItem opts (Just accountName) depth a format] asText [a] = [formatAccountsReportItem opts (Just accountName) depth a format]
asText (a:as) = (formatAccountsReportItem opts Nothing depth a format) : asText as asText (a:as) = (formatAccountsReportItem opts Nothing depth a format) : asText as
formatAccountsReportItem :: [Opt] -> Maybe AccountName -> Int -> Amount -> [FormatString] -> String formatAccountsReportItem :: ReportOpts -> Maybe AccountName -> Int -> Amount -> [FormatString] -> String
formatAccountsReportItem _ _ _ _ [] = "" formatAccountsReportItem _ _ _ _ [] = ""
formatAccountsReportItem opts accountName depth amount (f:fs) = s ++ (formatAccountsReportItem opts accountName depth amount fs) formatAccountsReportItem opts accountName depth amount (f:fs) = s ++ (formatAccountsReportItem opts accountName depth amount fs)
where where
@ -167,7 +168,7 @@ formatAccountsReportItem opts accountName depth amount (f:fs) = s ++ (formatAcco
FormatLiteral l -> l FormatLiteral l -> l
FormatField leftJustified min max field -> formatAccount opts accountName depth amount leftJustified min max field FormatField leftJustified min max field -> formatAccount opts accountName depth amount leftJustified min max field
formatAccount :: [Opt] -> Maybe AccountName -> Int -> Amount -> Bool -> Maybe Int -> Maybe Int -> Field -> String formatAccount :: ReportOpts -> Maybe AccountName -> Int -> Amount -> Bool -> Maybe Int -> Maybe Int -> Field -> String
formatAccount opts accountName depth balance leftJustified min max field = case field of formatAccount opts accountName depth balance leftJustified min max field = case field of
Format.Account -> formatValue leftJustified min max a Format.Account -> formatValue leftJustified min max a
DepthSpacer -> case min of DepthSpacer -> case min of
@ -176,7 +177,7 @@ formatAccount opts accountName depth balance leftJustified min max field = case
Total -> formatValue leftJustified min max $ showAmountWithoutPrice balance Total -> formatValue leftJustified min max $ showAmountWithoutPrice balance
_ -> "" _ -> ""
where where
a = maybe "" (accountNameDrop (dropFromOpts opts)) accountName a = maybe "" (accountNameDrop (drop_ opts)) accountName
tests_Hledger_Cli_Balance = TestList tests_Hledger_Cli_Balance = TestList
[ [

37
hledger/Hledger/Cli/Convert.hs
View File

@ -8,8 +8,7 @@ import Prelude hiding (getContents)
import Control.Monad (when, guard, liftM) import Control.Monad (when, guard, liftM)
import Data.Maybe import Data.Maybe
import Data.Time.Format (parseTime) import Data.Time.Format (parseTime)
import Safe (atDef, atMay, maximumDef) import Safe
import Safe (readDef, readMay)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.FilePath (takeBaseName, replaceExtension) import System.FilePath (takeBaseName, replaceExtension)
@ -23,13 +22,14 @@ import Text.Printf (hPrintf)
import Hledger.Cli.Format import Hledger.Cli.Format
import qualified Hledger.Cli.Format as Format import qualified Hledger.Cli.Format as Format
import Hledger.Cli.Version import Hledger.Cli.Version
import Hledger.Cli.Options (Opt(Debug), progname_cli, rulesFileFromOpts) import Hledger.Cli.Options
import Hledger.Cli.Reports
import Hledger.Data.Amount (nullmixedamt, costOfMixedAmount) import Hledger.Data.Amount (nullmixedamt, costOfMixedAmount)
import Hledger.Data.Dates (firstJust, showDate, parsedate) import Hledger.Data.Dates (firstJust, showDate, parsedate)
import Hledger.Data (Journal,AccountName,Transaction(..),Posting(..),PostingType(..)) import Hledger.Data (Journal,AccountName,Transaction(..),Posting(..),PostingType(..))
import Hledger.Data.Journal (nullctx) import Hledger.Data.Journal (nullctx)
import Hledger.Read.JournalReader (someamount,ledgeraccountname) import Hledger.Read.JournalReader (someamount,ledgeraccountname)
import Hledger.Utils (choice', strip, spacenonewline, restofline, parseWithCtx, assertParse, assertParseEqual, error', regexMatchesCI, regexReplaceCI) import Hledger.Utils
import Hledger.Utils.UTF8 (getContents) import Hledger.Utils.UTF8 (getContents)
{- | {- |
@ -84,20 +84,19 @@ type CsvRecord = [String]
-- | Read the CSV file named as an argument and print equivalent journal transactions, -- | Read the CSV file named as an argument and print equivalent journal transactions,
-- using/creating a .rules file. -- using/creating a .rules file.
convert :: [Opt] -> [String] -> Journal -> IO () convert :: CliOpts -> Journal -> IO ()
convert opts args _ = do convert opts _ = do
when (null args) $ error' "please specify a csv data file." let csvfile = headDef "" $ patterns_ $ reportopts_ opts
let csvfile = head args when (null csvfile) $ error' "please specify a csv data file."
let let
rulesFileSpecified = isJust $ rulesFileFromOpts opts rulesFileSpecified = isJust $ rules_file_ opts
rulesfile = rulesFileFor opts csvfile
usingStdin = csvfile == "-" usingStdin = csvfile == "-"
when (usingStdin && (not rulesFileSpecified)) $ error' "please specify a files file when converting stdin" when (usingStdin && (not rulesFileSpecified)) $ error' "please specify a files file when converting stdin"
csvparse <- parseCsv csvfile csvparse <- parseCsv csvfile
let records = case csvparse of let records = case csvparse of
Left e -> error' $ show e Left e -> error' $ show e
Right rs -> reverse $ filter (/= [""]) rs Right rs -> reverse $ filter (/= [""]) rs
let debug = Debug `elem` opts
rulesfile = rulesFileFor opts csvfile
exists <- doesFileExist rulesfile exists <- doesFileExist rulesfile
if (not exists) then do if (not exists) then do
hPrintf stderr "creating conversion rules file %s, edit this file for better results\n" rulesfile hPrintf stderr "creating conversion rules file %s, edit this file for better results\n" rulesfile
@ -106,12 +105,12 @@ convert opts args _ = do
hPrintf stderr "using conversion rules file %s\n" rulesfile hPrintf stderr "using conversion rules file %s\n" rulesfile
rules <- liftM (either (error'.show) id) $ parseCsvRulesFile rulesfile rules <- liftM (either (error'.show) id) $ parseCsvRulesFile rulesfile
let invalid = validateRules rules let invalid = validateRules rules
when debug $ hPrintf stderr "rules: %s\n" (show rules) when (debug_ opts) $ hPrintf stderr "rules: %s\n" (show rules)
when (isJust invalid) $ error (fromJust invalid) when (isJust invalid) $ error (fromJust invalid)
let requiredfields = max 2 (maxFieldIndex rules + 1) let requiredfields = max 2 (maxFieldIndex rules + 1)
badrecords = take 1 $ filter ((< requiredfields).length) records badrecords = take 1 $ filter ((< requiredfields).length) records
if null badrecords if null badrecords
then mapM_ (printTxn debug rules) records then mapM_ (printTxn (debug_ opts) rules) records
else do else do
hPrintf stderr (unlines [ hPrintf stderr (unlines [
"Warning, at least one CSV record does not contain a field referenced by the" "Warning, at least one CSV record does not contain a field referenced by the"
@ -142,17 +141,13 @@ maxFieldIndex r = maximumDef (-1) $ catMaybes [
,effectiveDateField r ,effectiveDateField r
] ]
rulesFileFor :: [Opt] -> FilePath -> FilePath rulesFileFor :: CliOpts -> FilePath -> FilePath
rulesFileFor opts csvfile = rulesFileFor CliOpts{rules_file_=Just f} _ = f
case opt of rulesFileFor CliOpts{rules_file_=Nothing} csvfile = replaceExtension csvfile ".rules"
Just path -> path
Nothing -> replaceExtension csvfile ".rules"
where
opt = rulesFileFromOpts opts
initialRulesFileContent :: String initialRulesFileContent :: String
initialRulesFileContent = initialRulesFileContent =
"# csv conversion rules file generated by "++(progversionstr progname_cli)++"\n" ++ "# csv conversion rules file generated by "++(progversionstr progname)++"\n" ++
"# Add rules to this file for more accurate conversion, see\n"++ "# Add rules to this file for more accurate conversion, see\n"++
"# http://hledger.org/MANUAL.html#convert\n" ++ "# http://hledger.org/MANUAL.html#convert\n" ++
"\n" ++ "\n" ++

13
hledger/Hledger/Cli/Histogram.hs
View File

@ -13,6 +13,7 @@ import Data.Ord
import Text.Printf import Text.Printf
import Hledger.Cli.Options import Hledger.Cli.Options
import Hledger.Cli.Reports
import Hledger.Data import Hledger.Data
import Prelude hiding (putStr) import Prelude hiding (putStr)
import Hledger.Utils.UTF8 (putStr) import Hledger.Utils.UTF8 (putStr)
@ -22,12 +23,12 @@ barchar = '*'
-- | Print a histogram of some statistic per reporting interval, such as -- | Print a histogram of some statistic per reporting interval, such as
-- number of postings per day. -- number of postings per day.
histogram :: [Opt] -> [String] -> Journal -> IO () histogram :: CliOpts -> Journal -> IO ()
histogram opts args j = do histogram CliOpts{reportopts_=reportopts_} j = do
d <- getCurrentDay d <- getCurrentDay
putStr $ showHistogram opts (optsToFilterSpec opts args d) j putStr $ showHistogram reportopts_ (optsToFilterSpec reportopts_ d) j
showHistogram :: [Opt] -> FilterSpec -> Journal -> String showHistogram :: ReportOpts -> FilterSpec -> Journal -> String
showHistogram opts filterspec j = concatMap (printDayWith countBar) spanps showHistogram opts filterspec j = concatMap (printDayWith countBar) spanps
where where
i = intervalFromOpts opts i = intervalFromOpts opts
@ -40,13 +41,13 @@ showHistogram opts filterspec j = concatMap (printDayWith countBar) spanps
-- should count transactions, not postings ? -- should count transactions, not postings ?
ps = sortBy (comparing postingDate) $ filterempties $ filter matchapats $ filterdepth $ journalPostings j ps = sortBy (comparing postingDate) $ filterempties $ filter matchapats $ filterdepth $ journalPostings j
filterempties filterempties
| Empty `elem` opts = id | empty_ opts = id
| otherwise = filter (not . isZeroMixedAmount . pamount) | otherwise = filter (not . isZeroMixedAmount . pamount)
matchapats = matchpats apats . paccount matchapats = matchpats apats . paccount
apats = acctpats filterspec apats = acctpats filterspec
filterdepth | interval == NoInterval = filter (\p -> accountNameLevel (paccount p) <= depth) filterdepth | interval == NoInterval = filter (\p -> accountNameLevel (paccount p) <= depth)
| otherwise = id | otherwise = id
depth = fromMaybe 99999 $ depthFromOpts opts depth = fromMaybe 99999 $ depth_ opts
printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts) printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts)

73
hledger/Hledger/Cli/Main.hs
View File

@ -39,7 +39,9 @@ See "Hledger.Data.Ledger" for more examples.
module Hledger.Cli.Main where module Hledger.Cli.Main where
import Control.Monad
import Data.List import Data.List
import Text.Printf
import Hledger.Cli.Add import Hledger.Cli.Add
import Hledger.Cli.Balance import Hledger.Cli.Balance
@ -52,38 +54,49 @@ import Hledger.Cli.Options
import Hledger.Cli.Tests import Hledger.Cli.Tests
import Hledger.Cli.Utils import Hledger.Cli.Utils
import Hledger.Cli.Version import Hledger.Cli.Version
import Hledger.Utils
import Prelude hiding (putStr, putStrLn)
import Hledger.Utils.UTF8 (putStr, putStrLn)
main :: IO () main :: IO ()
main = do main = do
(opts, args) <- parseArgumentsWith options_cli opts <- getHledgerOpts
case validateOpts opts of when (debug_ opts) $ printf "%s\n" progversion >> printf "opts: %s\n" (show opts)
Just err -> error' err runWith opts
Nothing -> run opts args
run opts args = runWith :: CliOpts -> IO ()
run opts args runWith opts = run' opts
where where
run opts _ cmd = command_ opts
| Help `elem` opts = putStr usage_cli run' opts
| Version `elem` opts = putStrLn $ progversionstr progname_cli | null cmd = printModeHelpAndExit mainmode
| BinaryFilename `elem` opts = putStrLn $ binaryfilename progname_cli | any (cmd `isPrefixOf`) ["accounts","balance"] = showModeHelpOr accountsmode $ withJournalDo opts balance
run _ [] = argsError "a command is required." | any (cmd `isPrefixOf`) ["activity","histogram"] = showModeHelpOr activitymode $ withJournalDo opts histogram
run opts (cmd:args) | cmd `isPrefixOf` "add" = showModeHelpOr addmode $ withJournalDo opts add
| cmd `isPrefixOf` "balance" = withJournalDo opts args cmd balance | cmd `isPrefixOf` "convert" = showModeHelpOr convertmode $ withJournalDo opts convert
| cmd `isPrefixOf` "convert" = withJournalDo opts args cmd convert | any (cmd `isPrefixOf`) ["entries","print"] = showModeHelpOr entriesmode $ withJournalDo opts print'
| cmd `isPrefixOf` "print" = withJournalDo opts args cmd print' | any (cmd `isPrefixOf`) ["postings","register"] = showModeHelpOr postingsmode $ withJournalDo opts register
| cmd `isPrefixOf` "register" = withJournalDo opts args cmd register | cmd `isPrefixOf` "stats" = showModeHelpOr statsmode $ withJournalDo opts stats
| cmd `isPrefixOf` "histogram" = withJournalDo opts args cmd histogram | cmd `isPrefixOf` "test" = showModeHelpOr testmode $ runtests opts >> return ()
| cmd `isPrefixOf` "add" = withJournalDo opts args cmd add | cmd `isPrefixOf` "binaryfilename" = showModeHelpOr binaryfilenamemode $ putStrLn $ binaryfilename progname
| cmd `isPrefixOf` "stats" = withJournalDo opts args cmd stats | otherwise = showModeHelpOr mainmode $ optserror $ "command "++cmd++" is not recognized"
| cmd `isPrefixOf` "test" = runtests opts args >> return () showModeHelpOr mode f = do
| otherwise = argsError $ "command "++cmd++" is unrecognized." when ("help" `in_` (rawopts_ opts)) $ printModeHelpAndExit mode
when ("version" `in_` (rawopts_ opts)) $ printVersionAndExit
f
validateOpts :: [Opt] -> Maybe String {- tests:
validateOpts opts =
case parseFormatFromOpts opts of hledger -> main help
Left err -> Just $ unlines ["Invalid format", err] hledger --help -> main help
Right _ -> Nothing hledger --help command -> command help
hledger command --help -> command help
hledger badcommand -> unrecognized command, try --help (non-zero exit)
hledger badcommand --help -> main help
hledger --help badcommand -> main help
hledger --mainflag command -> works
hledger command --mainflag -> works
hledger command --commandflag -> works
hledger command --mainflag --commandflag -> works
XX hledger --mainflag command --commandflag -> works
XX hledger --commandflag command -> works
XX hledger --commandflag command --mainflag -> works
-}

686
hledger/Hledger/Cli/Options.hs
View File

@ -1,234 +1,401 @@
{-| {-|
Command-line options for the application.
Command-line options for the hledger program, and option-parsing utilities.
-} -}
module Hledger.Cli.Options module Hledger.Cli.Options
where where
import Data.Char (toLower)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Time.Calendar import Data.Time.Calendar
import System.Console.GetOpt import Safe
import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import System.Environment import System.Environment
import System.Exit
import Test.HUnit import Test.HUnit
import Hledger.Data
import Hledger.Cli.Format as Format import Hledger.Cli.Format as Format
import Hledger.Read (myJournalPath, myTimelogPath) import Hledger.Cli.Reports
import Hledger.Cli.Version
import Hledger.Data
import Hledger.Read
import Hledger.Utils import Hledger.Utils
progname_cli = "hledger" progname = "hledger"
progversion = progversionstr progname
-- | The program name which, if we are invoked as (via symlink or -- 1. cmdargs mode and flag definitions, for the main and subcommand modes.
-- renaming), causes us to default to reading the user's time log instead -- Flag values are parsed initially to simple RawOpts to permit reuse.
-- of their journal.
progname_cli_time = "hours"
usage_preamble_cli = type RawOpts = [(String,String)]
"Usage: hledger [OPTIONS] COMMAND [PATTERNS]\n" ++
" hledger [OPTIONS] convert CSVFILE\n" ++
"\n" ++
"Reads your ~/.journal file, or another specified by $LEDGER or -f, and\n" ++
"runs the specified command (may be abbreviated):\n" ++
"\n" ++
" add - prompt for new transactions and add them to the journal\n" ++
" balance - show accounts, with balances\n" ++
" convert - show the specified CSV file as a hledger journal\n" ++
" histogram - show a barchart of transactions per day or other interval\n" ++
" print - show transactions in journal format\n" ++
" register - show transactions as a register with running balance\n" ++
" stats - show various statistics for a journal\n" ++
" test - run self-tests\n" ++
"\n"
usage_options_cli = usageInfo "hledger options:" options_cli defmode :: Mode RawOpts
defmode = Mode {
modeNames = []
,modeHelp = ""
,modeHelpSuffix = []
,modeValue = []
,modeCheck = Right
,modeReform = const Nothing
,modeGroupFlags = toGroup []
,modeArgs = Nothing
,modeGroupModes = toGroup []
}
usage_postscript_cli = mainmode = defmode {
"\n" ++ modeNames = [progname]
"DATES can be y/m/d or smart dates like \"last month\". PATTERNS are regular\n" ++ ,modeHelp = "run the specified hledger command. hledger COMMAND --help for more detail. When mixing general and command-specific flags, put them all after COMMAND."
"expressions which filter by account name. Prefix a pattern with desc: to\n" ++ ,modeHelpSuffix = help_postscript
"filter by transaction description instead, prefix with not: to negate it.\n" ++ ,modeGroupFlags = Group {
"When using both, not: comes last.\n" groupUnnamed = []
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags1)]
}
,modeArgs = Just mainargsflag
,modeGroupModes = Group {
groupUnnamed = [
]
,groupHidden = [
binaryfilenamemode
]
,groupNamed = [
("Misc commands", [
addmode
,convertmode
,testmode
])
,("\nReport commands", [
accountsmode
,entriesmode
,postingsmode
-- ,transactionsmode
,activitymode
,statsmode
])
]
}
}
usage_cli = concat [ help_postscript = [
usage_preamble_cli -- "DATES can be Y/M/D or smart dates like \"last month\"."
,usage_options_cli -- ,"PATTERNS are regular"
,usage_postscript_cli -- ,"expressions which filter by account name. Prefix a pattern with desc: to"
] -- ,"filter by transaction description instead, prefix with not: to negate it."
-- ,"When using both, not: comes last."
-- | Command-line options we accept.
options_cli :: [OptDescr Opt]
options_cli = [
Option "f" ["file"] (ReqArg File "FILE") "use a different journal/timelog file; - means stdin"
,Option "b" ["begin"] (ReqArg Begin "DATE") "report on transactions on or after this date"
,Option "e" ["end"] (ReqArg End "DATE") "report on transactions before this date"
,Option "p" ["period"] (ReqArg Period "EXPR") ("report on transactions during the specified period\n" ++
"and/or with the specified reporting interval\n")
,Option "C" ["cleared"] (NoArg Cleared) "report only on cleared transactions"
,Option "U" ["uncleared"] (NoArg UnCleared) "report only on uncleared transactions"
,Option "B" ["cost","basis"] (NoArg CostBasis) "report cost of commodities"
,Option "" ["alias"] (ReqArg Alias "ACCT=ALIAS") "display ACCT's name as ALIAS in reports"
,Option "" ["depth"] (ReqArg Depth "N") "hide accounts/transactions deeper than this"
,Option "d" ["display"] (ReqArg Display "EXPR") ("show only transactions matching EXPR (where\n" ++
"EXPR is 'dOP[DATE]' and OP is <, <=, =, >=, >)")
,Option "" ["effective"] (NoArg Effective) "use transactions' effective dates, if any"
,Option "E" ["empty"] (NoArg Empty) "show empty/zero things which are normally elided"
,Option "" ["no-elide"] (NoArg NoElide) "no eliding at all, stronger than -E (eg for balance report)"
,Option "R" ["real"] (NoArg Real) "report only on real (non-virtual) transactions"
,Option "" ["flat"] (NoArg Flat) "balance: show full account names, unindented"
,Option "" ["drop"] (ReqArg Drop "N") "balance: with --flat, elide first N account name components"
,Option "" ["no-total"] (NoArg NoTotal) "balance: hide the final total"
,Option "D" ["daily"] (NoArg DailyOpt) "register, stats: report by day"
,Option "W" ["weekly"] (NoArg WeeklyOpt) "register, stats: report by week"
,Option "M" ["monthly"] (NoArg MonthlyOpt) "register, stats: report by month"
,Option "Q" ["quarterly"] (NoArg QuarterlyOpt) "register, stats: report by quarter"
,Option "Y" ["yearly"] (NoArg YearlyOpt) "register, stats: report by year"
,Option "" ["no-new-accounts"] (NoArg NoNewAccts) "add: don't allow creating new accounts"
,Option "r" ["rules"] (ReqArg RulesFile "FILE") "convert: rules file to use (default:JOURNAL.rules)"
,Option "F" ["format"] (ReqArg ReportFormat "STR") "use STR as the format"
,Option "v" ["verbose"] (NoArg Verbose) "show more verbose output"
,Option "" ["debug"] (NoArg Debug) "show extra debug output; implies verbose"
,Option "" ["binary-filename"] (NoArg BinaryFilename) "show the download filename for this hledger build"
,Option "V" ["version"] (NoArg Version) "show version information"
,Option "h" ["help"] (NoArg Help) "show command-line usage"
] ]
-- | An option value from a command-line flag. generalflagstitle = "\nGeneral flags"
data Opt = generalflags1 = fileflags ++ reportflags ++ helpflags
File {value::String} generalflags2 = fileflags ++ helpflags
| NoNewAccts generalflags3 = helpflags
| Begin {value::String}
| End {value::String}
| Period {value::String}
| Cleared
| UnCleared
| CostBasis
| Alias {value::String}
| Depth {value::String}
| Display {value::String}
| Effective
| Empty
| NoElide
| Real
| Flat
| Drop {value::String}
| NoTotal
| DailyOpt
| WeeklyOpt
| MonthlyOpt
| QuarterlyOpt
| YearlyOpt
| RulesFile {value::String}
| ReportFormat {value::String}
| Help
| Verbose
| Version
| BinaryFilename
| Debug
-- XXX add-on options, must be defined here for now
-- vty
| DebugVty
-- web
| BaseUrl {value::String}
| Port {value::String}
-- chart
| ChartOutput {value::String}
| ChartItems {value::String}
| ChartSize {value::String}
deriving (Show,Eq)
-- these make me nervous fileflags = [
optsWithConstructor f opts = concatMap get opts flagReq ["file","f"] (\s opts -> Right $ setopt "file" s opts) "FILE" "use a different journal file; - means stdin"
where get o = [o | f v == o] where v = value o ,flagReq ["alias"] (\s opts -> Right $ setopt "alias" s opts) "ACCT=ALIAS" "display ACCT's name as ALIAS in reports"
]
optsWithConstructors fs opts = concatMap get opts reportflags = [
where get o = [o | any (== o) fs] flagReq ["begin","b"] (\s opts -> Right $ setopt "begin" s opts) "DATE" "report on transactions on or after this date"
,flagReq ["end","e"] (\s opts -> Right $ setopt "end" s opts) "DATE" "report on transactions before this date"
,flagReq ["period","p"] (\s opts -> Right $ setopt "period" s opts) "PERIODEXPR" "report on transactions during the specified period and/or with the specified reporting interval"
,flagNone ["daily","D"] (\opts -> setboolopt "daily" opts) "report by day"
,flagNone ["weekly","W"] (\opts -> setboolopt "weekly" opts) "report by week"
,flagNone ["monthly","M"] (\opts -> setboolopt "monthly" opts) "report by month"
,flagNone ["quarterly","Q"] (\opts -> setboolopt "quarterly" opts) "report by quarter"
,flagNone ["yearly","Y"] (\opts -> setboolopt "yearly" opts) "report by year"
,flagNone ["cleared","C"] (\opts -> setboolopt "cleared" opts) "report only on cleared transactions"
,flagNone ["uncleared","U"] (\opts -> setboolopt "uncleared" opts) "report only on uncleared transactions"
,flagNone ["cost","B"] (\opts -> setboolopt "cost" opts) "report cost of commodities"
,flagReq ["depth"] (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/transactions deeper than this"
,flagReq ["display","d"] (\s opts -> Right $ setopt "display" s opts) "DISPLAYEXPR" "show only transactions matching the expr, which is 'dOP[DATE]' where OP is <, <=, =, >=, >"
,flagNone ["effective"] (\opts -> setboolopt "effective" opts) "use transactions' effective dates, if any"
,flagNone ["empty","E"] (\opts -> setboolopt "empty" opts) "show empty/zero things which are normally elided"
,flagNone ["real","R"] (\opts -> setboolopt "real" opts) "report only on real (non-virtual) transactions"
]
optValuesForConstructor f opts = concatMap get opts helpflags = [
where get o = [v | f v == o] where v = value o flagHelpSimple (setboolopt "help")
,flagNone ["debug"] (setboolopt "debug") "Show extra debug output"
,flagVersion (setboolopt "version")
]
optValuesForConstructors fs opts = concatMap get opts mainargsflag = flagArg f ""
where get o = [v | any (\f -> f v == o) fs] where v = value o where f s opts = let as = words' s
cmd = headDef "" as
args = drop (length cmd + 1) s
in Right $ setopt "command" cmd $ setopt "args" args opts
-- | Parse the command-line arguments into options and arguments using the commandargsflag = flagArg (\s opts -> Right $ setopt "args" s opts) "[PATTERNS]"
-- specified option descriptors. Any smart dates in the options are
-- converted to explicit YYYY/MM/DD format based on the current time. If
-- parsing fails, raise an error, displaying the problem along with the
-- provided usage string.
parseArgumentsWith :: [OptDescr Opt] -> IO ([Opt], [String])
parseArgumentsWith options = do
rawargs <- map fromPlatformString `fmap` getArgs
parseArgumentsWith' options rawargs
parseArgumentsWith' options rawargs = do commandmode names = defmode {modeNames=names, modeValue=[("command",headDef "" names)]}
let (opts,args,errs) = getOpt Permute options rawargs
opts' <- fixOptDates opts
let opts'' = if Debug `elem` opts' then Verbose:opts' else opts'
if null errs
then return (opts'',args)
else argsError (concat errs) >> return ([],[])
argsError :: String -> IO () addmode = (commandmode ["add"]) {
argsError = ioError . userError' . (++ " Run with --help to see usage.") modeHelp = "prompt for new transactions and append them to the journal"
,modeHelpSuffix = ["Defaults come from previous similar transactions; use query patterns to restrict these."]
,modeArgs = Just commandargsflag
,modeGroupFlags = Group {
groupUnnamed = [
flagNone ["no-new-accounts"] (\opts -> setboolopt "no-new-accounts" opts) "don't allow creating new accounts"
]
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags2)]
}
}
-- | Convert any fuzzy dates within these option values to explicit ones, convertmode = (commandmode ["convert"]) {
-- based on today's date. modeValue = [("command","convert")]
fixOptDates :: [Opt] -> IO [Opt] ,modeHelp = "show the specified CSV file as hledger journal entries"
fixOptDates opts = do ,modeArgs = Just $ flagArg (\s opts -> Right $ setopt "args" s opts) "CSVFILE"
,modeGroupFlags = Group {
groupUnnamed = [
flagReq ["rules-file"] (\s opts -> Right $ setopt "rules-file" s opts) "FILE" "rules file to use (default: CSVFILE.rules)"
]
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags3)]
}
}
testmode = (commandmode ["test"]) {
modeHelp = "run self-tests, or just the ones matching REGEXPS"
,modeArgs = Just $ flagArg (\s opts -> Right $ setopt "args" s opts) "[REGEXPS]"
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags3)]
}
}
accountsmode = (commandmode ["accounts","balance"]) {
modeHelp = "(or balance) show matched accounts and their balances"
,modeArgs = Just commandargsflag
,modeGroupFlags = Group {
groupUnnamed = [
flagNone ["flat"] (\opts -> setboolopt "flat" opts) "show full account names, unindented"
,flagReq ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "with --flat, omit this many leading account name components"
,flagReq ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "use this custom line format"
,flagNone ["no-elide"] (\opts -> setboolopt "no-elide" opts) "no eliding at all, stronger than --empty"
,flagNone ["no-total"] (\opts -> setboolopt "no-total" opts) "don't show the final total"
]
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags1)]
}
}
entriesmode = (commandmode ["entries","print"]) {
modeHelp = "(or print) show matched journal entries"
,modeArgs = Just commandargsflag
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags1)]
}
}
postingsmode = (commandmode ["postings","register"]) {
modeHelp = "(or register) show matched postings and running total"
,modeArgs = Just commandargsflag
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags1)]
}
}
transactionsmode = (commandmode ["transactions"]) {
modeHelp = "show matched transactions and balance in some account(s)"
,modeArgs = Just commandargsflag
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags1)]
}
}
activitymode = (commandmode ["activity","histogram"]) {
modeHelp = "show a barchart of transactions per interval"
,modeHelpSuffix = ["The default interval is daily."]
,modeArgs = Just commandargsflag
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags1)]
}
}
statsmode = (commandmode ["stats"]) {
modeHelp = "show quick statistics for a journal (or part of it)"
,modeArgs = Just commandargsflag
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags1)]
}
}
binaryfilenamemode = (commandmode ["binaryfilename"]) {
modeHelp = "show the download filename for this hledger build, and exit"
,modeArgs = Nothing
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags3)]
}
}
-- 2. ADT holding options used in this package and above, parsed from RawOpts.
-- This represents the command-line options that were provided, with all
-- parsing completed, but before adding defaults or derived values (XXX add)
-- cli options, used in hledger and above
data CliOpts = CliOpts {
rawopts_ :: RawOpts
,command_ :: String
,file_ :: Maybe FilePath
,alias_ :: [String]
,debug_ :: Bool
,no_new_accounts_ :: Bool -- add
,rules_file_ :: Maybe FilePath -- convert
,reportopts_ :: ReportOpts
} deriving (Show)
defcliopts = CliOpts
def
def
def
def
def
def
def
def
instance Default CliOpts where def = defcliopts
-- | Parse raw option string values to the desired final data types.
-- Any relative smart dates will be converted to fixed dates based on
-- today's date. Parsing failures will raise an error.
toCliOpts :: RawOpts -> IO CliOpts
toCliOpts rawopts = do
d <- getCurrentDay d <- getCurrentDay
return $ map (fixopt d) opts return defcliopts {
where rawopts_ = rawopts
fixopt d (Begin s) = Begin $ fixSmartDateStr d s ,command_ = stringopt "command" rawopts
fixopt d (End s) = End $ fixSmartDateStr d s ,file_ = maybestringopt "file" rawopts
fixopt d (Display s) = -- hacky ,alias_ = listofstringopt "alias" rawopts
Display $ regexReplaceBy "\\[.+?\\]" fixbracketeddatestr s ,debug_ = boolopt "debug" rawopts
where fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]" ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
fixopt _ o = o ,rules_file_ = maybestringopt "rules-file" rawopts -- convert
,reportopts_ = defreportopts {
begin_ = maybesmartdateopt d "begin" rawopts
,end_ = maybesmartdateopt d "end" rawopts
,period_ = maybeperiodopt d rawopts
,cleared_ = boolopt "cleared" rawopts
,uncleared_ = boolopt "uncleared" rawopts
,cost_ = boolopt "cost" rawopts
,depth_ = maybeintopt "depth" rawopts
,display_ = maybedisplayopt d rawopts
,effective_ = boolopt "effective" rawopts
,empty_ = boolopt "empty" rawopts
,no_elide_ = boolopt "no-elide" rawopts
,real_ = boolopt "real" rawopts
,flat_ = boolopt "flat" rawopts -- balance
,drop_ = intopt "drop" rawopts -- balance
,no_total_ = boolopt "no-total" rawopts -- balance
,daily_ = boolopt "daily" rawopts
,weekly_ = boolopt "weekly" rawopts
,monthly_ = boolopt "monthly" rawopts
,quarterly_ = boolopt "quarterly" rawopts
,yearly_ = boolopt "yearly" rawopts
,format_ = maybestringopt "format" rawopts
,patterns_ = words'' prefixes $ singleQuoteIfNeeded $ stringopt "args" rawopts
}
}
-- | Figure out the overall date span we should report on, based on any -- workaround for http://code.google.com/p/ndmitchell/issues/detail?id=457
-- begin/end/period options provided. If there is a period option, the -- just handles commonest cases
-- others are ignored. moveFlagsAfterCommand ("-f":f:cmd:rest) = cmd:"-f":f:rest
dateSpanFromOpts :: Day -> [Opt] -> DateSpan moveFlagsAfterCommand (first:cmd:rest) | "-f" `isPrefixOf` first = cmd:first:rest
dateSpanFromOpts refdate opts moveFlagsAfterCommand as = as
| not (null popts) = case parsePeriodExpr refdate $ last popts of
Right (_, s) -> s -- | Convert possibly encoded option values to regular unicode strings.
Left e -> parseerror e decodeRawOpts = map (\(name,val) -> (name, fromPlatformString val))
| otherwise = DateSpan lastb laste
-- | Get all command-line options, failing on any parse errors.
getHledgerOpts :: IO CliOpts
-- getHledgerOpts = processArgs mainmode >>= return . decodeRawOpts >>= toOpts >>= checkOpts
getHledgerOpts = do
args <- getArgs
toCliOpts (decodeRawOpts $ processValue mainmode $ moveFlagsAfterCommand args) >>= checkCliOpts
-- utils
optserror = error' . (++ " (run with --help for usage)")
setopt name val = (++ [(name,singleQuoteIfNeeded val)])
setboolopt name = (++ [(name,"")])
in_ :: String -> RawOpts -> Bool
in_ name = isJust . lookup name
boolopt = in_
maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name
stringopt name = fromMaybe "" . maybestringopt name
listofstringopt name rawopts = [stripquotes v | (n,v) <- rawopts, n==name]
maybeintopt :: String -> RawOpts -> Maybe Int
maybeintopt name rawopts =
let ms = maybestringopt name rawopts in
case ms of Nothing -> Nothing
Just s -> Just $ readDef (optserror $ "could not parse "++name++" number: "++s) s
intopt name = fromMaybe 0 . maybeintopt name
maybesmartdateopt :: Day -> String -> RawOpts -> Maybe Day
maybesmartdateopt d name rawopts =
case maybestringopt name rawopts of
Nothing -> Nothing
Just s -> either
(\e -> optserror $ "could not parse "++name++" date: "++show e)
Just
$ fixSmartDateStrEither' d s
maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExpr
maybedisplayopt d rawopts =
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
where where
popts = optValuesForConstructor Period opts fixbracketeddatestr "" = ""
bopts = optValuesForConstructor Begin opts fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]"
eopts = optValuesForConstructor End opts
lastb = listtomaybeday bopts
laste = listtomaybeday eopts
listtomaybeday vs = if null vs then Nothing else Just $ parse $ last vs
where parse = parsedate . fixSmartDateStr refdate
-- | Figure out the reporting interval, if any, specified by the options. maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
-- If there is a period option, the others are ignored. maybeperiodopt d rawopts =
intervalFromOpts :: [Opt] -> Interval case maybestringopt "period" rawopts of
intervalFromOpts opts = Nothing -> Nothing
case (periodopts, intervalopts) of Just s -> either
((p:_), _) -> case parsePeriodExpr (parsedate "0001/01/01") p of (\e -> optserror $ "could not parse period option: "++show e)
Right (i, _) -> i Just
Left e -> parseerror e $ parsePeriodExpr d s
(_, (DailyOpt:_)) -> Days 1
(_, (WeeklyOpt:_)) -> Weeks 1
(_, (MonthlyOpt:_)) -> Months 1
(_, (QuarterlyOpt:_)) -> Quarters 1
(_, (YearlyOpt:_)) -> Years 1
(_, _) -> NoInterval
where
periodopts = reverse $ optValuesForConstructor Period opts
intervalopts = reverse $ filter (`elem` [DailyOpt,WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts
rulesFileFromOpts :: [Opt] -> Maybe FilePath -- | Do final validation of processed opts, raising an error if there is trouble.
rulesFileFromOpts opts = listtomaybe $ optValuesForConstructor RulesFile opts checkCliOpts :: CliOpts -> IO CliOpts -- or pure..
where checkCliOpts opts@CliOpts{reportopts_=ropts} = do
listtomaybe [] = Nothing case formatFromOpts ropts of
listtomaybe vs = Just $ head vs Left err -> optserror $ "could not parse format option: "++err
Right _ -> return ()
return opts
-- | Default balance format string: "%20(total) %2(depth_spacer)%-(account)" -- | Parse any format option provided, possibly raising an error, or get
-- the default value.
formatFromOpts :: ReportOpts -> Either String [FormatString]
formatFromOpts = maybe (Right defaultBalanceFormatString) parseFormatString . format_
-- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)"
defaultBalanceFormatString :: [FormatString] defaultBalanceFormatString :: [FormatString]
defaultBalanceFormatString = [ defaultBalanceFormatString = [
FormatField False (Just 20) Nothing Total FormatField False (Just 20) Nothing Total
@ -237,81 +404,14 @@ defaultBalanceFormatString = [
, FormatField True Nothing Nothing Format.Account , FormatField True Nothing Nothing Format.Account
] ]
-- | Parses the --format string to either an error message or a format string.
parseFormatFromOpts :: [Opt] -> Either String [FormatString]
parseFormatFromOpts opts = listtomaybe $ optValuesForConstructor ReportFormat opts
where
listtomaybe :: [String] -> Either String [FormatString]
listtomaybe [] = Right defaultBalanceFormatString
listtomaybe vs = parseFormatString $ head vs
-- | Returns the format string. If the string can't be parsed it fails with error'.
formatFromOpts :: [Opt] -> [FormatString]
formatFromOpts opts = case parseFormatFromOpts opts of
Left err -> error' err
Right format -> format
-- | Get the value of the (last) depth option, if any.
depthFromOpts :: [Opt] -> Maybe Int
depthFromOpts opts = listtomaybeint $ optValuesForConstructor Depth opts
where
listtomaybeint [] = Nothing
listtomaybeint vs = Just $ read $ last vs
-- | Get the value of the (last) drop option, if any, otherwise 0.
dropFromOpts :: [Opt] -> Int
dropFromOpts opts = fromMaybe 0 $ listtomaybeint $ optValuesForConstructor Drop opts
where
listtomaybeint [] = Nothing
listtomaybeint vs = Just $ read $ last vs
-- | Get the value of the (last) display option, if any.
displayExprFromOpts :: [Opt] -> Maybe String
displayExprFromOpts opts = listtomaybe $ optValuesForConstructor Display opts
where
listtomaybe [] = Nothing
listtomaybe vs = Just $ last vs
-- | Get the value of the (last) baseurl option, if any.
baseUrlFromOpts :: [Opt] -> Maybe String
baseUrlFromOpts opts = listtomaybe $ optValuesForConstructor BaseUrl opts
where
listtomaybe [] = Nothing
listtomaybe vs = Just $ last vs
-- | Get the value of the (last) port option, if any.
portFromOpts :: [Opt] -> Maybe Int
portFromOpts opts = listtomaybeint $ optValuesForConstructor Port opts
where
listtomaybeint [] = Nothing
listtomaybeint vs = Just $ read $ 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
-- | Detect which date we will report on, based on --effective.
whichDateFromOpts :: [Opt] -> WhichDate
whichDateFromOpts opts = if Effective `elem` opts then EffectiveDate else ActualDate
-- | Were we invoked as \"hours\" ?
usingTimeProgramName :: IO Bool
usingTimeProgramName = do
progname <- getProgName
return $ map toLower progname == progname_cli_time
-- | Get the journal file path from options, an environment variable, or a default -- | Get the journal file path from options, an environment variable, or a default
journalFilePathFromOpts :: [Opt] -> IO String journalFilePathFromOpts :: CliOpts -> IO String
journalFilePathFromOpts opts = do journalFilePathFromOpts opts = do
istimequery <- usingTimeProgramName f <- myJournalPath
f <- if istimequery then myTimelogPath else myJournalPath return $ fromMaybe f $ file_ opts
return $ last $ f : optValuesForConstructor File opts
aliasesFromOpts :: [Opt] -> [(AccountName,AccountName)] aliasesFromOpts :: CliOpts -> [(AccountName,AccountName)]
aliasesFromOpts opts = map parseAlias $ optValuesForConstructor Alias opts aliasesFromOpts = map parseAlias . alias_
where where
-- similar to ledgerAlias -- similar to ledgerAlias
parseAlias :: String -> (AccountName,AccountName) parseAlias :: String -> (AccountName,AccountName)
@ -322,57 +422,11 @@ aliasesFromOpts opts = map parseAlias $ optValuesForConstructor Alias opts
alias' = case alias of ('=':rest) -> rest alias' = case alias of ('=':rest) -> rest
_ -> orig _ -> orig
-- | Gather filter pattern arguments into a list of account patterns and a printModeHelpAndExit mode = putStrLn progversion >> putStr help >> exitSuccess
-- list of description patterns. We interpret pattern arguments as where help = showText defaultWrap $ helpText HelpFormatDefault mode
-- follows: those prefixed with "desc:" are description patterns, all
-- others are account patterns; also patterns prefixed with "not:" are
-- negated. not: should come after desc: if both are used.
parsePatternArgs :: [String] -> ([String],[String])
parsePatternArgs args = (as, ds')
where
descprefix = "desc:"
(ds, as) = partition (descprefix `isPrefixOf`) args
ds' = map (drop (length descprefix)) ds
-- | Convert application options to the library's generic filter specification. printVersionAndExit = putStrLn progversion >> exitSuccess
optsToFilterSpec :: [Opt] -> [String] -> Day -> FilterSpec
optsToFilterSpec opts args d = FilterSpec {
datespan=dateSpanFromOpts d opts
,cleared=clearedValueFromOpts opts
,real=Real `elem` opts
,empty=Empty `elem` opts
,acctpats=apats
,descpats=dpats
,depth = depthFromOpts opts
}
where (apats,dpats) = parsePatternArgs args
-- currentLocalTimeFromOpts opts = listtomaybe $ optValuesForConstructor CurrentLocalTime opts
-- where
-- listtomaybe [] = Nothing
-- listtomaybe vs = Just $ last vs
tests_Hledger_Cli_Options = TestList tests_Hledger_Cli_Options = TestList
[ [
"dateSpanFromOpts" ~: do
let todaysdate = parsedate "2008/11/26"
let gives = is . show . dateSpanFromOpts todaysdate
[] `gives` "DateSpan Nothing Nothing"
[Begin "2008", End "2009"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"
[Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"
[Begin "2005", End "2007",Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"
,"intervalFromOpts" ~: do
let gives = is . intervalFromOpts
[] `gives` NoInterval
[DailyOpt] `gives` Days 1
[WeeklyOpt] `gives` Weeks 1
[MonthlyOpt] `gives` Months 1
[QuarterlyOpt] `gives` Quarters 1
[YearlyOpt] `gives` Years 1
[Period "weekly"] `gives` Weeks 1
[Period "monthly"] `gives` Months 1
[Period "quarterly"] `gives` Quarters 1
[WeeklyOpt, Period "yearly"] `gives` Years 1
] ]

13
hledger/Hledger/Cli/Print.hs
View File

@ -18,15 +18,14 @@ import Hledger.Cli.Options
import Hledger.Cli.Reports import Hledger.Cli.Reports
-- | Print journal transactions in standard format. -- | Print journal transactions in standard format.
print' :: [Opt] -> [String] -> Journal -> IO () print' :: CliOpts -> Journal -> IO ()
print' opts args j = do print' CliOpts{reportopts_=ropts} j = do
d <- getCurrentDay d <- getCurrentDay
putStr $ showTransactions opts (optsToFilterSpec opts args d) j putStr $ showTransactions ropts (optsToFilterSpec ropts d) j
showTransactions :: [Opt] -> FilterSpec -> Journal -> String showTransactions :: ReportOpts -> FilterSpec -> Journal -> String
showTransactions opts fspec j = entriesReportAsText opts fspec $ entriesReport opts fspec j showTransactions opts fspec j = entriesReportAsText opts fspec $ entriesReport opts fspec j
entriesReportAsText :: [Opt] -> FilterSpec -> EntriesReport -> String entriesReportAsText :: ReportOpts -> FilterSpec -> EntriesReport -> String
entriesReportAsText opts _ items = concatMap (showTransactionForPrint effective) items entriesReportAsText opts _ items = concatMap (showTransactionForPrint (effective_ opts)) items
where effective = Effective `elem` opts

12
hledger/Hledger/Cli/Register.hs
View File

@ -25,13 +25,13 @@ import Hledger.Cli.Reports
-- | Print a (posting) register report. -- | Print a (posting) register report.
register :: [Opt] -> [String] -> Journal -> IO () register :: CliOpts -> Journal -> IO ()
register opts args j = do register CliOpts{reportopts_=ropts} j = do
d <- getCurrentDay d <- getCurrentDay
putStr $ postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts args d) j putStr $ postingsReportAsText ropts $ postingsReport ropts (optsToFilterSpec ropts d) j
-- | Render a register report as plain text suitable for console output. -- | Render a register report as plain text suitable for console output.
postingsReportAsText :: [Opt] -> PostingsReport -> String postingsReportAsText :: ReportOpts -> PostingsReport -> String
postingsReportAsText opts = unlines . map (postingsReportItemAsText opts) . snd postingsReportAsText opts = unlines . map (postingsReportItemAsText opts) . snd
-- | Render one register report line item as plain text. Eg: -- | Render one register report line item as plain text. Eg:
@ -41,7 +41,7 @@ postingsReportAsText opts = unlines . map (postingsReportItemAsText opts) . snd
-- ^ displayed for first postings^ -- ^ displayed for first postings^
-- only, otherwise blank -- only, otherwise blank
-- @ -- @
postingsReportItemAsText :: [Opt] -> PostingsReportItem -> String postingsReportItemAsText :: ReportOpts -> PostingsReportItem -> String
postingsReportItemAsText _ (dd, p, b) = concatTopPadded [datedesc, pstr, " ", bal] postingsReportItemAsText _ (dd, p, b) = concatTopPadded [datedesc, pstr, " ", bal]
where where
datedesc = case dd of Nothing -> replicate datedescwidth ' ' datedesc = case dd of Nothing -> replicate datedescwidth ' '
@ -57,7 +57,7 @@ postingsReportItemAsText _ (dd, p, b) = concatTopPadded [datedesc, pstr, " ", ba
bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b) bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)
-- XXX -- XXX
showPostingWithBalanceForVty showtxninfo p b = postingsReportItemAsText [] $ mkpostingsReportItem showtxninfo p b showPostingWithBalanceForVty showtxninfo p b = postingsReportItemAsText defreportopts $ mkpostingsReportItem showtxninfo p b
tests_Hledger_Cli_Register :: Test tests_Hledger_Cli_Register :: Test
tests_Hledger_Cli_Register = TestList tests_Hledger_Cli_Register = TestList

191
hledger/Hledger/Cli/Reports.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE RecordWildCards #-}
{-| {-|
Generate several common kinds of report from a journal, as \"*Report\" - Generate several common kinds of report from a journal, as \"*Report\" -
@ -9,6 +10,17 @@ on the command-line options, should move to hledger-lib later.
-} -}
module Hledger.Cli.Reports ( module Hledger.Cli.Reports (
ReportOpts(..),
DisplayExpr,
FormatStr,
defreportopts,
dateSpanFromOpts,
intervalFromOpts,
clearedValueFromOpts,
whichDateFromOpts,
journalSelectingDateFromOpts,
journalSelectingAmountFromOpts,
optsToFilterSpec,
-- * Entries report -- * Entries report
EntriesReport, EntriesReport,
EntriesReportItem, EntriesReportItem,
@ -42,14 +54,138 @@ import Data.Ord
import Data.Time.Calendar import Data.Time.Calendar
import Data.Tree import Data.Tree
import Safe (headMay, lastMay) import Safe (headMay, lastMay)
import System.Console.CmdArgs -- for defaults support
import Test.HUnit import Test.HUnit
import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec
import Text.Printf import Text.Printf
import Hledger.Data import Hledger.Data
import Hledger.Utils import Hledger.Utils
import Hledger.Cli.Options -- import Hledger.Cli.Utils
import Hledger.Cli.Utils
-- report options, used in hledger-lib and above
data ReportOpts = ReportOpts {
begin_ :: Maybe Day
,end_ :: Maybe Day
,period_ :: Maybe (Interval,DateSpan)
,cleared_ :: Bool
,uncleared_ :: Bool
,cost_ :: Bool
,depth_ :: Maybe Int
,display_ :: Maybe DisplayExpr
,effective_ :: Bool
,empty_ :: Bool
,no_elide_ :: Bool
,real_ :: Bool
,flat_ :: Bool -- balance
,drop_ :: Int -- balance
,no_total_ :: Bool -- balance
,daily_ :: Bool
,weekly_ :: Bool
,monthly_ :: Bool
,quarterly_ :: Bool
,yearly_ :: Bool
,format_ :: Maybe FormatStr
,patterns_ :: [String]
} deriving (Show)
type DisplayExpr = String
type FormatStr = String
defreportopts = ReportOpts
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
instance Default ReportOpts where def = defreportopts
-- | Figure out the date span we should report on, based on any
-- begin/end/period options provided. A period option will cause begin and
-- end options to be ignored.
dateSpanFromOpts :: Day -> ReportOpts -> DateSpan
dateSpanFromOpts _ ReportOpts{..} =
case period_ of Just (_,span) -> span
Nothing -> DateSpan begin_ end_
-- | Figure out the reporting interval, if any, specified by the options.
-- --period overrides --daily overrides --weekly overrides --monthly etc.
intervalFromOpts :: ReportOpts -> Interval
intervalFromOpts ReportOpts{..} =
case period_ of
Just (interval,_) -> interval
Nothing -> i
where i | daily_ = Days 1
| weekly_ = Weeks 1
| monthly_ = Months 1
| quarterly_ = Quarters 1
| yearly_ = Years 1
| otherwise = NoInterval
-- | Get a maybe boolean representing the last cleared/uncleared option if any.
clearedValueFromOpts :: ReportOpts -> Maybe Bool
clearedValueFromOpts ReportOpts{..} | cleared_ = Just True
| uncleared_ = Just False
| otherwise = Nothing
-- | Detect which date we will report on, based on --effective.
whichDateFromOpts :: ReportOpts -> WhichDate
whichDateFromOpts ReportOpts{..} = if effective_ then EffectiveDate else ActualDate
-- | Convert this journal's transactions' primary date to either the
-- actual or effective date, as per options.
journalSelectingDateFromOpts :: ReportOpts -> Journal -> Journal
journalSelectingDateFromOpts opts = journalSelectingDate (whichDateFromOpts opts)
-- | Convert this journal's postings' amounts to the cost basis amounts if
-- specified by options.
journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal
journalSelectingAmountFromOpts opts
| cost_ opts = journalConvertAmountsToCost
| otherwise = id
-- | Convert application options to the library's generic filter specification.
optsToFilterSpec :: ReportOpts -> Day -> FilterSpec
optsToFilterSpec opts@ReportOpts{..} d = FilterSpec {
datespan=dateSpanFromOpts d opts
,cleared= clearedValueFromOpts opts
,real=real_
,empty=empty_
,acctpats=apats
,descpats=dpats
,depth = depth_
}
where (apats,dpats) = parsePatternArgs patterns_
-- | Gather filter pattern arguments into a list of account patterns and a
-- list of description patterns. We interpret pattern arguments as
-- follows: those prefixed with "desc:" are description patterns, all
-- others are account patterns; also patterns prefixed with "not:" are
-- negated. not: should come after desc: if both are used.
parsePatternArgs :: [String] -> ([String],[String])
parsePatternArgs args = (as, ds')
where
descprefix = "desc:"
(ds, as) = partition (descprefix `isPrefixOf`) args
ds' = map (drop (length descprefix)) ds
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -60,7 +196,7 @@ type EntriesReport = [EntriesReportItem]
type EntriesReportItem = Transaction type EntriesReportItem = Transaction
-- | Select transactions for an entries report. -- | Select transactions for an entries report.
entriesReport :: [Opt] -> FilterSpec -> Journal -> EntriesReport entriesReport :: ReportOpts -> FilterSpec -> Journal -> EntriesReport
entriesReport opts fspec j = sortBy (comparing tdate) $ jtxns $ filterJournalTransactions fspec j' entriesReport opts fspec j = sortBy (comparing tdate) $ jtxns $ filterJournalTransactions fspec j'
where where
j' = journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j j' = journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j
@ -79,12 +215,12 @@ type PostingsReportItem = (Maybe (Day, String) -- transaction date and descripti
-- | Select postings from the journal and add running balance and other -- | Select postings from the journal and add running balance and other
-- information to make a postings report. Used by eg hledger's register command. -- information to make a postings report. Used by eg hledger's register command.
postingsReport :: [Opt] -> FilterSpec -> Journal -> PostingsReport postingsReport :: ReportOpts -> FilterSpec -> Journal -> PostingsReport
postingsReport opts fspec j = (totallabel, postingsReportItems ps nullposting startbal (+)) postingsReport opts fspec j = (totallabel, postingsReportItems ps nullposting startbal (+))
where where
ps | interval == NoInterval = displayableps ps | interval == NoInterval = displayableps
| otherwise = summarisePostingsByInterval interval depth empty filterspan displayableps | otherwise = summarisePostingsByInterval interval depth empty filterspan displayableps
(precedingps, displayableps, _) = postingsMatchingDisplayExpr (displayExprFromOpts opts) (precedingps, displayableps, _) = postingsMatchingDisplayExpr (display_ opts)
$ depthClipPostings depth $ depthClipPostings depth
$ journalPostings $ journalPostings
$ filterJournalPostings fspec{depth=Nothing} $ filterJournalPostings fspec{depth=Nothing}
@ -93,7 +229,7 @@ postingsReport opts fspec j = (totallabel, postingsReportItems ps nullposting st
j j
startbal = sumPostings precedingps startbal = sumPostings precedingps
filterspan = datespan fspec filterspan = datespan fspec
(interval, depth, empty) = (intervalFromOpts opts, depthFromOpts opts, Empty `elem` opts) (interval, depth, empty) = (intervalFromOpts opts, depth_ opts, empty_ opts)
totallabel = "Total" totallabel = "Total"
balancelabel = "Balance" balancelabel = "Balance"
@ -238,7 +374,7 @@ triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0"
-- "postingsReport" except it uses matchers and transaction-based report -- "postingsReport" except it uses matchers and transaction-based report
-- items and the items are most recent first. Used by eg hledger-web's -- items and the items are most recent first. Used by eg hledger-web's
-- journal view. -- journal view.
journalTransactionsReport :: [Opt] -> Journal -> Matcher -> TransactionsReport journalTransactionsReport :: ReportOpts -> Journal -> Matcher -> TransactionsReport
journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items) journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items)
where where
ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts
@ -261,16 +397,16 @@ journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items)
-- Currently, reporting intervals are not supported, and report items are -- Currently, reporting intervals are not supported, and report items are
-- most recent first. Used by eg hledger-web's account register view. -- most recent first. Used by eg hledger-web's account register view.
-- --
accountTransactionsReport :: [Opt] -> Journal -> Matcher -> Matcher -> TransactionsReport accountTransactionsReport :: ReportOpts -> Journal -> Matcher -> Matcher -> TransactionsReport
accountTransactionsReport opts j m thisacctmatcher = (label, items) accountTransactionsReport opts j m thisacctmatcher = (label, items)
where where
-- transactions affecting this account, in date order -- transactions affecting this account, in date order
ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctmatcher) $ jtxns j ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctmatcher) $ jtxns j
-- starting balance: if we are filtering by a start date and nothing else, -- starting balance: if we are filtering by a start date and nothing else,
-- the sum of postings to this account before that date; otherwise zero. -- the sum of postings to this account before that date; otherwise zero.
(startbal,label) | matcherIsNull m = (nullmixedamt, balancelabel) (startbal,label) | matcherIsNull m = (nullmixedamt, balancelabel)
| matcherIsStartDateOnly effective m = (sumPostings priorps, balancelabel) | matcherIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel)
| otherwise = (nullmixedamt, totallabel) | otherwise = (nullmixedamt, totallabel)
where where
priorps = -- ltrace "priorps" $ priorps = -- ltrace "priorps" $
filter (matchesPosting filter (matchesPosting
@ -278,8 +414,7 @@ accountTransactionsReport opts j m thisacctmatcher = (label, items)
MatchAnd [thisacctmatcher, tostartdatematcher])) MatchAnd [thisacctmatcher, tostartdatematcher]))
$ transactionsPostings ts $ transactionsPostings ts
tostartdatematcher = MatchDate True (DateSpan Nothing startdate) tostartdatematcher = MatchDate True (DateSpan Nothing startdate)
startdate = matcherStartDate effective m startdate = matcherStartDate (effective_ opts) m
effective = Effective `elem` opts
items = reverse $ accountTransactionsReportItems m (Just thisacctmatcher) startbal negate ts items = reverse $ accountTransactionsReportItems m (Just thisacctmatcher) startbal negate ts
-- | Generate transactions report items from a list of transactions, -- | Generate transactions report items from a list of transactions,
@ -344,25 +479,25 @@ type AccountsReportItem = (AccountName -- full account name
-- | Select accounts, and get their balances at the end of the selected -- | Select accounts, and get their balances at the end of the selected
-- period, and misc. display information, for an accounts report. Used by -- period, and misc. display information, for an accounts report. Used by
-- eg hledger's balance command. -- eg hledger's balance command.
accountsReport :: [Opt] -> FilterSpec -> Journal -> AccountsReport accountsReport :: ReportOpts -> FilterSpec -> Journal -> AccountsReport
accountsReport opts filterspec j = accountsReport' opts j (journalToLedger filterspec) accountsReport opts filterspec j = accountsReport' opts j (journalToLedger filterspec)
-- | Select accounts, and get their balances at the end of the selected -- | Select accounts, and get their balances at the end of the selected
-- period, and misc. display information, for an accounts report. Like -- period, and misc. display information, for an accounts report. Like
-- "accountsReport" but uses the new matchers. Used by eg hledger-web's -- "accountsReport" but uses the new matchers. Used by eg hledger-web's
-- accounts sidebar. -- accounts sidebar.
accountsReport2 :: [Opt] -> Matcher -> Journal -> AccountsReport accountsReport2 :: ReportOpts -> Matcher -> Journal -> AccountsReport
accountsReport2 opts matcher j = accountsReport' opts j (journalToLedger2 matcher) accountsReport2 opts matcher j = accountsReport' opts j (journalToLedger2 matcher)
-- Accounts report helper. -- Accounts report helper.
accountsReport' :: [Opt] -> Journal -> (Journal -> Ledger) -> AccountsReport accountsReport' :: ReportOpts -> Journal -> (Journal -> Ledger) -> AccountsReport
accountsReport' opts j jtol = (items, total) accountsReport' opts j jtol = (items, total)
where where
items = map mkitem interestingaccts items = map mkitem interestingaccts
interestingaccts | NoElide `elem` opts = acctnames interestingaccts | no_elide_ opts = acctnames
| otherwise = filter (isInteresting opts l) acctnames | otherwise = filter (isInteresting opts l) acctnames
acctnames = sort $ tail $ flatten $ treemap aname accttree acctnames = sort $ tail $ flatten $ treemap aname accttree
accttree = ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) l accttree = ledgerAccountTree (fromMaybe 99999 $ depth_ opts) l
total = sum $ map abalance $ ledgerTopAccounts l total = sum $ map abalance $ ledgerTopAccounts l
l = jtol $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j l = jtol $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j
@ -370,14 +505,14 @@ accountsReport' opts j jtol = (items, total)
mkitem :: AccountName -> AccountsReportItem mkitem :: AccountName -> AccountsReportItem
mkitem a = (a, adisplay, indent, abal) mkitem a = (a, adisplay, indent, abal)
where where
adisplay | Flat `elem` opts = a adisplay | flat_ opts = a
| otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a] | otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]
where ps = takeWhile boring parents where boring = not . (`elem` interestingparents) where ps = takeWhile boring parents where boring = not . (`elem` interestingparents)
indent | Flat `elem` opts = 0 indent | flat_ opts = 0
| otherwise = length interestingparents | otherwise = length interestingparents
interestingparents = filter (`elem` interestingaccts) parents interestingparents = filter (`elem` interestingaccts) parents
parents = parentAccountNames a parents = parentAccountNames a
abal | Flat `elem` opts = exclusiveBalance acct abal | flat_ opts = exclusiveBalance acct
| otherwise = abalance acct | otherwise = abalance acct
where acct = ledgerAccount l a where acct = ledgerAccount l a
@ -386,24 +521,24 @@ exclusiveBalance = sumPostings . apostings
-- | Is the named account considered interesting for this ledger's accounts report, -- | Is the named account considered interesting for this ledger's accounts report,
-- following the eliding style of ledger's balance command ? -- following the eliding style of ledger's balance command ?
isInteresting :: [Opt] -> Ledger -> AccountName -> Bool isInteresting :: ReportOpts -> Ledger -> AccountName -> Bool
isInteresting opts l a | Flat `elem` opts = isInterestingFlat opts l a isInteresting opts l a | flat_ opts = isInterestingFlat opts l a
| otherwise = isInterestingIndented opts l a | otherwise = isInterestingIndented opts l a
isInterestingFlat :: [Opt] -> Ledger -> AccountName -> Bool isInterestingFlat :: ReportOpts -> Ledger -> AccountName -> Bool
isInterestingFlat opts l a = notempty || emptyflag isInterestingFlat opts l a = notempty || emptyflag
where where
acct = ledgerAccount l a acct = ledgerAccount l a
notempty = not $ isZeroMixedAmount $ exclusiveBalance acct notempty = not $ isZeroMixedAmount $ exclusiveBalance acct
emptyflag = Empty `elem` opts emptyflag = empty_ opts
isInterestingIndented :: [Opt] -> Ledger -> AccountName -> Bool isInterestingIndented :: ReportOpts -> Ledger -> AccountName -> Bool
isInterestingIndented opts l a isInterestingIndented opts l a
| numinterestingsubs==1 && not atmaxdepth = notlikesub | numinterestingsubs==1 && not atmaxdepth = notlikesub
| otherwise = notzero || emptyflag | otherwise = notzero || emptyflag
where where
atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depthFromOpts opts atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depth_ opts
emptyflag = Empty `elem` opts emptyflag = empty_ opts
acct = ledgerAccount l a acct = ledgerAccount l a
notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct
notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct

15
hledger/Hledger/Cli/Stats.hs
View File

@ -15,6 +15,7 @@ import Text.Printf
import qualified Data.Map as Map import qualified Data.Map as Map
import Hledger.Cli.Options import Hledger.Cli.Options
import Hledger.Cli.Reports
import Hledger.Data import Hledger.Data
import Prelude hiding (putStr) import Prelude hiding (putStr)
import Hledger.Utils.UTF8 (putStr) import Hledger.Utils.UTF8 (putStr)
@ -22,19 +23,19 @@ import Hledger.Utils.UTF8 (putStr)
-- like Register.summarisePostings -- like Register.summarisePostings
-- | Print various statistics for the journal. -- | Print various statistics for the journal.
stats :: [Opt] -> [String] -> Journal -> IO () stats :: CliOpts -> Journal -> IO ()
stats opts args j = do stats CliOpts{reportopts_=reportopts_} j = do
d <- getCurrentDay d <- getCurrentDay
let filterspec = optsToFilterSpec opts args d let filterspec = optsToFilterSpec reportopts_ d
l = journalToLedger filterspec j l = journalToLedger filterspec j
reportspan = (ledgerDateSpan l) `orDatesFrom` (datespan filterspec) reportspan = (ledgerDateSpan l) `orDatesFrom` (datespan filterspec)
intervalspans = splitSpan (intervalFromOpts opts) reportspan intervalspans = splitSpan (intervalFromOpts reportopts_) reportspan
showstats = showLedgerStats opts args l d showstats = showLedgerStats l d
s = intercalate "\n" $ map showstats intervalspans s = intercalate "\n" $ map showstats intervalspans
putStr s putStr s
showLedgerStats :: [Opt] -> [String] -> Ledger -> Day -> DateSpan -> String showLedgerStats :: Ledger -> Day -> DateSpan -> String
showLedgerStats _ _ l today span = showLedgerStats l today span =
unlines (map (uncurry (printf fmt)) stats) unlines (map (uncurry (printf fmt)) stats)
where where
fmt = "%-" ++ show w1 ++ "s: %-" ++ show w2 ++ "s" fmt = "%-" ++ show w1 ++ "s: %-" ++ show w2 ++ "s"

18
hledger/Hledger/Cli/Tests.hs
View File

@ -38,22 +38,22 @@ import Hledger.Utils
-- | Run unit tests and exit with success or failure. -- | Run unit tests and exit with success or failure.
runtests :: [Opt] -> [String] -> IO () runtests :: CliOpts -> IO ()
runtests opts args = do runtests opts = do
(hunitcounts,_) <- runtests' opts args (hunitcounts,_) <- runtests' opts
if errors hunitcounts > 0 || (failures hunitcounts > 0) if errors hunitcounts > 0 || (failures hunitcounts > 0)
then exitFailure then exitFailure
else exitWith ExitSuccess else exitWith ExitSuccess
-- | Run unit tests and exit on failure. -- | Run unit tests and exit on failure.
runTestsOrExit :: [Opt] -> [String] -> IO () runTestsOrExit :: CliOpts -> IO ()
runTestsOrExit opts args = do runTestsOrExit opts = do
(hunitcounts,_) <- runtests' opts args (hunitcounts,_) <- runtests' opts
when (errors hunitcounts > 0 || (failures hunitcounts > 0)) $ exitFailure when (errors hunitcounts > 0 || (failures hunitcounts > 0)) $ exitFailure
runtests' :: Num b => t -> [String] -> IO (Counts, b) runtests' :: Num b => CliOpts -> IO (Counts, b)
runtests' _ args = liftM (flip (,) 0) $ runTestTT ts runtests' opts = liftM (flip (,) 0) $ runTestTT ts
where where
ts = TestList $ filter matchname $ tflatten tests_Hledger_Cli -- show flat test names ts = TestList $ filter matchname $ tflatten tests_Hledger_Cli -- show flat test names
-- ts = tfilter matchname $ TestList tests -- show hierarchical test names -- ts = tfilter matchname $ TestList tests -- show hierarchical test names
matchname = matchpats args . tname matchname = matchpats (patterns_ $ reportopts_ opts) . tname

30
hledger/Hledger/Cli/Utils.hs
View File

@ -10,8 +10,6 @@ module Hledger.Cli.Utils
( (
withJournalDo, withJournalDo,
readJournal', readJournal',
journalSelectingDateFromOpts,
journalSelectingAmountFromOpts,
journalReload, journalReload,
journalReloadIfChanged, journalReloadIfChanged,
journalFileIsNewer, journalFileIsNewer,
@ -25,10 +23,10 @@ module Hledger.Cli.Utils
) )
where where
import Control.Exception import Control.Exception
import Control.Monad
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Safe (readMay) import Safe (readMay)
import System.Console.CmdArgs
import System.Directory (getModificationTime, getDirectoryContents, copyFile) import System.Directory (getModificationTime, getDirectoryContents, copyFile)
import System.Exit import System.Exit
import System.FilePath ((</>), splitFileName, takeDirectory) import System.FilePath ((</>), splitFileName, takeDirectory)
@ -46,34 +44,22 @@ import Hledger.Utils
-- | Parse the user's specified journal file and run a hledger command on -- | Parse the user's specified journal file and run a hledger command on
-- it, or throw an error. -- it, or throw an error.
withJournalDo :: [Opt] -> [String] -> String -> ([Opt] -> [String] -> Journal -> IO ()) -> IO () withJournalDo :: CliOpts -> (CliOpts -> Journal -> IO ()) -> IO ()
withJournalDo opts args _ cmd = do withJournalDo opts cmd = do
-- We kludgily read the file before parsing to grab the full text, unless -- We kludgily read the file before parsing to grab the full text, unless
-- it's stdin, or it doesn't exist and we are adding. We read it strictly -- it's stdin, or it doesn't exist and we are adding. We read it strictly
-- to let the add command work. -- to let the add command work.
journalFilePathFromOpts opts >>= readJournalFile Nothing >>= journalFilePathFromOpts opts >>= readJournalFile Nothing >>=
either error' (cmd opts args . journalApplyAliases (aliasesFromOpts opts)) either error' (cmd opts . journalApplyAliases (aliasesFromOpts opts))
-- -- | Get a journal from the given string and options, or throw an error. -- -- | Get a journal from the given string and options, or throw an error.
-- readJournalWithOpts :: [Opt] -> String -> IO Journal -- readJournalWithOpts :: CliOpts -> String -> IO Journal
-- readJournalWithOpts opts s = readJournal Nothing s >>= either error' return -- readJournalWithOpts opts s = readJournal Nothing s >>= either error' return
-- | Get a journal from the given string, or throw an error. -- | Get a journal from the given string, or throw an error.
readJournal' :: String -> IO Journal readJournal' :: String -> IO Journal
readJournal' s = readJournal Nothing s >>= either error' return readJournal' s = readJournal Nothing s >>= either error' return
-- | Convert this journal's transactions' primary date to either the
-- actual or effective date, as per options.
journalSelectingDateFromOpts :: [Opt] -> Journal -> Journal
journalSelectingDateFromOpts opts = journalSelectingDate (whichDateFromOpts opts)
-- | Convert this journal's postings' amounts to the cost basis amounts if
-- specified by options.
journalSelectingAmountFromOpts :: [Opt] -> Journal -> Journal
journalSelectingAmountFromOpts opts
| CostBasis `elem` opts = journalConvertAmountsToCost
| otherwise = id
-- | Re-read a journal from its data file, or return an error string. -- | Re-read a journal from its data file, or return an error string.
journalReload :: Journal -> IO (Either String Journal) journalReload :: Journal -> IO (Either String Journal)
journalReload j = readJournalFile Nothing $ journalFilePath j journalReload j = readJournalFile Nothing $ journalFilePath j
@ -83,14 +69,14 @@ journalReload j = readJournalFile Nothing $ journalFilePath j
-- stdin). The provided options are mostly ignored. Return a journal or -- stdin). The provided options are mostly ignored. Return a journal or
-- the error message while reading it, and a flag indicating whether it -- the error message while reading it, and a flag indicating whether it
-- was re-read or not. -- was re-read or not.
journalReloadIfChanged :: [Opt] -> Journal -> IO (Either String Journal, Bool) journalReloadIfChanged :: CliOpts -> Journal -> IO (Either String Journal, Bool)
journalReloadIfChanged opts j = do journalReloadIfChanged _ j = do
let maybeChangedFilename f = do newer <- journalSpecifiedFileIsNewer j f let maybeChangedFilename f = do newer <- journalSpecifiedFileIsNewer j f
return $ if newer then Just f else Nothing return $ if newer then Just f else Nothing
changedfiles <- catMaybes `fmap` mapM maybeChangedFilename (journalFilePaths j) changedfiles <- catMaybes `fmap` mapM maybeChangedFilename (journalFilePaths j)
if not $ null changedfiles if not $ null changedfiles
then do then do
when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (head changedfiles) whenLoud $ printf "%s has changed, reloading\n" (head changedfiles)
jE <- journalReload j jE <- journalReload j
return (jE, True) return (jE, True)
else else

2
hledger/hledger.cabal
View File

@ -60,6 +60,7 @@ library
hledger-lib == 0.15 hledger-lib == 0.15
,base >= 3 && < 5 ,base >= 3 && < 5
,containers ,containers
,cmdargs >= 0.7 && < 0.8
,csv ,csv
,directory ,directory
,filepath ,filepath
@ -110,6 +111,7 @@ executable hledger
hledger-lib == 0.15 hledger-lib == 0.15
,base >= 3 && < 5 ,base >= 3 && < 5
,containers ,containers
,cmdargs >= 0.7 && < 0.8
,csv ,csv
,directory ,directory
,filepath ,filepath

2
tests/convert-with-in-and-out-fields.test
View File

@ -1,5 +1,5 @@
# Conversion from CSV to Ledger with in-field and out-field # Conversion from CSV to Ledger with in-field and out-field
rm -rf unused.journal$$ convert.rules$$; printf 'base-account Assets:MyAccount\ndate-field 0\ndate-format %%d/%%Y/%%m\ndescription-field 1\nin-field 2\nout-field 3\ncurrency $\n' >convert.rules$$ ; touch unused.journal$$ ; bin/hledger -f unused.journal$$ convert --rules convert.rules$$ - ; rm -rf *$$ rm -rf convert.rules$$; printf 'base-account Assets:MyAccount\ndate-field 0\ndate-format %%d/%%Y/%%m\ndescription-field 1\nin-field 2\nout-field 3\ncurrency $\n' >convert.rules$$ ; bin/hledger convert --rules-file convert.rules$$ - ; rm -rf *$$
<<< <<<
10/2009/09,Flubber Co,50, 10/2009/09,Flubber Co,50,
11/2009/09,Flubber Co,,50 11/2009/09,Flubber Co,,50

2
tests/convert.test
View File

@ -1,5 +1,5 @@
# Conversion from CSV to Ledger # Conversion from CSV to Ledger
rm -rf input.rules; printf 'base-account Assets:MyAccount\ndate-field 0\ndate-format %%d/%%Y/%%m\ndescription-field 1\namount-field 2\ncurrency $\n' > input.rules ; printf '10/2009/09,Flubber Co,50' > input.csv$$ ; touch unused.journal$$ ; bin/hledger -f unused.journal$$ convert input.csv$$ ; rm -rf input.rules *$$ rm -rf input.rules; printf 'base-account Assets:MyAccount\ndate-field 0\ndate-format %%d/%%Y/%%m\ndescription-field 1\namount-field 2\ncurrency $\n' > input.rules ; printf '10/2009/09,Flubber Co,50' > input.csv$$ ; bin/hledger convert input.csv$$ ; rm -rf input.rules *$$
>>> >>>
2009/09/10 Flubber Co 2009/09/10 Flubber Co
income:unknown $-50 income:unknown $-50

6
tests/prices.test
View File

@ -12,8 +12,8 @@ bin/hledger -f- print
>>>=0 >>>=0
# 2. convert to cost basis # 2. convert to cost
bin/hledger -f- print -B bin/hledger -f- print --cost
<<< <<<
2011/01/01 2011/01/01
expenses:foreign currency €100 @ $1.35 expenses:foreign currency €100 @ $1.35
@ -135,7 +135,7 @@ bin/hledger -f - balance -B
0 0
>>>=0 >>>=0
# 10. transaction in two commodities should balance out properly # 10. transaction in two commodities should balance out properly
bin/hledger -f - balance --basis bin/hledger -f - balance --cost
<<< <<<
2011/01/01 x 2011/01/01 x
a 10£ @@ 16$ a 10£ @@ 16$