web: ui cleanups, replace balance/register with combo view

Hledger/Cli/Commands/Add.hs

@@ -44,7 +44,7 @@ add opts args j
 getAndAddTransactions :: Journal -> [Opt] -> [String] -> Day -> IO ()
 getAndAddTransactions j opts args defaultDate = do
   (t, d) <- getTransaction j opts args defaultDate
-  j <- journalAddTransaction j t
+  j <- journalAddTransaction j opts t
   getAndAddTransactions j opts args d
 
 -- | Read a transaction from the command line, with history-aware prompting.
@@ -134,9 +134,10 @@ askFor prompt def validator = do
 -- | Append this transaction to the journal's file. Also, to the journal's
 -- transaction list, but we don't bother updating the other fields - this
 -- is enough to include new transactions in the history matching.
-journalAddTransaction :: Journal -> Transaction -> IO Journal
-journalAddTransaction j@Journal{jtxns=ts} t = do
+journalAddTransaction :: Journal -> [Opt] -> Transaction -> IO Journal
+journalAddTransaction j@Journal{jtxns=ts} opts t = do
   appendToJournalFile j $ showTransaction t
+  when (Debug `elem` opts) $ do
     putStrLn $ printf "\nAdded transaction to %s:" (filepath j)
     putStrLn =<< registerFromString (show t)
   return j{jtxns=ts++[t]}

Hledger/Cli/Commands/Balance.hs

@@ -96,9 +96,9 @@ balance report:
 -}
 
 module Hledger.Cli.Commands.Balance (
-  balance
- ,BalanceReport
+  BalanceReport
  ,BalanceReportItem
+ ,balance
  ,balanceReport
  ,balanceReportAsText
  -- ,tests_Balance

Hledger/Cli/Commands/Print.hs

@@ -5,8 +5,13 @@ A ledger-compatible @print@ command.
 
 -}
 
-module Hledger.Cli.Commands.Print
-where
+module Hledger.Cli.Commands.Print (
+  JournalReport
+ ,JournalReportItem
+ ,print'
+ ,journalReport
+ ,showTransactions
+) where
 import Hledger.Data
 import Hledger.Cli.Options
 #if __GLASGOW_HASKELL__ <= 610
@@ -15,6 +20,12 @@ import System.IO.UTF8
 #endif
 
 
+-- | A "journal report" is just a list of transactions.
+type JournalReport = [JournalReportItem]
+
+-- | The data for a single journal report item, representing one transaction.
+type JournalReportItem = Transaction
+
 -- | Print journal transactions in standard format.
 print' :: [Opt] -> [String] -> Journal -> IO ()
 print' opts args j = do
@@ -22,8 +33,11 @@ print' opts args j = do
   putStr $ showTransactions (optsToFilterSpec opts args t) j
 
 showTransactions :: FilterSpec -> Journal -> String
-showTransactions filterspec j =
-    concatMap (showTransactionForPrint effective) $ sortBy (comparing tdate) txns
-        where
-          effective = EffectiveDate == whichdate filterspec
-          txns = jtxns $ filterJournalTransactions filterspec j
+showTransactions fspec j = journalReportAsText [] fspec $ journalReport [] fspec j
+
+journalReportAsText :: [Opt] -> FilterSpec -> JournalReport -> String -- XXX unlike the others, this one needs fspec not opts
+journalReportAsText _ fspec items = concatMap (showTransactionForPrint effective) items
+    where effective = EffectiveDate == whichdate fspec
+
+journalReport :: [Opt] -> FilterSpec -> Journal -> JournalReport
+journalReport _ fspec j = sortBy (comparing tdate) $ jtxns $ filterJournalTransactions fspec j

Hledger/Cli/Commands/Register.hs

@@ -6,9 +6,9 @@ A ledger-compatible @register@ command.
 -}
 
 module Hledger.Cli.Commands.Register (
-  register
- ,RegisterReport
+  RegisterReport
  ,RegisterReportItem
+ ,register
  ,registerReport
  ,registerReportAsText
  ,showPostingWithBalanceForVty

Hledger/Cli/Commands/Web.hs

@@ -19,6 +19,7 @@ import Hledger.Cli.Commands.Print
 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.Read (journalFromPathAndString)
 import Hledger.Read.Journal (someamount)
@@ -47,14 +48,17 @@ data HledgerWebApp = HledgerWebApp {
 mkYesod "HledgerWebApp" [$parseRoutes|
 /             IndexPage        GET
 /journal      JournalPage      GET POST
-/edit         EditPage         GET POST
 /register     RegisterPage     GET
 /balance      BalancePage      GET
+/ledger       LedgerPage       GET
 /style.css    StyleCss         GET
 |]
 
 instance Yesod HledgerWebApp where approot = appRoot
 
+-- defaultroute = LedgerPage
+defaultroute = JournalPage
+
 -- | A bundle of useful data passed to templates.
 data TemplateData = TD {
      here         :: HledgerWebAppRoute -- ^ the current page's route
@@ -62,18 +66,14 @@ data TemplateData = TD {
     ,msg          :: Maybe (Html ())     -- ^ transient message
     ,a            :: String             -- ^ a (filter pattern) parameter
     ,p            :: String             -- ^ p (period expression) parameter
-    ,content      :: Html ()             -- ^ html for the content area
-    ,contentplain :: String             -- ^ or plain text content
     }
 
-td = TD {
+mktd = TD {
       here = IndexPage
      ,title = "hledger"
      ,msg = Nothing
      ,a = ""
      ,p = ""
-     ,content = nulltemplate id
-     ,contentplain = ""
      }
 
 -- | The web command.
@@ -104,9 +104,10 @@ server baseurl port opts args j = do
               }
     withStore "hledger" $ do
      putValue "hledger" "journal" j
-     basicHandler port app
+     basicHandler' port Nothing app
 
--- handlers
+----------------------------------------------------------------------
+-- handlers & templates
 
 getStyleCss :: Handler HledgerWebApp ()
 getStyleCss = do
@@ -115,158 +116,107 @@ getStyleCss = do
     sendFile "text/css" $ dir </> "style.css"
 
 getIndexPage :: Handler HledgerWebApp ()
-getIndexPage = redirect RedirectTemporary BalancePage
+getIndexPage = redirect RedirectTemporary defaultroute
 
--- | 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'
+----------------------------------------------------------------------
 
+-- | A basic journal view, like hledger print, with editing.
 getJournalPage :: Handler HledgerWebApp RepHtml
 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'
-
-getBalancePage :: Handler HledgerWebApp RepHtml
-getBalancePage = do
   (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'
+  let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p}
+      editform' = editform td $ jtext j
+      txns = journalReportAsHtml opts td $ journalReport opts fspec j
+  hamletToRepHtml $ pageLayout td [$hamlet|
+%div.journal
+ ^journalScripts^
+ %div.nav2
+  %a#addformlink!href!onclick="return addformToggle()" add one transaction
+  \ | $
+  %a#editformlink!href!onclick="return editformToggle()" edit the whole journal
+ ^addform^
+ ^editform'^
+ #transactions ^txns^
+|]
 
--- | Render a balance report as HTML.
-balanceReportAsHtml :: [Opt] -> TemplateData -> BalanceReport -> Html ()
-balanceReportAsHtml _ td (items,total) = [$hamlet|
-%table.balancereport
- $forall items i
-  %tr.itemrule
-   %td!colspan=2
+-- | Render a journal report as HTML.
+journalReportAsHtml :: [Opt] -> TemplateData -> JournalReport -> Hamlet HledgerWebAppRoute
+journalReportAsHtml _ td items = [$hamlet|
+%table.journalreport
+ $forall number.items i
   ^itemAsHtml' i^
- %tr.totalrule
-  %td!colspan=2
- %tr
-  %td
-  %td!align=right $mixedAmountAsHtml.total$
-|] id
+|]
  where
+   number = zip [1..]
    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.balance!align=right $mixedAmountAsHtml.abal$
+   itemAsHtml :: TemplateData -> (Int, JournalReportItem) -> Hamlet HledgerWebAppRoute
+   itemAsHtml _ (n, t) = [$hamlet|
+     %tr.item.$evenodd$
+      %td.transaction
+       %pre $txn$
      |] where
-       indent = preEscapedString $ concat $ replicate (2 * adepth) "&nbsp;"
-       aurl = printf "../register?a=^%s%s" a p' :: String
-       p' = if null p then "" else printf "&p=%s" p
+       evenodd = if even n then "even" else "odd"
+       txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse
 
---mixedAmountAsHtml = intercalate ", " . lines . show
-mixedAmountAsHtml = preEscapedString . intercalate "<br>" . lines . show
+journalScripts = [$hamlet|
+<script type="text/javascript">
 
-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
+ function addformToggle() {
+  a = document.getElementById('addform');
+  e = document.getElementById('editform');
+  t = document.getElementById('transactions');
+  alink = document.getElementById('addformlink');
+  elink = document.getElementById('editformlink');
+  if (a.style.display == 'none') {
+   alink.style['font-weight'] = 'bold';
+   elink.style['font-weight'] = 'normal';
+   a.style.display = 'block';
+   e.style.display = 'none';
+   t.style.display = 'block';
+  } else {
+   alink.style['font-weight'] = 'normal';
+   elink.style['font-weight'] = 'normal';
+   a.style.display = 'none';
+   e.style.display = 'none';
+   t.style.display = 'block';
+  }
+  return false;
  }
-  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
+ function editformToggle() {
+  a = document.getElementById('addform');
+  e = document.getElementById('editform');
+  t = document.getElementById('transactions');
+  alink = document.getElementById('addformlink');
+  elink = document.getElementById('editformlink');
+  if (e.style.display == 'none') {
+   alink.style['font-weight'] = 'normal';
+   elink.style['font-weight'] = 'bold';
+   a.style.display = 'none';
+   e.style.display = 'block';
+   t.style.display = 'none';
+  } else {
+   alink.style['font-weight'] = 'normal';
+   elink.style['font-weight'] = 'normal';
+   a.style.display = 'none';
+   e.style.display = 'none';
+   t.style.display = 'block';
+  }
+  return false;
+ }
 
-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'
+</script>
+|]
 
 postJournalPage :: Handler HledgerWebApp RepPlain
 postJournalPage = do
+  edit <- runFormPost' $ maybeStringInput "edit"
+  if isJust edit then postEditForm else postAddForm
+
+-- | Handle a journal add form post.
+postAddForm :: Handler HledgerWebApp RepPlain
+postAddForm = do
+  (_, _, opts, _, _, _, _) <- getHandlerParameters
   today <- liftIO getCurrentDay
   -- get form input values. M means a Maybe value.
   (dateM, descM, acct1M, amt1M, acct2M, amt2M) <- runFormPost'
@@ -315,12 +265,13 @@ postJournalPage = do
    Right t -> do
     let t' = txnTieKnot t -- XXX move into balanceTransaction
     j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
-    liftIO $ journalAddTransaction j t'
+    liftIO $ journalAddTransaction j opts t'
     setMessage $ string $ printf "Added transaction:\n%s" (show t')
     redirect RedirectTemporary JournalPage
 
-postEditPage :: Handler HledgerWebApp RepPlain
-postEditPage = do
+-- | Handle a journal edit form post.
+postEditForm :: Handler HledgerWebApp RepPlain
+postEditForm = do
   -- get form input values, or basic validation errors. E means an Either value.
   textM  <- runFormPost' $ maybeStringInput "text"
   let textE = maybe (Left "No value provided") Right textM
@@ -343,134 +294,23 @@ postEditPage = do
     if not changed
      then do
        setMessage $ string $ "No change"
-       redirect RedirectTemporary EditPage
+       redirect RedirectTemporary JournalPage
      else do
       jE <- liftIO $ journalFromPathAndString Nothing f tnew
       either
        (\e -> do
           setMessage $ string e
-          redirect RedirectTemporary EditPage)
+          redirect RedirectTemporary JournalPage)
        (const $ do
           liftIO $ writeFileWithBackup f tnew
           setMessage $ string $ printf "Saved journal %s\n" (show f)
           redirect RedirectTemporary JournalPage)
        jE
 
--- templates
-
-nulltemplate = [$hamlet||]
-
-stringToPre :: String -> Html ()
-stringToPre s = [$hamlet|%pre $s$|] id
-
-pageLayout :: TemplateData -> Hamlet HledgerWebAppRoute
-pageLayout td@TD{here=here, title=title, msg=msg, content=content} = [$hamlet|
-!!!
-%html
- %head
-  %title $title$
-  %meta!http-equiv=Content-Type!content=$metacontent$
-  %link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
- %body
-  ^navbar.td^
-  #messages $m$
-  ^addform'.here^
-  #content
-   $content$
-|]
- where m = fromMaybe (string "") msg
-       addform' JournalPage = addform
-       addform' _           = nulltemplate
-       stylesheet = StyleCss
-       metacontent = "text/html; charset=utf-8"
-
-navbar :: TemplateData -> Hamlet HledgerWebAppRoute
-navbar td = [$hamlet|
- #navbar
-  %a.toprightlink!href=$hledgerurl$ hledger.org
-  \ $
-  %a.toprightlink!href=$manualurl$ manual
-  \ $
-  ^navlinks.td^
-  ^searchform.td^
-|]
-
-navlinks :: TemplateData -> Hamlet HledgerWebAppRoute
-navlinks TD{here=here,a=a,p=p} = [$hamlet|
- #navlinks
-  ^journallink^ $
-  (^editlink^) $
-  | ^balancelink^ $
-  | ^registerlink^ $
-|]
- where
-  journallink = navlink here "journal" JournalPage
-  editlink = navlink here "edit" EditPage
-  registerlink = navlink here "register" RegisterPage
-  balancelink = navlink here "balance" BalancePage
-  navlink here s dest = [$hamlet|%a.$style$!href=@?u@ $s$|]
-   where u = (dest, concat [(if null a then [] else [("a", a)])
-                           ,(if null p then [] else [("p", p)])])
-         style | here == dest = "navlinkcurrent"
-               | otherwise    = "navlink"
-
-searchform :: TemplateData -> Hamlet HledgerWebAppRoute
-searchform TD{here=here,a=a,p=p} = [$hamlet|
- %form#searchform!method=GET
-  ^resetlink^ $
-  %span!style=white-space:nowrap;
-   filter by: $
-   %input!name=a!size=30!value=$a$
-   ^ahelp^ $
-   in period: $
-   %input!name=p!size=30!value=$p$
-   ^phelp^ $
-   %input!type=submit!value=filter
-|]
- where
-  ahelp = helplink "filter-patterns" "?"
-  phelp = helplink "period-expressions" "?"
-  resetlink
-   | null a && null p = nulltemplate
-   | otherwise        = [$hamlet|%span#resetlink!style=font-weight:bold; $
-                                  %a!href=@here@ stop filtering|]
-
-helplink topic label = [$hamlet|%a!href=$u$ $label$|]
-    where u = manualurl ++ if null topic then "" else '#':topic
-
-editform :: TemplateData -> Hamlet HledgerWebAppRoute
-editform TD{contentplain=t} = [$hamlet|
- %form!method=POST
-  %table.form#editform!cellpadding=0!cellspacing=0!border=0
-   %tr.formheading
-    %td!colspan=2
-     %span!style=float:right; ^formhelp^
-     %span#formheading Edit journal:
-   %tr
-    %td!colspan=2
-     %textarea!name=text!rows=30!cols=80
-      $t$
-   %tr#addbuttonrow
-    %td
-     %a!href=@JournalPage@ cancel
-    %td!align=right
-     %input!type=submit!value=$submitlabel$
-   %tr.helprow
-    %td
-    %td!align=right
-     #help Are you sure ? All previous data will be replaced
-|]
- where
-  submitlabel = "save journal"
-  formhelp = helplink "file-format" "file format help"
-
 addform :: Hamlet HledgerWebAppRoute
 addform = [$hamlet|
- %form!method=POST
-  %table.form#addform!cellpadding=0!cellspacing=0!border=0
-   %tr.formheading
-    %td!colspan=4
-     %span#formheading Add a transaction:
+ %form#addform!method=POST!style=display:none;
+  %table.form!cellpadding=0!cellspacing=0!border=0
    %tr
     %td!colspan=4
      %table!cellpadding=0!cellspacing=0!border=0
@@ -486,21 +326,21 @@ addform = [$hamlet|
       %tr.helprow
        %td
        %td
-        #help $datehelp$ ^datehelplink^ $
+        .help $datehelp$ ^datehelplink^ $
        %td
        %td
-        #help $deschelp$
+        .help $deschelp$
    ^transactionfields1^
    ^transactionfields2^
    %tr#addbuttonrow
     %td!colspan=4
-     %input!type=submit!value=$addlabel$
+     %input!type=hidden!name=add!value=1
+     %input!type=submit!name=submit!value="add transaction"
 |]
  where
   datehelplink = helplink "dates" "..."
   datehelp = "eg: 7/20, 2010/1/1, "
   deschelp = "eg: supermarket (optional)"
-  addlabel = "add transaction"
   date = "today"
   desc = ""
   transactionfields1 = transactionfields 1
@@ -517,10 +357,10 @@ transactionfields n = [$hamlet|
  %tr.helprow
   %td
   %td
-   #help $accthelp$
+   .help $accthelp$
   %td
   %td
-   #help $amthelp$
+   .help $amthelp$
 |]
  where
   label | n == 1    = "To account"
@@ -542,3 +382,255 @@ transactionfields n = [$hamlet|
   acctvar = numbered "accountname"
   amtvar = numbered "amount"
 
+editform :: TemplateData -> String -> Hamlet HledgerWebAppRoute
+editform _ content = [$hamlet|
+ %form#editform!method=POST!style=display:none;
+  %table.form#editform!cellpadding=0!cellspacing=0!border=0
+   %tr
+    %td!colspan=2
+     %textarea!name=text!rows=30!cols=80
+      $content$
+   %tr#addbuttonrow
+    %td
+     %span.help ^formathelp^
+    %td!align=right
+     %span.help Are you sure ? Your journal will be overwritten. $
+     %input!type=hidden!name=edit!value=1
+     %input!type=submit!name=submit!value="save journal"
+     \ or $
+     %a!href!onclick="return editformToggle()" cancel
+|]
+  where
+    formathelp = helplink "file-format" "file format help"
+
+----------------------------------------------------------------------
+
+-- | A combined accounts and postings view, like hledger balance + hledger register.
+getLedgerPage :: Handler HledgerWebApp RepHtml
+getLedgerPage = do
+  (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
+  -- in this view, balance report is filtered only by period, not account/description filters
+  app <- getYesod
+  t <- liftIO $ getCurrentLocalTime
+  let args = appArgs app
+      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}
+  hamletToRepHtml $ pageLayout td [$hamlet|
+%div.ledger
+ %div.accounts!style=float:left;  ^br^
+ %div.register ^rr^
+|]
+
+----------------------------------------------------------------------
+
+-- | An accounts and balances view, like hledger balance.
+getBalancePage :: Handler HledgerWebApp RepHtml
+getBalancePage = do
+  (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
+  let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p}
+  hamletToRepHtml $ pageLayout td $ balanceReportAsHtml opts td $ balanceReport opts fspec j
+
+-- | Render a balance report as HTML.
+balanceReportAsHtml :: [Opt] -> TemplateData -> BalanceReport -> Hamlet HledgerWebAppRoute
+balanceReportAsHtml _ td (items,total) = [$hamlet|
+%table.balancereport
+ $forall items i
+  ^itemAsHtml' i^
+ %tr.totalrule
+  %td!colspan=2
+ %tr
+  %td
+  %td!align=right $mixedAmountAsHtml.total$
+|]
+ where
+   itemAsHtml' = itemAsHtml td
+   itemAsHtml :: TemplateData -> BalanceReportItem -> Hamlet HledgerWebAppRoute
+   itemAsHtml TD{a=a,p=p} (acct, adisplay, adepth, abal) = [$hamlet|
+     %tr.item.$current$
+      %td.account
+       $indent$
+       %a!href=$aurl$ $adisplay$
+      %td.balance!align=right $mixedAmountAsHtml.abal$
+     |] where
+       current = if not (null a) && containsRegex a acct then "current" else ""
+       indent = preEscapedString $ concat $ replicate (2 * adepth) "&nbsp;"
+       aurl = printf "../ledger?a=^%s%s" acct p' :: String
+       p' = if null p then "" else printf "&p=%s" p
+
+----------------------------------------------------------------------
+
+-- | A postings view, like hledger register.
+getRegisterPage :: Handler HledgerWebApp RepHtml
+getRegisterPage = do
+  (a, p, opts, fspec, j, msg, here) <- getHandlerParameters
+  let td = mktd{here=here, title="hledger", msg=msg, a=a, p=p}
+  hamletToRepHtml $ pageLayout td $ registerReportAsHtml opts td $ registerReport opts fspec j
+
+-- | Render a register report as HTML.
+registerReportAsHtml :: [Opt] -> TemplateData -> RegisterReport -> Hamlet HledgerWebAppRoute
+registerReportAsHtml _ td items = [$hamlet|
+%table.registerreport
+ $forall number.items i
+  ^itemAsHtml' i^
+|]
+ where
+   number = zip [1..]
+   itemAsHtml' = itemAsHtml td
+   itemAsHtml :: TemplateData -> (Int, RegisterReportItem) -> Hamlet HledgerWebAppRoute
+   itemAsHtml TD{p=p} (n, (ds, posting, b)) = [$hamlet|
+     %tr.item.$evenodd$.$firstposting$
+      %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
+       evenodd = if even n then "even" else "odd"
+       (firstposting, date, desc) = case ds of Just (da, de) -> ("firstposting", show da, de)
+                                               Nothing -> ("", "", "")
+       acct = paccount posting
+       aurl = printf "../ledger?a=^%s%s" acct p' :: String
+       p' = if null p then "" else printf "&p=%s" p
+
+--mixedAmountAsHtml = intercalate ", " . lines . show
+mixedAmountAsHtml = preEscapedString . intercalate "<br>" . lines . show
+
+----------------------------------------------------------------------
+
+-- | A standalone journal edit form page.
+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 = mktd{here=here, title="hledger", msg=msg, a=a, p=p}
+  hamletToRepHtml $ pageLayout td $ editform td s
+
+----------------------------------------------------------------------
+
+-- | 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
+
+pageLayout :: TemplateData -> Hamlet HledgerWebAppRoute -> Hamlet HledgerWebAppRoute
+pageLayout td@TD{title=title, msg=msg} content = [$hamlet|
+!!!
+%html
+ %head
+  %title $title$
+  %meta!http-equiv=Content-Type!content=$metacontent$
+  %link!rel=stylesheet!type=text/css!href=@StyleCss@!media=all
+ %body
+  ^navbar.td^
+  #messages $m$
+  #content
+   ^content^
+|]
+ where m = fromMaybe (string "") msg
+       metacontent = "text/html; charset=utf-8"
+
+navbar :: TemplateData -> Hamlet HledgerWebAppRoute
+navbar td = [$hamlet|
+ #navbar
+  %a.toprightlink!href=$hledgerurl$ hledger $version$
+  \ $
+  %a.toprightlink!href=$manualurl$ manual
+  \ $
+  ^navlinks.td^
+  ^filterform.td^
+|]
+
+navlinks :: TemplateData -> Hamlet HledgerWebAppRoute
+navlinks td = [$hamlet|
+ #navlinks
+  ^journallink^ $
+  | ^ledgerlink^ $
+|]
+ where
+  journallink  = navlink td "journal" JournalPage
+  ledgerlink   = navlink td "ledger" LedgerPage
+  -- | ^balancelink^ $
+  -- | ^registerlink^ $
+  -- balancelink  = navlink td "balance" BalancePage
+  -- registerlink = navlink td "register" RegisterPage
+
+navlink :: TemplateData -> String -> HledgerWebAppRoute -> Hamlet HledgerWebAppRoute
+navlink TD{here=here,a=a,p=p} s dest = [$hamlet|%a.$style$!href=@?u@ $s$|]
+ where u = (dest, concat [(if null a then [] else [("a", a)])
+                         ,(if null p then [] else [("p", p)])])
+       style | dest == here = "navlinkcurrent"
+             | otherwise    = "navlink"
+
+filterform :: TemplateData -> Hamlet HledgerWebAppRoute
+filterform TD{here=here,a=a,p=p} = [$hamlet|
+ %form#filterform.$filtering$!method=GET
+  %span!style=white-space:nowrap;
+   ^filterformlabel^ $
+   %input!name=a!size=30!value=$a$
+   ^ahelp^ $
+   in period: $
+   %input!name=p!size=30!value=$p$
+   ^phelp^ $
+   %input!type=submit!value=filter
+|]
+ where
+  ahelp = helplink "filter-patterns" "?"
+  phelp = helplink "period-expressions" "?"
+  (filtering, filterformlabel)
+   | null a && null p = ("", [$hamlet|filter by: $|])
+   | otherwise        = ("filtering", [$hamlet|
+%a#stopfilterlink!href=@here@ stop filtering
+\ $
+by $
+|])
+
+helplink :: String -> String -> Hamlet HledgerWebAppRoute
+helplink topic label = [$hamlet|%a!href=$u$!target=hledgerhelp $label$|]
+    where u = manualurl ++ if null topic then "" else '#':topic
+
+nulltemplate = [$hamlet||]
+

data/web/style.css

@@ -1,12 +1,19 @@
 /* hledger web ui stylesheet */
 
-body { font-family: "helvetica","arial", "sans serif"; margin:0; }
-#navbar { background-color:#eeeeee; border-bottom:2px solid #dddddd; padding:4px 4px 6px 4px; }
+/* font families */
+body { font-family:helvetica,arial,"sans serif"; }
+/* pre { font-family:monospace,courier,"courier new"; } */
+#editform textarea { font-family:courier,"courier new",monospace; }
+
+body { margin:0; }
+#navbar { /* background-color:#eeeeee; */ /* border-bottom:2px solid #dddddd; */ padding:4px 4px 6px 4px; }
 #navlinks { display:inline; }
 .navlink { }
 .navlinkcurrent { font-weight:bold; }
-#searchform { font-size:small; display:inline; margin-left:1em; }
-#resetlink { font-size:small; }
+.nav2 { font-size:small; }
+#filterform { font-size:small; display:inline; margin-left:1em; }
+.filtering { background-color:#eee; font-weight:bold; }
+#stopfilterlink { font-size:small; }
 .toprightlink { font-size:small; margin-left:1em; float:right; }
 #messages { color:red; background-color:#ffeeee; margin:0.5em;}
 .form { margin:1em; font-size:small; }
@@ -16,25 +23,50 @@ body { font-family: "helvetica","arial", "sans serif"; margin:0; }
 #addform #postingrow { }
 #addform #addbuttonrow { text-align:right; }
 #editform { width:95%; }
-#editform textarea { background-color:#eeeeee; font-family:monospace; font-size:medium; width:100%; }
+#editform textarea { /* background-color:#eeeeee; */ width:100%; }
 #content { margin:1em; }
 .formheading td { padding-bottom:8px; }
 #formheading { font-size:medium; font-weight:bold; }
 .helprow td { padding-bottom:8px; }
-#help {font-style: italic; font-size:smaller; }
+.help {font-style: italic; font-size:smaller; }
 
 /* for -fweb610 */
-#hledgerorglink, #helplink { float:right; margin-left:1em; }
+/* #hledgerorglink, #helplink { float:right; margin-left:1em; } */
 
-/* .balancereport { font-size:small; } */
+.current { font-weight:bold; background-color:#eee; }
+.description { padding-left:1em; }
+.account { white-space:nowrap; padding-left:1em; }
+.amount { white-space:nowrap; padding-left:1em; }
+.balance { white-space:nowrap; padding-left:1em; }
+ /* don't let fields get too small in emptyish reports */
+.description { width:4em; }
+.account, .amount, .balance { width:2em; }
+/* .odd { background-color:#e8e8e8; } */
+/* .even { background-color:#e8f8e8; } */
+/* .even { background-color:#f0fff0; } */
+
+.journalreport { font-size:small; }
+table.journalreport { margin-top:1em; }
+.journalreport td { border-top:thin solid #ddd; }
+.journalreport pre { margin-top:0; }
+
+.ledger .accounts {padding-right:1em; margin-right:1em; border-right:thin solid #ddd;}
+.ledger .register {}
+
+.balancereport { font-size:small; }
 .balancereport tr { vertical-align:top; }
+table.balancereport { border-spacing:0; }
+.ledger .balancereport td { padding:0; }
 /* .itemrule td { border-top:thin solid #ddd; } */
 .totalrule td { border-top:thin solid black; }
 
+table.registerreport { border-spacing:0; }
 .registerreport { font-size:small; }
 .registerreport tr { vertical-align:top; }
+.registerreport td { padding-bottom:0.2em; }
+/* .registerreport td { margin-left:0em; margin-right:0; } */
 .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; }
+/* .firstposting { background-color:#eee; } */
+.registerreport .even { background-color:#f0f0f0; }
+

hledger-lib/Hledger/Read.hs

@@ -104,7 +104,7 @@ ensureJournalFile f = do
 emptyJournal :: IO String
 emptyJournal = do
   d <- getCurrentDay
-  return $ printf "; journal created %s; see http://hledger.org/MANUAL.html#journal-file\n\n" (show d)
+  return $ printf "; journal created %s by hledger\n\n" (show d)
 
 -- | Read a Journal from this string, using the specified data format or
 -- trying all known formats, or give an error string.