diff --git a/Hledger/Cli/Commands/Web.hs b/Hledger/Cli/Commands/Web.hs index 3e3e3e8a6..90d573c6d 100644 --- a/Hledger/Cli/Commands/Web.hs +++ b/Hledger/Cli/Commands/Web.hs @@ -20,7 +20,7 @@ import Hledger.Cli.Commands.Register import Hledger.Cli.Options hiding (value) import Hledger.Cli.Utils import Hledger.Cli.Version (version) -import Hledger.Data +import Hledger.Data hiding (today) import Hledger.Read (journalFromPathAndString) import Hledger.Read.Journal (someamount) #ifdef MAKE @@ -67,6 +67,7 @@ data TemplateData = TD { ,a :: String -- ^ a (acct/desc filter pattern) parameter ,p :: String -- ^ p (period expression) parameter ,j :: Journal -- ^ the current journal + ,today :: Day -- ^ the current day } mktd = TD { @@ -76,6 +77,7 @@ mktd = TD { ,a = "" ,p = "" ,j = nulljournal + ,today = ModifiedJulianDay 0 } -- | The web command. @@ -171,13 +173,14 @@ getIndexPage = redirect RedirectTemporary defaultpage getAccountsJournalPage :: Handler HledgerWebApp RepHtml getAccountsJournalPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters + today <- liftIO getCurrentDay -- app <- getYesod -- t <- liftIO $ getCurrentLocalTime let -- args = appArgs app -- fspec' = optsToFilterSpec opts args t br = balanceReportAsHtml opts td $ balanceReport opts fspec j jr = journalReportAsHtml opts td $ journalReport opts fspec j - td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} + td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j, today=today} editform' = editform td $ jtext j hamletToRepHtml $ pageLayout td [$hamlet| ^scripts^ @@ -201,6 +204,7 @@ postAccountsJournalPage = postJournalOnlyPage getAccountsRegisterPage :: Handler HledgerWebApp RepHtml getAccountsRegisterPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters + today <- liftIO getCurrentDay -- app <- getYesod -- t <- liftIO $ getCurrentLocalTime let -- args = appArgs app @@ -208,7 +212,7 @@ getAccountsRegisterPage = do -- fspec' = optsToFilterSpec opts' args t br = balanceReportAsHtml opts td $ balanceReport opts fspec j rr = registerReportAsHtml opts td $ registerReport opts fspec j - td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} + td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j, today=today} editform' = editform td $ jtext j hamletToRepHtml $ pageLayout td [$hamlet| ^scripts^ @@ -232,7 +236,8 @@ postAccountsRegisterPage = postJournalOnlyPage getAccountsPage :: Handler HledgerWebApp RepHtml getAccountsPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters - let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} + today <- liftIO getCurrentDay + let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j, today=today} hamletToRepHtml $ pageLayout td $ balanceReportAsHtml opts td $ balanceReport opts fspec j -- | Render a balance report as HTML. @@ -312,7 +317,8 @@ isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:(" getJournalOnlyPage :: Handler HledgerWebApp RepHtml getJournalOnlyPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters - let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} + today <- liftIO getCurrentDay + let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j, today=today} editform' = editform td $ jtext j txns = journalReportAsHtml opts td $ journalReport opts fspec j hamletToRepHtml $ pageLayout td [$hamlet| @@ -714,7 +720,8 @@ postImportForm = do getRegisterOnlyPage :: Handler HledgerWebApp RepHtml getRegisterOnlyPage = do (a, p, opts, fspec, j, msg, here) <- getHandlerParameters - let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} + today <- liftIO getCurrentDay + let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j, today=today} hamletToRepHtml $ pageLayout td $ registerReportAsHtml opts td $ registerReport opts fspec j -- | Render a register report as HTML. @@ -755,11 +762,12 @@ mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "
" $ lines $ getEditPage :: Handler HledgerWebApp RepHtml getEditPage = do (a, p, _, _, _, msg, here) <- getHandlerParameters + today <- liftIO getCurrentDay -- reload journal's text without parsing, if changed -- XXX are we doing this right ? 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 = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j} + let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p, j=j, today=today} hamletToRepHtml $ pageLayout td $ editform td s ---------------------------------------------------------------------- @@ -783,7 +791,7 @@ pageLayout td@TD{title=title, msg=msg} content = [$hamlet| metacontent = "text/html; charset=utf-8" navbar :: TemplateData -> Hamlet HledgerWebAppRoute -navbar TD{j=j} = [$hamlet| +navbar TD{p=p,j=j,today=today} = [$hamlet| #navbar %a.topleftlink!href=$hledgerurl$ hledger @@ -791,8 +799,15 @@ navbar TD{j=j} = [$hamlet| $version$ %a.toprightlink!href=$manualurl$!target=hledgerhelp manual %h1 $journaltitle$ + \ $ + %span#journalinfo $journalinfo$ |] - where journaltitle = printf "%s" (takeFileName $ filepath j) :: String + where + journaltitle = printf "%s" (takeFileName $ filepath j) :: String + journalinfo = printf "%s" (showspan span) :: String + showspan (DateSpan Nothing Nothing) = "" + showspan s = " (showing " ++ dateSpanAsText s ++ ")" + span = either (const $ DateSpan Nothing Nothing) snd (parsePeriodExpr today p) navlinks :: TemplateData -> Hamlet HledgerWebAppRoute navlinks td = [$hamlet| diff --git a/Hledger/Cli/Options.hs b/Hledger/Cli/Options.hs index d427fd180..a1e055efa 100644 --- a/Hledger/Cli/Options.hs +++ b/Hledger/Cli/Options.hs @@ -200,7 +200,9 @@ fixOptDates opts = do -- others are ignored. dateSpanFromOpts :: Day -> [Opt] -> DateSpan dateSpanFromOpts refdate opts - | not $ null popts = snd $ parsePeriodExpr refdate $ last popts + | not (null popts) = case parsePeriodExpr refdate $ last popts of + Right (_, s) -> s + Left e -> parseerror e | otherwise = DateSpan lastb laste where popts = optValuesForConstructor Period opts @@ -216,7 +218,9 @@ dateSpanFromOpts refdate opts intervalFromOpts :: [Opt] -> Interval intervalFromOpts opts = case (periodopts, intervalopts) of - ((p:_), _) -> fst $ parsePeriodExpr d p where d = parsedate "0001/01/01" -- unused + ((p:_), _) -> case parsePeriodExpr (parsedate "0001/01/01") p of + Right (i, _) -> i + Left e -> parseerror e (_, (DailyOpt:_)) -> Daily (_, (WeeklyOpt:_)) -> Weekly (_, (MonthlyOpt:_)) -> Monthly diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index 54cb8f15c..25e06983f 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -86,10 +86,16 @@ orDatesFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b b = if isJust b1 then b1 else b2 -- | Parse a period expression to an Interval and overall DateSpan using --- the provided reference date, or raise an error. -parsePeriodExpr :: Day -> String -> (Interval, DateSpan) -parsePeriodExpr refdate expr = (interval,span) - where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr +-- the provided reference date, or return a parse error. +parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan) +parsePeriodExpr refdate = parsewith (periodexpr refdate) + +-- | Show a DateSpan as a human-readable pseudo-period-expression string. +dateSpanAsText :: DateSpan -> String +dateSpanAsText (DateSpan Nothing Nothing) = "all" +dateSpanAsText (DateSpan Nothing (Just e)) = printf "to %s" (show e) +dateSpanAsText (DateSpan (Just b) Nothing) = printf "from %s" (show b) +dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e) -- | Convert a single smart date string to a date span using the provided -- reference date, or raise an error.