web: more web and report refactoring, and a html register report
This commit is contained in:
Simon Michael
parent
b6c7cd8a98
commit
4467af1aa8
@ -10,7 +10,7 @@ where
|
||||
import Hledger.Data
|
||||
import Hledger.Read.Journal (someamount)
|
||||
import Hledger.Cli.Options
|
||||
import Hledger.Cli.Commands.Register (showRegisterReport)
|
||||
import Hledger.Cli.Commands.Register (registerReport, registerReportAsText)
|
||||
#if __GLASGOW_HASKELL__ <= 610
|
||||
import Prelude hiding (putStr, putStrLn, getLine, appendFile)
|
||||
import System.IO.UTF8
|
||||
@ -160,7 +160,7 @@ registerFromString :: String -> IO String
|
||||
registerFromString s = do
|
||||
now <- getCurrentLocalTime
|
||||
l <- readJournalWithOpts [] s
|
||||
return $ showRegisterReport opts (optsToFilterSpec opts [] now) l
|
||||
return $ registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] now) l
|
||||
where opts = [Empty]
|
||||
|
||||
-- | Return a similarity measure, from 0 to 1, for two strings.
|
||||
|
||||
@ -95,8 +95,14 @@ balance report:
|
||||
|
||||
-}
|
||||
|
||||
module Hledger.Cli.Commands.Balance
|
||||
where
|
||||
module Hledger.Cli.Commands.Balance (
|
||||
balance
|
||||
,BalanceReport
|
||||
,BalanceReportItem
|
||||
,balanceReport
|
||||
,balanceReportAsText
|
||||
-- ,tests_Balance
|
||||
) where
|
||||
import Hledger.Data.Utils
|
||||
import Hledger.Data.Types
|
||||
import Hledger.Data.Amount
|
||||
@ -110,7 +116,7 @@ import System.IO.UTF8
|
||||
#endif
|
||||
|
||||
|
||||
-- | The data for a balance report.
|
||||
-- | A balance report is a chart of accounts with balances, and their grand total.
|
||||
type BalanceReport = ([BalanceReportItem] -- ^ line items, one per account
|
||||
,MixedAmount -- ^ total balance of all accounts
|
||||
)
|
||||
@ -126,24 +132,29 @@ type BalanceReportItem = (AccountName -- ^ full account name
|
||||
balance :: [Opt] -> [String] -> Journal -> IO ()
|
||||
balance opts args j = do
|
||||
t <- getCurrentLocalTime
|
||||
putStr $ showBalanceReport opts $ balanceReport opts (optsToFilterSpec opts args t) j
|
||||
putStr $ balanceReportAsText opts $ balanceReport opts (optsToFilterSpec opts args t) j
|
||||
|
||||
-- | Render a balance report as plain text suitable for console output.
|
||||
showBalanceReport :: [Opt] -> BalanceReport -> String
|
||||
showBalanceReport opts (items,total) = acctsstr ++ totalstr
|
||||
balanceReportAsText :: [Opt] -> BalanceReport -> String
|
||||
balanceReportAsText opts (items,total) =
|
||||
unlines $
|
||||
map (balanceReportItemAsText opts) items
|
||||
++
|
||||
if NoTotal `elem` opts
|
||||
then []
|
||||
else ["--------------------"
|
||||
,padleft 20 $ showMixedAmountWithoutPrice total
|
||||
]
|
||||
|
||||
-- | Render one balance report line item as plain text.
|
||||
balanceReportItemAsText :: [Opt] -> BalanceReportItem -> String
|
||||
balanceReportItemAsText opts (a, adisplay, adepth, abal) = concatTopPadded [amt, " ", name]
|
||||
where
|
||||
acctsstr = unlines $ map showitem items
|
||||
totalstr | NoTotal `elem` opts = ""
|
||||
| otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmountWithoutPrice total
|
||||
-- | Render one balance report line item as plain text.
|
||||
showitem :: BalanceReportItem -> String
|
||||
showitem (a, adisplay, adepth, abal) = concatTopPadded [amt, " ", name]
|
||||
where
|
||||
amt = padleft 20 $ showMixedAmountWithoutPrice abal
|
||||
name | Flat `elem` opts = accountNameDrop (dropFromOpts opts) a
|
||||
| otherwise = depthspacer ++ adisplay
|
||||
depthspacer = replicate (indentperlevel * adepth) ' '
|
||||
indentperlevel = 2
|
||||
amt = padleft 20 $ showMixedAmountWithoutPrice abal
|
||||
name | Flat `elem` opts = accountNameDrop (dropFromOpts opts) a
|
||||
| otherwise = depthspacer ++ adisplay
|
||||
depthspacer = replicate (indentperlevel * adepth) ' '
|
||||
indentperlevel = 2
|
||||
|
||||
-- | Get a balance report with the specified options for this journal.
|
||||
balanceReport :: [Opt] -> FilterSpec -> Journal -> BalanceReport
|
||||
@ -157,11 +168,13 @@ balanceReport opts filterspec j = (items, total)
|
||||
l = journalToLedger filterspec j
|
||||
-- | Get data for one balance report line item.
|
||||
mkitem :: AccountName -> BalanceReportItem
|
||||
mkitem a = (a, adisplay, adepth, abal)
|
||||
mkitem a = (a, adisplay, indent, abal)
|
||||
where
|
||||
adisplay = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]
|
||||
adisplay | Flat `elem` opts = a
|
||||
| otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]
|
||||
where ps = takeWhile boring parents where boring = not . (`elem` interestingparents)
|
||||
adepth = length interestingparents
|
||||
indent | Flat `elem` opts = 0
|
||||
| otherwise = length interestingparents
|
||||
interestingparents = filter (`elem` interestingaccts) parents
|
||||
parents = parentAccountNames a
|
||||
abal | Flat `elem` opts = exclusiveBalance acct
|
||||
|
||||
@ -7,8 +7,11 @@ A ledger-compatible @register@ command.
|
||||
|
||||
module Hledger.Cli.Commands.Register (
|
||||
register
|
||||
,showRegisterReport
|
||||
,showPostingWithBalance
|
||||
,RegisterReport
|
||||
,RegisterReportItem
|
||||
,registerReport
|
||||
,registerReportAsText
|
||||
,showPostingWithBalanceForVty
|
||||
,tests_Register
|
||||
) where
|
||||
|
||||
@ -22,24 +25,80 @@ import System.IO.UTF8
|
||||
import Text.ParserCombinators.Parsec
|
||||
|
||||
|
||||
-- | A register report is a list of postings to an account or set of
|
||||
-- accounts, with a running total. Postings may be actual postings, or
|
||||
-- virtual postings aggregated over a reporting interval.
|
||||
type RegisterReport = [RegisterReportItem] -- ^ line items, one per posting
|
||||
|
||||
-- | The data for a single register report line item, representing one posting.
|
||||
type RegisterReportItem = (Maybe (Day, String) -- ^ transaction date and description if this is the first posting
|
||||
,Posting -- ^ the posting
|
||||
,MixedAmount -- ^ balance so far
|
||||
)
|
||||
|
||||
-- | Print a register report.
|
||||
register :: [Opt] -> [String] -> Journal -> IO ()
|
||||
register opts args j = do
|
||||
t <- getCurrentLocalTime
|
||||
putStr $ showRegisterReport opts (optsToFilterSpec opts args t) j
|
||||
putStr $ registerReportAsText opts $ registerReport opts (optsToFilterSpec opts args t) j
|
||||
|
||||
-- | Generate the register report, which is a list of postings with transaction
|
||||
-- info and a running balance.
|
||||
showRegisterReport :: [Opt] -> FilterSpec -> Journal -> String
|
||||
showRegisterReport opts filterspec j = showPostingsWithBalance ps nullposting startbal
|
||||
-- | Render a register report as plain text suitable for console output.
|
||||
registerReportAsText :: [Opt] -> RegisterReport -> String
|
||||
registerReportAsText opts = unlines . map (registerReportItemAsText opts)
|
||||
|
||||
-- | Render one register report line item as plain text. Eg:
|
||||
-- @
|
||||
-- date (10) description (20) account (22) amount (11) balance (12)
|
||||
-- DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
|
||||
-- ^ displayed for first postings^
|
||||
-- only, otherwise blank
|
||||
-- @
|
||||
registerReportItemAsText :: [Opt] -> RegisterReportItem -> String
|
||||
registerReportItemAsText _ (dd, p, b) = concatTopPadded [datedesc, pstr, " ", bal]
|
||||
where
|
||||
datedesc = case dd of Nothing -> replicate datedescwidth ' '
|
||||
Just (da, de) -> printf "%s %s " date desc
|
||||
where
|
||||
date = showDate da
|
||||
desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String
|
||||
where
|
||||
descwidth = datedescwidth - datewidth - 2
|
||||
datedescwidth = 32
|
||||
datewidth = 10
|
||||
pstr = showPostingForRegister p
|
||||
bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)
|
||||
|
||||
showPostingWithBalanceForVty showtxninfo p b = registerReportItemAsText [] $ mkitem showtxninfo p b
|
||||
|
||||
-- | Get a register report with the specified options for this journal.
|
||||
registerReport :: [Opt] -> FilterSpec -> Journal -> RegisterReport
|
||||
registerReport opts fspec j = getitems ps nullposting startbal
|
||||
where
|
||||
ps | interval == NoInterval = displayableps
|
||||
| otherwise = summarisePostings interval depth empty filterspan displayableps
|
||||
| otherwise = summarisePostings interval depth empty filterspan displayableps
|
||||
(precedingps, displayableps, _) =
|
||||
postingsMatchingDisplayExpr (displayExprFromOpts opts) $ journalPostings $ filterJournalPostings fspec j
|
||||
startbal = sumPostings precedingps
|
||||
(precedingps,displayableps,_) =
|
||||
postingsMatchingDisplayExpr (displayExprFromOpts opts) $ journalPostings $ filterJournalPostings filterspec j
|
||||
(interval, depth, empty) = (intervalFromOpts opts, depthFromOpts opts, Empty `elem` opts)
|
||||
filterspan = datespan filterspec
|
||||
filterspan = datespan fspec
|
||||
|
||||
-- | Generate register report line items.
|
||||
getitems :: [Posting] -> Posting -> MixedAmount -> [RegisterReportItem]
|
||||
getitems [] _ _ = []
|
||||
getitems (p:ps) pprev b = i:(getitems ps p b')
|
||||
where
|
||||
i = mkitem isfirst p b'
|
||||
isfirst = ptransaction p /= ptransaction pprev
|
||||
b' = b + pamount p
|
||||
|
||||
-- | Generate one register report line item, from a flag indicating
|
||||
-- whether to include transaction info, a posting, and the current running
|
||||
-- balance.
|
||||
mkitem :: Bool -> Posting -> MixedAmount -> RegisterReportItem
|
||||
mkitem False p b = (Nothing, p, b)
|
||||
mkitem True p b = (ds, p, b)
|
||||
where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de)
|
||||
Nothing -> Just (nulldate,"")
|
||||
|
||||
-- | Convert a list of postings into summary postings, one per interval.
|
||||
summarisePostings :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting]
|
||||
@ -124,40 +183,6 @@ summarisePostingsInDateSpan (DateSpan b e) depth showempty ps
|
||||
balancetoshowfor a =
|
||||
(if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)
|
||||
|
||||
{- |
|
||||
Show postings one per line, plus transaction info for the first posting of
|
||||
each transaction, and a running balance. Eg:
|
||||
|
||||
@
|
||||
date (10) description (20) account (22) amount (11) balance (12)
|
||||
DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
|
||||
aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
|
||||
@
|
||||
-}
|
||||
showPostingsWithBalance :: [Posting] -> Posting -> MixedAmount -> String
|
||||
showPostingsWithBalance [] _ _ = ""
|
||||
showPostingsWithBalance (p:ps) pprev bal = this ++ showPostingsWithBalance ps p bal'
|
||||
where
|
||||
this = showPostingWithBalance isfirst p bal'
|
||||
isfirst = ptransaction p /= ptransaction pprev
|
||||
bal' = bal + pamount p
|
||||
|
||||
-- | Show one posting and running balance, with or without transaction info.
|
||||
showPostingWithBalance :: Bool -> Posting -> MixedAmount -> String
|
||||
showPostingWithBalance withtxninfo p b = concatTopPadded [txninfo, pstr, " ", bal] ++ "\n"
|
||||
where
|
||||
ledger3ishlayout = False
|
||||
datedescwidth = if ledger3ishlayout then 34 else 32
|
||||
txninfo = if withtxninfo then printf "%s %s " date desc else replicate datedescwidth ' '
|
||||
date = showDate da
|
||||
datewidth = 10
|
||||
descwidth = datedescwidth - datewidth - 2
|
||||
desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String
|
||||
pstr = showPostingForRegister p
|
||||
bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)
|
||||
(da,de) = case ptransaction p of Just (Transaction{tdate=da',tdescription=de'}) -> (da',de')
|
||||
Nothing -> (nulldate,"")
|
||||
|
||||
tests_Register :: Test
|
||||
tests_Register = TestList [
|
||||
|
||||
|
||||
@ -229,8 +229,8 @@ resetTrailAndEnter t scr a = enter t scr (aargs a) $ clearLocs a
|
||||
updateData :: LocalTime -> AppState -> AppState
|
||||
updateData t a@AppState{aopts=opts,ajournal=j} =
|
||||
case screen a of
|
||||
BalanceScreen -> a{abuf=lines $ showBalanceReport opts $ balanceReport opts fspec j}
|
||||
RegisterScreen -> a{abuf=lines $ showRegisterReport opts fspec j}
|
||||
BalanceScreen -> a{abuf=lines $ balanceReportAsText opts $ balanceReport opts fspec j}
|
||||
RegisterScreen -> a{abuf=lines $ registerReportAsText opts $ registerReport opts fspec j}
|
||||
PrintScreen -> a{abuf=lines $ showTransactions fspec j}
|
||||
where fspec = optsToFilterSpec opts (currentArgs a) t
|
||||
|
||||
@ -289,7 +289,7 @@ currentTransaction a@AppState{ajournal=j,abuf=buf} = ptransaction p
|
||||
where
|
||||
p = headDef nullposting $ filter ismatch $ journalPostings j
|
||||
ismatch p = postingDate p == parsedate (take 10 datedesc)
|
||||
&& take 70 (showPostingWithBalance False p nullmixedamt) == (datedesc ++ acctamt)
|
||||
&& take 70 (showPostingWithBalanceForVty False p nullmixedamt) == (datedesc ++ acctamt)
|
||||
datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ headDef "" rest : reverse above
|
||||
acctamt = drop 32 $ headDef "" rest
|
||||
(above,rest) = splitAt y buf
|
||||
|
||||
@ -115,114 +115,155 @@ getStyleCss = do
|
||||
sendFile "text/css" $ dir </> "style.css"
|
||||
|
||||
getIndexPage :: Handler HledgerWebApp ()
|
||||
getIndexPage = redirect RedirectTemporary JournalPage
|
||||
getIndexPage = redirect RedirectTemporary BalancePage
|
||||
|
||||
-- | Gather all the stuff we want for a typical hledger web request handler.
|
||||
getHandlerParameters :: Handler HledgerWebApp
|
||||
(String, String, [Opt], FilterSpec, Journal, Maybe (Html ()), HledgerWebAppRoute)
|
||||
getHandlerParameters = do
|
||||
Just here <- getCurrentRoute
|
||||
(a, p, opts, fspec) <- getReportParameters
|
||||
(j, err) <- getLatestJournal opts
|
||||
msg <- getMessage' err
|
||||
return (a, p, opts, fspec, j, msg, here)
|
||||
where
|
||||
-- | Get current report parameters for this request.
|
||||
getReportParameters :: Handler HledgerWebApp (String, String, [Opt], FilterSpec)
|
||||
getReportParameters = do
|
||||
app <- getYesod
|
||||
t <- liftIO $ getCurrentLocalTime
|
||||
a <- fromMaybe "" <$> lookupGetParam "a"
|
||||
p <- fromMaybe "" <$> lookupGetParam "p"
|
||||
let opts = appOpts app ++ [Period p]
|
||||
args = appArgs app ++ [a]
|
||||
fspec = optsToFilterSpec opts args t
|
||||
return (a, p, opts, fspec)
|
||||
|
||||
-- | 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
|
||||
-- ui message.
|
||||
getLatestJournal :: [Opt] -> Handler HledgerWebApp (Journal, Maybe String)
|
||||
getLatestJournal opts = do
|
||||
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
||||
(jE, changed) <- liftIO $ journalReloadIfChanged opts j
|
||||
if not changed
|
||||
then return (j,Nothing)
|
||||
else case jE of
|
||||
Right j' -> do liftIO $ putValue "hledger" "journal" j'
|
||||
return (j',Nothing)
|
||||
Left e -> do setMessage $ string "error while reading" {- ++ ": " ++ e-}
|
||||
return (j, Just e)
|
||||
|
||||
-- | Helper to work around a yesod feature (can't set and get a message in the same request.)
|
||||
getMessage' :: Maybe String -> Handler HledgerWebApp (Maybe (Html ()))
|
||||
getMessage' newmsgstr = do
|
||||
oldmsg <- getMessage
|
||||
return $ maybe oldmsg (Just . string) newmsgstr
|
||||
|
||||
-- renderLatestJournalWith :: ([Opt] -> FilterSpec -> Journal -> Html ()) -> Handler HledgerWebApp RepHtml
|
||||
-- renderLatestJournalWith reportHtml = do
|
||||
-- (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
|
||||
-- let td' = td{here=here, title="hledger", msg=msg, a=a, p=p, content=reportHtml opts fspec j}
|
||||
-- hamletToRepHtml $ pageLayout td'
|
||||
|
||||
getJournalPage :: Handler HledgerWebApp RepHtml
|
||||
getJournalPage = withLatestJournalRender (const showTransactions)
|
||||
getJournalPage = do
|
||||
(a, p, _, fspec, j, msg, here) <- getHandlerParameters
|
||||
let td' = td{here=here, title="hledger", msg=msg, a=a, p=p, content=
|
||||
stringToPre $ showTransactions fspec j
|
||||
}
|
||||
hamletToRepHtml $ pageLayout td'
|
||||
|
||||
getRegisterPage :: Handler HledgerWebApp RepHtml
|
||||
getRegisterPage = withLatestJournalRender showRegisterReport
|
||||
|
||||
withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
|
||||
withLatestJournalRender reportfn = do
|
||||
app <- getYesod
|
||||
t <- liftIO $ getCurrentLocalTime
|
||||
a <- fromMaybe "" <$> lookupGetParam "a"
|
||||
p <- fromMaybe "" <$> lookupGetParam "p"
|
||||
let opts = appOpts app ++ [Period p]
|
||||
args = appArgs app ++ [a]
|
||||
fspec = optsToFilterSpec opts args t
|
||||
-- reload journal if changed, displaying any error as a message
|
||||
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
||||
(jE, changed) <- liftIO $ journalReloadIfChanged opts j
|
||||
let (j', err) = either (\e -> (j,e)) (\j -> (j,"")) jE
|
||||
when (changed && null err) $ liftIO $ putValue "hledger" "journal" j'
|
||||
if (changed && not (null err)) then setMessage $ string "error while reading"
|
||||
else return ()
|
||||
-- run the specified report using this request's params
|
||||
let s = reportfn opts fspec j'
|
||||
-- render the standard template
|
||||
msg' <- getMessage
|
||||
-- XXX work around a bug, can't get the message we set above
|
||||
let msg = if null err then msg' else Just $ string $ printf "Error while reading %s" (filepath j')
|
||||
Just here <- getCurrentRoute
|
||||
hamletToRepHtml $ pageLayout td{here=here, title="hledger", msg=msg, a=a, p=p, content=stringToPre s}
|
||||
|
||||
-- XXX duplication of withLatestJournalRender
|
||||
getEditPage :: Handler HledgerWebApp RepHtml
|
||||
getEditPage = do
|
||||
-- app <- getYesod
|
||||
-- t <- liftIO $ getCurrentLocalTime
|
||||
a <- fromMaybe "" <$> lookupGetParam "a"
|
||||
p <- fromMaybe "" <$> lookupGetParam "p"
|
||||
-- opts = appOpts app ++ [Period p]
|
||||
-- args = appArgs app ++ [a]
|
||||
-- fspec = optsToFilterSpec opts args t
|
||||
-- reload journal's text, without parsing, if changed
|
||||
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
||||
changed <- liftIO $ journalFileIsNewer j
|
||||
-- XXX readFile may throw an error
|
||||
s <- liftIO $ if changed then readFile (filepath j) else return (jtext j)
|
||||
-- render the page
|
||||
msg <- getMessage
|
||||
Just here <- getCurrentRoute
|
||||
-- XXX mucking around to squeeze editform into pageLayout
|
||||
let td' = td{here=here, title="hledger", msg=msg, a=a, p=p, content=(editform td') show, contentplain=s}
|
||||
hamletToRepHtml $ pageLayout td'
|
||||
|
||||
-- XXX duplication of withLatestJournalRender
|
||||
getBalancePage :: Handler HledgerWebApp RepHtml
|
||||
getBalancePage = do
|
||||
app <- getYesod
|
||||
t <- liftIO $ getCurrentLocalTime
|
||||
a <- fromMaybe "" <$> lookupGetParam "a"
|
||||
p <- fromMaybe "" <$> lookupGetParam "p"
|
||||
let opts = appOpts app ++ [Period p]
|
||||
args = appArgs app ++ [a]
|
||||
fspec = optsToFilterSpec opts args t
|
||||
-- reload journal if changed, displaying any error as a message
|
||||
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
||||
(jE, changed) <- liftIO $ journalReloadIfChanged opts j
|
||||
let (j', err) = either (\e -> (j,e)) (\j -> (j,"")) jE
|
||||
when (changed && null err) $ liftIO $ putValue "hledger" "journal" j'
|
||||
if (changed && not (null err)) then setMessage $ string "error while reading"
|
||||
else return ()
|
||||
Just here <- getCurrentRoute
|
||||
msg' <- getMessage
|
||||
-- XXX work around a misfeature, can't get a message we just set in this request
|
||||
let msg = if null err then msg' else Just $ string $ printf "Error while reading %s" (filepath j')
|
||||
-- run and render the report
|
||||
let td' = td{here=here, title="hledger", msg=msg, a=a, p=p
|
||||
,content=(balanceReportToHtml opts td' $ balanceReport opts fspec j')}
|
||||
hamletToRepHtml $ pageLayout td'
|
||||
(a, p, opts, fspec, j, msg, here) <- getHandlerParameters
|
||||
let td' = td{here=here, title="hledger", msg=msg, a=a, p=p, content=
|
||||
balanceReportAsHtml opts td' $ balanceReport opts fspec j
|
||||
}
|
||||
hamletToRepHtml $ pageLayout td'
|
||||
|
||||
-- | Render a balance report as HTML.
|
||||
balanceReportToHtml :: [Opt] -> TemplateData -> BalanceReport -> Html ()
|
||||
balanceReportToHtml _ td (items,total) = [$hamlet|
|
||||
%table
|
||||
balanceReportAsHtml :: [Opt] -> TemplateData -> BalanceReport -> Html ()
|
||||
balanceReportAsHtml _ td (items,total) = [$hamlet|
|
||||
%table.balancereport
|
||||
$forall items i
|
||||
^itemToHtml' i^
|
||||
%tr
|
||||
%td!colspan=2!style="border-top:1px black solid;"
|
||||
%tr.itemrule
|
||||
%td!colspan=2
|
||||
^itemAsHtml' i^
|
||||
%tr.totalrule
|
||||
%td!colspan=2
|
||||
%tr
|
||||
%td
|
||||
%td!align=right $mixedAmountToHtml.total$
|
||||
%td!align=right $mixedAmountAsHtml.total$
|
||||
|] id
|
||||
where
|
||||
itemToHtml' = itemToHtml td
|
||||
itemToHtml :: TemplateData -> BalanceReportItem -> Hamlet String
|
||||
itemToHtml TD{p=p} (a, adisplay, adepth, abal) = [$hamlet|
|
||||
%tr
|
||||
%td
|
||||
itemAsHtml' = itemAsHtml td
|
||||
itemAsHtml :: TemplateData -> BalanceReportItem -> Hamlet String
|
||||
itemAsHtml TD{p=p} (a, adisplay, adepth, abal) = [$hamlet|
|
||||
%tr.item
|
||||
%td.account
|
||||
$indent$
|
||||
%a!href=$aurl$ $adisplay$
|
||||
%td!align=right $mixedAmountToHtml.abal$
|
||||
%td.balance!align=right $mixedAmountAsHtml.abal$
|
||||
|] where
|
||||
indent = preEscapedString $ concat $ replicate (2 * adepth) " "
|
||||
aurl = printf "../register?a=^%s%s" a p' :: String
|
||||
p' = if null p then "" else printf "&p=%s" p
|
||||
|
||||
mixedAmountToHtml = intercalate ", " . lines . show
|
||||
--mixedAmountAsHtml = intercalate ", " . lines . show
|
||||
mixedAmountAsHtml = preEscapedString . intercalate "<br>" . lines . show
|
||||
|
||||
getRegisterPage :: Handler HledgerWebApp RepHtml
|
||||
getRegisterPage = do
|
||||
(a, p, opts, fspec, j, msg, here) <- getHandlerParameters
|
||||
let td' = td{here=here, title="hledger", msg=msg, a=a, p=p, content=
|
||||
registerReportAsHtml opts td' $ registerReport opts fspec j
|
||||
}
|
||||
hamletToRepHtml $ pageLayout td'
|
||||
|
||||
-- | Render a register report as HTML.
|
||||
registerReportAsHtml :: [Opt] -> TemplateData -> RegisterReport -> Html ()
|
||||
registerReportAsHtml _ td items = [$hamlet|
|
||||
%table.registerreport
|
||||
$forall items i
|
||||
%tr.itemrule
|
||||
%td!colspan=5
|
||||
^itemAsHtml' i^
|
||||
|] id
|
||||
where
|
||||
itemAsHtml' = itemAsHtml td
|
||||
itemAsHtml :: TemplateData -> RegisterReportItem -> Hamlet String
|
||||
itemAsHtml TD{p=p} (ds, posting, b) = [$hamlet|
|
||||
%tr.item
|
||||
%td.date $date$
|
||||
%td.description $desc$
|
||||
%td.account
|
||||
%a!href=$aurl$ $acct$
|
||||
%td.amount!align=right $mixedAmountAsHtml.pamount.posting$
|
||||
%td.balance!align=right $mixedAmountAsHtml.b$
|
||||
|] where
|
||||
(date, desc) = case ds of Just (da, de) -> (show da, de)
|
||||
Nothing -> ("", "")
|
||||
acct = paccount posting
|
||||
aurl = printf "../register?a=^%s%s" acct p' :: String
|
||||
p' = if null p then "" else printf "&p=%s" p
|
||||
|
||||
queryStringFromAP a p = if null ap then "" else "?" ++ ap
|
||||
where
|
||||
ap = intercalate "&" [a',p']
|
||||
a' = if null a then "" else printf "&a=%s" a
|
||||
p' = if null p then "" else printf "&p=%s" p
|
||||
|
||||
getEditPage :: Handler HledgerWebApp RepHtml
|
||||
getEditPage = do
|
||||
(a, p, _, _, _, msg, here) <- getHandlerParameters
|
||||
-- reload journal's text without parsing, if changed
|
||||
j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
|
||||
changed <- liftIO $ journalFileIsNewer j
|
||||
s <- liftIO $ if changed then readFile (filepath j) else return (jtext j) -- XXX readFile may throw an error
|
||||
let td' = td{here=here, title="hledger", msg=msg, a=a, p=p,
|
||||
content=(editform td') show, contentplain=s} -- XXX provide both to squeeze editform into pageLayout
|
||||
hamletToRepHtml $ pageLayout td'
|
||||
|
||||
postJournalPage :: Handler HledgerWebApp RepPlain
|
||||
postJournalPage = do
|
||||
|
||||
@ -109,7 +109,7 @@ tests = TestList [
|
||||
let (opts,args) `gives` es = do
|
||||
l <- samplejournalwithopts opts args
|
||||
t <- getCurrentLocalTime
|
||||
showBalanceReport opts (balanceReport opts (optsToFilterSpec opts args t) l) `is` unlines es
|
||||
balanceReportAsText opts (balanceReport opts (optsToFilterSpec opts args t) l) `is` unlines es
|
||||
in TestList
|
||||
[
|
||||
|
||||
@ -245,7 +245,7 @@ tests = TestList [
|
||||
," c:d "
|
||||
]) >>= either error return
|
||||
let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment
|
||||
showBalanceReport [] (balanceReport [] nullfilterspec j') `is`
|
||||
balanceReportAsText [] (balanceReport [] nullfilterspec j') `is`
|
||||
unlines
|
||||
[" $500 a:b"
|
||||
," $-500 c:d"
|
||||
@ -260,7 +260,7 @@ tests = TestList [
|
||||
," test:a 1"
|
||||
," test:b"
|
||||
])
|
||||
showBalanceReport [] (balanceReport [] nullfilterspec l) `is`
|
||||
balanceReportAsText [] (balanceReport [] nullfilterspec l) `is`
|
||||
unlines
|
||||
[" 1 test:a"
|
||||
," -1 test:b"
|
||||
@ -458,7 +458,7 @@ tests = TestList [
|
||||
"register report with no args" ~:
|
||||
do
|
||||
l <- samplejournal
|
||||
showRegisterReport [] (optsToFilterSpec [] [] t1) l `is` unlines
|
||||
(registerReportAsText [] $ registerReport [] (optsToFilterSpec [] [] t1) l) `is` unlines
|
||||
["2008/01/01 income assets:bank:checking $1 $1"
|
||||
," income:salary $-1 0"
|
||||
,"2008/06/01 gift assets:bank:checking $1 $1"
|
||||
@ -476,7 +476,7 @@ tests = TestList [
|
||||
do
|
||||
let opts = [Cleared]
|
||||
l <- readJournalWithOpts opts sample_journal_str
|
||||
showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
|
||||
(registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` unlines
|
||||
["2008/06/03 eat & shop expenses:food $1 $1"
|
||||
," expenses:supplies $1 $2"
|
||||
," assets:cash $-2 0"
|
||||
@ -488,7 +488,7 @@ tests = TestList [
|
||||
do
|
||||
let opts = [UnCleared]
|
||||
l <- readJournalWithOpts opts sample_journal_str
|
||||
showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
|
||||
(registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` unlines
|
||||
["2008/01/01 income assets:bank:checking $1 $1"
|
||||
," income:salary $-1 0"
|
||||
,"2008/06/01 gift assets:bank:checking $1 $1"
|
||||
@ -508,19 +508,19 @@ tests = TestList [
|
||||
," e 1"
|
||||
," f"
|
||||
]
|
||||
registerdates (showRegisterReport [] (optsToFilterSpec [] [] t1) l) `is` ["2008/01/01","2008/02/02"]
|
||||
registerdates (registerReportAsText [] $ registerReport [] (optsToFilterSpec [] [] t1) l) `is` ["2008/01/01","2008/02/02"]
|
||||
|
||||
,"register report with account pattern" ~:
|
||||
do
|
||||
l <- samplejournal
|
||||
showRegisterReport [] (optsToFilterSpec [] ["cash"] t1) l `is` unlines
|
||||
(registerReportAsText [] $ registerReport [] (optsToFilterSpec [] ["cash"] t1) l) `is` unlines
|
||||
["2008/06/03 eat & shop assets:cash $-2 $-2"
|
||||
]
|
||||
|
||||
,"register report with account pattern, case insensitive" ~:
|
||||
do
|
||||
l <- samplejournal
|
||||
showRegisterReport [] (optsToFilterSpec [] ["cAsH"] t1) l `is` unlines
|
||||
(registerReportAsText [] $ registerReport [] (optsToFilterSpec [] ["cAsH"] t1) l) `is` unlines
|
||||
["2008/06/03 eat & shop assets:cash $-2 $-2"
|
||||
]
|
||||
|
||||
@ -528,7 +528,7 @@ tests = TestList [
|
||||
do
|
||||
l <- samplejournal
|
||||
let gives displayexpr =
|
||||
(registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is`)
|
||||
(registerdates (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is`)
|
||||
where opts = [Display displayexpr]
|
||||
"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"]
|
||||
@ -541,7 +541,7 @@ tests = TestList [
|
||||
l <- samplejournal
|
||||
let periodexpr `gives` dates = do
|
||||
l' <- samplejournalwithopts opts []
|
||||
registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l') `is` dates
|
||||
registerdates (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l') `is` dates
|
||||
where opts = [Period periodexpr]
|
||||
"" `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"]
|
||||
@ -550,7 +550,7 @@ tests = TestList [
|
||||
"monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]
|
||||
"quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"]
|
||||
let opts = [Period "yearly"]
|
||||
showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
|
||||
(registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` unlines
|
||||
["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1"
|
||||
," assets:cash $-2 $-1"
|
||||
," expenses:food $1 0"
|
||||
@ -560,9 +560,9 @@ tests = TestList [
|
||||
," liabilities:debts $1 0"
|
||||
]
|
||||
let opts = [Period "quarterly"]
|
||||
registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/10/01"]
|
||||
registerdates (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/10/01"]
|
||||
let opts = [Period "quarterly",Empty]
|
||||
registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]
|
||||
registerdates (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]
|
||||
|
||||
]
|
||||
|
||||
@ -570,7 +570,7 @@ tests = TestList [
|
||||
do
|
||||
l <- samplejournal
|
||||
let opts = [Depth "2"]
|
||||
showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
|
||||
(registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` unlines
|
||||
["2008/01/01 income income:salary $-1 $-1"
|
||||
,"2008/06/01 gift income:gifts $-1 $-2"
|
||||
,"2008/06/03 eat & shop expenses:food $1 $-1"
|
||||
@ -586,7 +586,7 @@ tests = TestList [
|
||||
,"unicode in balance layout" ~: do
|
||||
l <- readJournalWithOpts []
|
||||
"2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
|
||||
showBalanceReport [] (balanceReport [] (optsToFilterSpec [] [] t1) l) `is` unlines
|
||||
balanceReportAsText [] (balanceReport [] (optsToFilterSpec [] [] t1) l) `is` unlines
|
||||
[" -100 актив:наличные"
|
||||
," 100 расходы:покупки"
|
||||
,"--------------------"
|
||||
@ -596,7 +596,7 @@ tests = TestList [
|
||||
,"unicode in register layout" ~: do
|
||||
l <- readJournalWithOpts []
|
||||
"2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
|
||||
showRegisterReport [] (optsToFilterSpec [] [] t1) l `is` unlines
|
||||
(registerReportAsText [] $ registerReport [] (optsToFilterSpec [] [] t1) l) `is` unlines
|
||||
["2009/01/01 медвежья шкура расходы:покупки 100 100"
|
||||
," актив:наличные -100 0"]
|
||||
|
||||
|
||||
@ -25,3 +25,16 @@ body { font-family: "helvetica","arial", "sans serif"; margin:0; }
|
||||
|
||||
/* for -fweb610 */
|
||||
#hledgerorglink, #helplink { float:right; margin-left:1em; }
|
||||
|
||||
/* .balancereport { font-size:small; } */
|
||||
.balancereport tr { vertical-align:top; }
|
||||
/* .itemrule td { border-top:thin solid #ddd; } */
|
||||
.totalrule td { border-top:thin solid black; }
|
||||
|
||||
.registerreport { font-size:small; }
|
||||
.registerreport tr { vertical-align:top; }
|
||||
.registerreport .date { white-space:nowrap; }
|
||||
/* .registerreport .description { font-size:small; } */
|
||||
.registerreport .account { white-space:nowrap; }
|
||||
.registerreport .amount { white-space:nowrap; }
|
||||
.registerreport .balance { white-space:nowrap; }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user