{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}

module Hledger.Web.Widget.Common
  ( accountQuery
  , accountOnlyQuery
  , balanceReportAsHtml
  , helplink
  , mixedAmountAsHtml
  , fromFormSuccess
  , writeJournalTextIfValidAndChanged
  , journalFile404
  , transactionFragment
  , removeDates
  , removeInacct
  , replaceInacct
  ) where

import Control.Monad.Except (ExceptT, mapExceptT)
import Data.Foldable (find, for_)
import Data.List (elemIndex)
import Data.Text (Text)
import qualified Data.Text as T
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

journalFile404 :: FilePath -> Journal -> HandlerFor m (FilePath, Text)
journalFile404 :: forall m. String -> Journal -> HandlerFor m (String, Text)
journalFile404 String
f Journal
j =
  case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== String
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (Journal -> [(String, Text)]
jfiles Journal
j) of
    Just (String
_, Text
txt) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String
takeFileName String
f, Text
txt)
    Maybe (String, Text)
Nothing -> forall (m :: * -> *) a. MonadHandler m => m a
notFound

fromFormSuccess :: Applicative m => m a -> FormResult a -> m a
fromFormSuccess :: forall (m :: * -> *) a. Applicative m => m a -> FormResult a -> m a
fromFormSuccess m a
h FormResult a
FormMissing = m a
h
fromFormSuccess m a
h (FormFailure [Text]
_) = m a
h
fromFormSuccess m a
_ (FormSuccess a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
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 -> ExceptT String m ()
writeJournalTextIfValidAndChanged :: forall (m :: * -> *).
MonadHandler m =>
String -> Text -> ExceptT String m ()
writeJournalTextIfValidAndChanged String
f Text
t = forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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' :: Text
t' = Text -> Text -> Text -> Text
T.replace Text
"\r" Text
"" Text
t
  Journal
j <- InputOpts -> Maybe String -> Text -> ExceptT String IO Journal
readJournal InputOpts
definputopts (forall a. a -> Maybe a
Just String
f) Text
t'
  Bool
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Journal
j seq :: forall a b. a -> b -> b
`seq` String -> Text -> IO Bool
writeFileWithBackupIfChanged String
f Text
t'  -- Only write backup if the journal didn't error
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Link to a topic in the manual.
helplink :: Text -> Text -> HtmlUrl r
helplink :: forall r. Text -> Text -> HtmlUrl r
helplink Text
topic Text
label Render r
_ = Html -> Html
H.a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
u forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.target AttributeValue
"hledgerhelp" forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
toHtml Text
label
  where u :: AttributeValue
u = Text -> AttributeValue
textValue forall a b. (a -> b) -> a -> b
$ Text
manualurl forall a. Semigroup a => a -> a -> a
<> if Text -> Bool
T.null Text
topic then Text
"" else Char -> Text -> Text
T.cons Char
'#' Text
topic

-- | Render a "BalanceReport" as html.
balanceReportAsHtml :: Eq r => (r, r) -> r -> Bool -> Journal -> Text -> [QueryOpt] -> BalanceReport -> HtmlUrl r
balanceReportAsHtml :: forall r.
Eq r =>
(r, r)
-> r
-> Bool
-> Journal
-> Text
-> [QueryOpt]
-> BalanceReport
-> HtmlUrl r
balanceReportAsHtml (r
journalR, r
registerR) r
here Bool
hideEmpty Journal
j Text
qparam [QueryOpt]
qopts ([BalanceReportItem]
items, MixedAmount
total) =
  $(hamletFile "templates/balance-report.hamlet")
  where
    l :: Ledger
l = Query -> Journal -> Ledger
ledgerFromJournal Query
Any Journal
j
    indent :: Int -> Html
indent Int
a = String -> Html
preEscapedString forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Int
2 forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* Int
a) String
"&nbsp;"
    hasSubAccounts :: Text -> Bool
hasSubAccounts Text
acct = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Account -> [Account]
asubs) (Ledger -> Text -> Maybe Account
ledgerAccount Ledger
l Text
acct)
    isInterestingAccount :: Text -> Bool
isInterestingAccount Text
acct = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Account -> Bool
isInteresting forall a b. (a -> b) -> a -> b
$ Ledger -> Text -> Maybe Account
ledgerAccount Ledger
l Text
acct
      where isInteresting :: Account -> Bool
isInteresting Account
a = Bool -> Bool
not (MixedAmount -> Bool
mixedAmountLooksZero (Account -> MixedAmount
aebalance Account
a)) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Account -> Bool
isInteresting (Account -> [Account]
asubs Account
a)
    matchesAcctSelector :: Text -> Bool
matchesAcctSelector Text
acct = forall a. a -> Maybe a
Just Bool
True forall a. Eq a => a -> a -> Bool
== ((Query -> Text -> Bool
`matchesAccount` Text
acct) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QueryOpt] -> Maybe Query
inAccountQuery [QueryOpt]
qopts)

accountQuery :: AccountName -> Text
accountQuery :: Text -> Text
accountQuery = (Text
"inacct:" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Text -> Text
quoteIfSpaced

accountOnlyQuery :: AccountName -> Text
accountOnlyQuery :: Text -> Text
accountOnlyQuery = (Text
"inacctonly:" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
quoteIfSpaced

mixedAmountAsHtml :: MixedAmount -> HtmlUrl a
mixedAmountAsHtml :: forall a. MixedAmount -> HtmlUrl a
mixedAmountAsHtml MixedAmount
b Render a
_ =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (String -> [String]
lines (Bool -> MixedAmount -> String
showMixedAmountWithoutPrice Bool
False MixedAmount
b)) forall a b. (a -> b) -> a -> b
$ \String
t -> do
    Html -> Html
H.span forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
c forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
toHtml String
t
    Html
H.br
  where
    c :: AttributeValue
c = case MixedAmount -> Maybe Bool
isNegativeMixedAmount MixedAmount
b of
      Just Bool
True -> AttributeValue
"negative amount"
      Maybe Bool
_ -> AttributeValue
"positive amount"

-- Make a slug to uniquely identify this transaction
-- in hyperlinks (as far as possible).
transactionFragment :: Journal -> Transaction -> String
transactionFragment :: Journal -> Transaction -> String
transactionFragment Journal
j Transaction{Integer
tindex :: Transaction -> Integer
tindex :: Integer
tindex, (SourcePos, SourcePos)
tsourcepos :: Transaction -> (SourcePos, SourcePos)
tsourcepos :: (SourcePos, SourcePos)
tsourcepos} = 
  forall r. PrintfType r => String -> r
printf String
"transaction-%d-%d" Int
tfileindex Integer
tindex
  where
    -- the numeric index of this txn's file within all the journal files,
    -- or 0 if this txn has no known file (eg a forecasted txn)
    tfileindex :: Int
tfileindex = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall a. Num a => a -> a -> a
+Int
1) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (SourcePos -> String
sourceName forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (SourcePos, SourcePos)
tsourcepos) (Journal -> [String]
journalFilePaths Journal
j)

removeDates :: Text -> [Text]
removeDates :: Text -> [Text]
removeDates =
    forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
quoteIfSpaced forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
term ->
        Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Text -> Bool
T.isPrefixOf Text
"date:" Text
term Bool -> Bool -> Bool
|| Text -> Text -> Bool
T.isPrefixOf Text
"date2:" Text
term) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    [Text] -> Text -> [Text]
Query.words'' [Text]
queryprefixes

removeInacct :: Text -> [Text]
removeInacct :: Text -> [Text]
removeInacct =
    forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
quoteIfSpaced forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
term ->
        Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Text -> Bool
T.isPrefixOf Text
"inacct:" Text
term Bool -> Bool -> Bool
|| Text -> Text -> Bool
T.isPrefixOf Text
"inacctonly:" Text
term) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    [Text] -> Text -> [Text]
Query.words'' [Text]
queryprefixes

replaceInacct :: Text -> Text -> Text
replaceInacct :: Text -> Text -> Text
replaceInacct Text
q Text
acct = [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ Text
acct forall a. a -> [a] -> [a]
: Text -> [Text]
removeInacct Text
q