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

fromFormSuccess :: Applicative m => m a -> FormResult a -> m a
fromFormSuccess :: 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) = a -> m 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 -> m (Either String ())
writeJournalTextIfValidAndChanged :: FilePath -> Text -> m (Either FilePath ())
writeJournalTextIfValidAndChanged FilePath
f Text
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' :: Text
t' = Text -> Text -> Text -> Text
T.replace Text
"\r" Text
"" Text
t
  IO (Either FilePath Journal) -> m (Either FilePath Journal)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (InputOpts -> Maybe FilePath -> Text -> IO (Either FilePath Journal)
readJournal InputOpts
definputopts (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
f) Text
t') m (Either FilePath Journal)
-> (Either FilePath Journal -> m (Either FilePath ()))
-> m (Either FilePath ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left FilePath
e -> Either FilePath () -> m (Either FilePath ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left FilePath
e)
    Right Journal
_ -> do
      Bool
_ <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> Text -> IO Bool
writeFileWithBackupIfChanged FilePath
f Text
t')
      Either FilePath () -> m (Either FilePath ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either FilePath ()
forall a b. b -> Either a b
Right ())

-- | Link to a topic in the manual.
helplink :: Text -> Text -> HtmlUrl r
helplink :: Text -> Text -> HtmlUrl r
helplink Text
topic Text
label Render r
_ = Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
u (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.target AttributeValue
"hledgerhelp" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml Text
label
  where u :: AttributeValue
u = Text -> AttributeValue
textValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Text
manualurl Text -> Text -> Text
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 :: (r, r)
-> r
-> Bool
-> Journal
-> Text
-> [QueryOpt]
-> BalanceReport
-> HtmlUrl r
balanceReportAsHtml (r
journalR, r
registerR) r
here Bool
hideEmpty Journal
j Text
q [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 = FilePath -> Html
preEscapedString (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> [FilePath]
forall a. Int -> a -> [a]
replicate (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
a) FilePath
"&nbsp;"
    hasSubAccounts :: Text -> Bool
hasSubAccounts Text
acct = Bool -> (Account -> Bool) -> Maybe Account -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (Account -> Bool) -> Account -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Account] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Account] -> Bool) -> (Account -> [Account]) -> Account -> Bool
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 = Bool -> (Account -> Bool) -> Maybe Account -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Account -> Bool
isInteresting (Maybe Account -> Bool) -> Maybe Account -> Bool
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
|| (Account -> Bool) -> [Account] -> 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 = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ((Query -> Text -> Bool
`matchesAccount` Text
acct) (Query -> Bool) -> Maybe Query -> Maybe Bool
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:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Text -> Text
quoteIfSpaced

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

mixedAmountAsHtml :: MixedAmount -> HtmlUrl a
mixedAmountAsHtml :: MixedAmount -> HtmlUrl a
mixedAmountAsHtml MixedAmount
b Render a
_ =
  [FilePath] -> (FilePath -> Html) -> Html
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (FilePath -> [FilePath]
lines (Bool -> MixedAmount -> FilePath
showMixedAmountWithoutPrice Bool
False MixedAmount
b)) ((FilePath -> Html) -> Html) -> (FilePath -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \FilePath
t -> do
    Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
c (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
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 -> FilePath
transactionFragment Journal
j Transaction{Integer
tindex :: Transaction -> Integer
tindex :: Integer
tindex, (SourcePos, SourcePos)
tsourcepos :: Transaction -> (SourcePos, SourcePos)
tsourcepos :: (SourcePos, SourcePos)
tsourcepos} = 
  FilePath -> Int -> Integer -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"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 = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (SourcePos -> FilePath
sourceName (SourcePos -> FilePath) -> SourcePos -> FilePath
forall a b. (a -> b) -> a -> b
$ (SourcePos, SourcePos) -> SourcePos
forall a b. (a, b) -> a
fst (SourcePos, SourcePos)
tsourcepos) (Journal -> [FilePath]
journalFilePaths Journal
j)

removeDates :: Text -> [Text]
removeDates :: Text -> [Text]
removeDates =
    (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
quoteIfSpaced ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
term ->
        Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
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) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    [Text] -> Text -> [Text]
Query.words'' [Text]
Query.prefixes

removeInacct :: Text -> [Text]
removeInacct :: Text -> [Text]
removeInacct =
    (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
quoteIfSpaced ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
term ->
        Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
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) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    [Text] -> Text -> [Text]
Query.words'' [Text]
Query.prefixes

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