44c3eb1904
This is an API change, but it seems better than having additional colour-supporting variants and trying to avoid duplicated code. I stopped short of changing showAmount, so cshowAmount still exists.
129 lines
4.5 KiB
Haskell
129 lines
4.5 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Hledger.Web.Widget.Common
|
|
( accountQuery
|
|
, accountOnlyQuery
|
|
, balanceReportAsHtml
|
|
, helplink
|
|
, mixedAmountAsHtml
|
|
, fromFormSuccess
|
|
, writeJournalTextIfValidAndChanged
|
|
, journalFile404
|
|
, transactionFragment
|
|
, removeInacct
|
|
, replaceInacct
|
|
) where
|
|
|
|
import Data.Default (def)
|
|
import Data.Foldable (find, for_)
|
|
#if !(MIN_VERSION_base(4,13,0))
|
|
import Data.Semigroup ((<>))
|
|
#endif
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import System.FilePath (takeFileName)
|
|
import Text.Blaze ((!), textValue)
|
|
import qualified Text.Blaze.Html5 as H
|
|
import qualified Text.Blaze.Html5.Attributes as A
|
|
import Text.Blaze.Internal (preEscapedString)
|
|
import Text.Hamlet (hamletFile)
|
|
import Text.Printf (printf)
|
|
import Yesod
|
|
|
|
import Hledger
|
|
import Hledger.Cli.Utils (writeFileWithBackupIfChanged)
|
|
import Hledger.Web.Settings (manualurl)
|
|
import qualified Hledger.Query as Query
|
|
|
|
#if MIN_VERSION_yesod(1,6,0)
|
|
journalFile404 :: FilePath -> Journal -> HandlerFor m (FilePath, Text)
|
|
#else
|
|
journalFile404 :: FilePath -> Journal -> HandlerT m IO (FilePath, Text)
|
|
#endif
|
|
journalFile404 f j =
|
|
case find ((== f) . fst) (jfiles j) of
|
|
Just (_, txt) -> pure (takeFileName f, txt)
|
|
Nothing -> notFound
|
|
|
|
fromFormSuccess :: Applicative m => m a -> FormResult a -> m a
|
|
fromFormSuccess h FormMissing = h
|
|
fromFormSuccess h (FormFailure _) = h
|
|
fromFormSuccess _ (FormSuccess a) = pure a
|
|
|
|
-- | A helper for postEditR/postUploadR: check that the given text
|
|
-- parses as a Journal, and if so, write it to the given file, if the
|
|
-- text has changed. Or, return any error message encountered.
|
|
--
|
|
-- As a convenience for data received from web forms, which does not
|
|
-- have normalised line endings, line endings will be normalised (to \n)
|
|
-- before parsing.
|
|
--
|
|
-- The file will be written (if changed) with the current system's native
|
|
-- line endings (see writeFileWithBackupIfChanged).
|
|
--
|
|
writeJournalTextIfValidAndChanged :: MonadHandler m => FilePath -> Text -> m (Either String ())
|
|
writeJournalTextIfValidAndChanged f t = do
|
|
-- Ensure unix line endings, since both readJournal (cf
|
|
-- formatdirectivep, #1194) writeFileWithBackupIfChanged require them.
|
|
-- XXX klunky. Any equivalent of "hSetNewlineMode h universalNewlineMode" for form posts ?
|
|
let t' = T.pack $ regexReplace "\r" "" $ T.unpack t
|
|
liftIO (readJournal def (Just f) t') >>= \case
|
|
Left e -> return (Left e)
|
|
Right _ -> do
|
|
_ <- liftIO (writeFileWithBackupIfChanged f t')
|
|
return (Right ())
|
|
|
|
-- | Link to a topic in the manual.
|
|
helplink :: Text -> Text -> HtmlUrl r
|
|
helplink topic label _ = H.a ! A.href u ! A.target "hledgerhelp" $ toHtml label
|
|
where u = textValue $ manualurl <> if T.null topic then "" else T.cons '#' topic
|
|
|
|
-- | Render a "BalanceReport" as html.
|
|
balanceReportAsHtml :: Eq r => (r, r) -> r -> Bool -> Journal -> Text -> [QueryOpt] -> BalanceReport -> HtmlUrl r
|
|
balanceReportAsHtml (journalR, registerR) here hideEmpty j q qopts (items, total) =
|
|
$(hamletFile "templates/balance-report.hamlet")
|
|
where
|
|
l = ledgerFromJournal Any j
|
|
indent a = preEscapedString $ concat $ replicate (2 + 2 * a) " "
|
|
hasSubAccounts acct = maybe True (not . null . asubs) (ledgerAccount l acct)
|
|
matchesAcctSelector acct = Just True == ((`matchesAccount` acct) <$> inAccountQuery qopts)
|
|
|
|
accountQuery :: AccountName -> Text
|
|
accountQuery = ("inacct:" <>) . quoteIfSpaced
|
|
|
|
accountOnlyQuery :: AccountName -> Text
|
|
accountOnlyQuery = ("inacctonly:" <>) . quoteIfSpaced
|
|
|
|
mixedAmountAsHtml :: MixedAmount -> HtmlUrl a
|
|
mixedAmountAsHtml b _ =
|
|
for_ (lines (showMixedAmountWithoutPrice False b)) $ \t -> do
|
|
H.span ! A.class_ c $ toHtml t
|
|
H.br
|
|
where
|
|
c = case isNegativeMixedAmount b of
|
|
Just True -> "negative amount"
|
|
_ -> "positive amount"
|
|
|
|
transactionFragment :: Journal -> Transaction -> String
|
|
transactionFragment j =
|
|
let hm = HashMap.fromList $ zip (map fst $ jfiles j) [(1::Integer) ..]
|
|
in \t ->
|
|
printf "transaction-%d-%d"
|
|
(hm HashMap.! sourceFilePath (tsourcepos t)) (tindex t)
|
|
|
|
removeInacct :: Text -> [Text]
|
|
removeInacct =
|
|
map quoteIfSpaced .
|
|
filter (\term ->
|
|
not $ T.isPrefixOf "inacct:" term || T.isPrefixOf "inacctonly:" term) .
|
|
Query.words'' Query.prefixes
|
|
|
|
replaceInacct :: Text -> Text -> Text
|
|
replaceInacct q acct = T.unwords $ acct : removeInacct q
|