{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Hledger.Web.Widget.AddForm
  ( addForm
  , addModal
  ) where

import Control.Monad.State.Strict (evalStateT)
import Data.Bifunctor (first)
import Data.Foldable (toList)
import Data.List (dropWhileEnd, unfoldr)
import Data.Maybe (isJust, fromMaybe)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text.Encoding.Base64 (encodeBase64)
import qualified Data.Text as T
import Data.Time (Day)
import Text.Blaze.Internal (Markup, preEscapedText)
import Text.Megaparsec (bundleErrors, eof, parseErrorTextPretty, runParser)
import Yesod

import Hledger
import Hledger.Web.Foundation (App, Handler, Widget)
import Hledger.Web.Settings (widgetFile)
import Data.Function ((&))
import Control.Arrow (right)

addModal :: Route App -> Journal -> Day -> Widget
addModal :: Route App -> Journal -> Day -> WidgetFor App ()
addModal Route App
addR Journal
j Day
today = do
  (WidgetFor App ()
addView, Enctype
addEnctype) <- forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Markup -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost (Journal
-> Day
-> Markup
-> MForm
     (HandlerFor App)
     (FormResult (Transaction, FilePath), WidgetFor App ())
addForm Journal
j Day
today)
  [whamlet|
<div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true">
  <div .modal-dialog .modal-lg>
    <div .modal-content>
      <div .modal-header>
        <button type="button" .close data-dismiss="modal" aria-hidden="true">&times;
        <h3 .modal-title #addLabel>Add a transaction
      <div .modal-body>
        <form#addform.form action=@{addR} method=POST enctype=#{addEnctype}>
          ^{addView}
|]

addForm :: Journal -> Day -> Markup -> MForm Handler (FormResult (Transaction,FilePath), Widget)
addForm :: Journal
-> Day
-> Markup
-> MForm
     (HandlerFor App)
     (FormResult (Transaction, FilePath), WidgetFor App ())
addForm Journal
j Day
today = forall (m :: * -> *) a.
Monad m =>
Text
-> (Markup -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> Markup
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
identifyForm Text
"add" forall a b. (a -> b) -> a -> b
$ \Markup
extra -> do
  let  -- bindings used in add-form.hamlet
    descriptions :: Set Text
descriptions = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Ord a => [a] -> Set a
S.fromList [Journal -> [Text]
journalPayeesDeclaredOrUsed Journal
j, Journal -> [Text]
journalDescriptions Journal
j]
    files :: [FilePath]
files = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Journal -> [(FilePath, Text)]
jfiles Journal
j
    deffile :: FilePath
deffile = Journal -> FilePath
journalFilePath Journal
j
  (FormResult Day
dateRes, FieldView (HandlerSite (HandlerFor App))
dateView) <- forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (HandlerFor App) Day
dateField forall {master}. FieldSettings master
dateSettings forall a. Maybe a
Nothing
  (FormResult (Maybe Text)
descRes, FieldView (HandlerSite (HandlerFor App))
descView) <- forall site (m :: * -> *) a.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField forall {master}. FieldSettings master
descSettings forall a. Maybe a
Nothing
  (FormResult [Text]
acctsRes, FieldView (HandlerSite (HandlerFor App))
_)       <- forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (HandlerFor App) [Text]
listField forall {master}. FieldSettings master
acctSettings forall a. Maybe a
Nothing
  (FormResult [Text]
amtsRes, FieldView App
_)        <- forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (HandlerFor App) [Text]
listField forall {master}. FieldSettings master
amtSettings  forall a. Maybe a
Nothing
  (FormResult (Maybe FilePath)
fileRes, FieldView App
fileView) <- forall site (m :: * -> *) a.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt Field (HandlerFor App) FilePath
fileField' forall {master}. FieldSettings master
fileSettings forall a. Maybe a
Nothing
  let
    (FormResult [Posting]
postingsRes, [(Int, (Text, Text, Maybe Text, Maybe Text))]
displayRows) = FormResult [Text]
-> FormResult [Text]
-> (FormResult [Posting],
    [(Int, (Text, Text, Maybe Text, Maybe Text))])
validatePostings FormResult [Text]
acctsRes FormResult [Text]
amtsRes
    formRes :: FormResult (Transaction, FilePath)
formRes = FilePath
-> FormResult Day
-> FormResult (Maybe Text)
-> FormResult [Posting]
-> FormResult (Maybe FilePath)
-> FormResult (Transaction, FilePath)
validateTransaction FilePath
deffile FormResult Day
dateRes FormResult (Maybe Text)
descRes FormResult [Posting]
postingsRes FormResult (Maybe FilePath)
fileRes
  forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult (Transaction, FilePath)
formRes, $(widgetFile "add-form"))
  where
    -- custom fields
    dateField :: Field (HandlerFor App) Day
dateField = forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) msg a b.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> m (Either msg b)) -> (b -> a) -> Field m a -> Field m b
checkMMap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right EFDay -> Day
fromEFDay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text EFDay
validateDate) (FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show)
      where
        validateDate :: Text -> Either Text EFDay
validateDate Text
s =
          forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. a -> b -> a
const (Text
"Invalid date format" :: Text)) forall a b. (a -> b) -> a -> b
$
          Day -> Text -> Either HledgerParseErrors EFDay
fixSmartDateStrEither' Day
today (Text -> Text
T.strip Text
s)
    listField :: Field (HandlerFor App) [Text]
listField = Field
      { fieldParse :: [Text]
-> [FileInfo]
-> Handler
     (Either
        (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
fieldParse = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Text -> Bool
T.null
      , fieldView :: FieldViewFunc (HandlerFor App) [Text]
fieldView = forall a. FilePath -> a
error' FilePath
"listField should not be used for rendering"  -- PARTIAL:
      , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
      }
    fileField' :: Field Handler FilePath
    fileField' :: Field (HandlerFor App) FilePath
fileField' = forall a site msg.
(Eq a, RenderMessage site FormMessage, RenderMessage site msg) =>
[(msg, a)] -> Field (HandlerFor site) a
selectFieldList [(FilePath -> Text
T.pack FilePath
f, FilePath
f) | FilePath
f <- [FilePath]
fs] forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) msg a.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> Either msg a) -> Field m a -> Field m a
check FilePath -> Either FormMessage FilePath
validateFilepath
      where
        fs :: [FilePath]
fs = Journal -> [FilePath]
journalFilePaths Journal
j
        validateFilepath :: FilePath -> Either FormMessage FilePath
        validateFilepath :: FilePath -> Either FormMessage FilePath
validateFilepath FilePath
f
          | FilePath
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
fs = forall a b. b -> Either a b
Right FilePath
f
          | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInputNotFound forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
f
    -- field settings
    dateSettings :: FieldSettings master
dateSettings = forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"date" forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
"date") [(Text
"class", Text
"form-control input-lg"), (Text
"placeholder", Text
"Date")]
    descSettings :: FieldSettings master
descSettings = forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"desc" forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
"description") [(Text
"class", Text
"form-control input-lg typeahead"), (Text
"placeholder", Text
"Description"), (Text
"size", Text
"40")]
    acctSettings :: FieldSettings master
acctSettings = forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"account" forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
"account") []
    amtSettings :: FieldSettings master
amtSettings  = forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"amount" forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
"amount") []
    fileSettings :: FieldSettings master
fileSettings = forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"file" forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
"file") [(Text
"class", Text
"form-control input-lg")]

validateTransaction ::
     FilePath -> FormResult Day -> FormResult (Maybe Text) -> FormResult [Posting] -> FormResult (Maybe FilePath)
  -> FormResult (Transaction, FilePath)
validateTransaction :: FilePath
-> FormResult Day
-> FormResult (Maybe Text)
-> FormResult [Posting]
-> FormResult (Maybe FilePath)
-> FormResult (Transaction, FilePath)
validateTransaction FilePath
deffile FormResult Day
dateRes FormResult (Maybe Text)
descRes FormResult [Posting]
postingsRes FormResult (Maybe FilePath)
fileRes =
  case Day
-> Maybe Text
-> [Posting]
-> Maybe FilePath
-> (Transaction, FilePath)
makeTransaction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormResult Day
dateRes forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult (Maybe Text)
descRes forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult [Posting]
postingsRes forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult (Maybe FilePath)
fileRes of
    FormSuccess (Transaction
txn,FilePath
f) -> case BalancingOpts -> Transaction -> Either FilePath Transaction
balanceTransaction BalancingOpts
defbalancingopts Transaction
txn of
      Left FilePath
e     -> forall a. [Text] -> FormResult a
FormFailure [FilePath -> Text
T.pack FilePath
e]
      Right Transaction
txn' -> forall a. a -> FormResult a
FormSuccess (Transaction
txn',FilePath
f)
    FormResult (Transaction, FilePath)
x -> FormResult (Transaction, FilePath)
x
  where
    makeTransaction :: Day
-> Maybe Text
-> [Posting]
-> Maybe FilePath
-> (Transaction, FilePath)
makeTransaction Day
date Maybe Text
mdesc [Posting]
postings Maybe FilePath
mfile =
      (Transaction
nulltransaction {
         tdate :: Day
tdate = Day
date
        ,tdescription :: Text
tdescription = forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mdesc
        ,tpostings :: [Posting]
tpostings = [Posting]
postings
        ,tsourcepos :: (SourcePos, SourcePos)
tsourcepos = (FilePath -> SourcePos
initialPos FilePath
f, FilePath -> SourcePos
initialPos FilePath
f)
        }, FilePath
f)
      where f :: FilePath
f = forall a. a -> Maybe a -> a
fromMaybe FilePath
deffile Maybe FilePath
mfile

-- | Parse a list of postings out of a list of accounts and a corresponding list
-- of amounts
validatePostings ::
     FormResult [Text] -> FormResult [Text]
  -> (FormResult [Posting], [(Int, (Text, Text, Maybe Text, Maybe Text))])
validatePostings :: FormResult [Text]
-> FormResult [Text]
-> (FormResult [Posting],
    [(Int, (Text, Text, Maybe Text, Maybe Text))])
validatePostings FormResult [Text]
acctsRes FormResult [Text]
amtsRes = let

  -- Zip accounts and amounts, fill in missing values and drop empty rows.
  rows :: [(Text, Text)]
  rows :: [(Text, Text)]
rows = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= (Text
"", Text
"")) forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault Text
"" (forall a. a -> FormResult a -> a
formSuccess [] FormResult [Text]
acctsRes) (forall a. a -> FormResult a -> a
formSuccess [] FormResult [Text]
amtsRes)

  -- Parse values and check for incomplete rows with only an account or an amount.
  -- The boolean in unfoldr state is for special handling of 'missingamt', where
  -- one row may have only an account and not an amount.
  postings :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
  postings :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
postings = forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (Bool, [(Text, Text)])
-> Maybe
     ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
      (Bool, [(Text, Text)]))
go (Bool
True, [(Text, Text)]
rows)
    where
      go :: (Bool, [(Text, Text)])
-> Maybe
     ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
      (Bool, [(Text, Text)]))
go (Bool
True, (Text
x, Text
""):(Text, Text)
y:[(Text, Text)]
xs) = forall a. a -> Maybe a
Just ((Text
x, Text
"", forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (forall a b. a -> Either a b
Left Text
"Missing amount")), (Bool
True, (Text, Text)
yforall a. a -> [a] -> [a]
:[(Text, Text)]
xs))
      go (Bool
True, (Text
x, Text
""):[(Text, Text)]
xs) = forall a. a -> Maybe a
Just ((Text
x, Text
"", forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (forall a b. b -> Either a b
Right Amount
missingamt)), (Bool
False, [(Text, Text)]
xs))
      go (Bool
False, (Text
x, Text
""):[(Text, Text)]
xs) = forall a. a -> Maybe a
Just ((Text
x, Text
"", forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (forall a b. a -> Either a b
Left Text
"Missing amount")), (Bool
False, [(Text, Text)]
xs))
      go (Bool
_, (Text
"", Text
y):[(Text, Text)]
xs) = forall a. a -> Maybe a
Just ((Text
"", Text
y, forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (forall a b. a -> Either a b
Left Text
"Missing account") (Text -> Either Text Amount
checkAmount Text
y)), (Bool
False, [(Text, Text)]
xs))
      go (Bool
_, (Text
x, Text
y):[(Text, Text)]
xs) = forall a. a -> Maybe a
Just ((Text
x, Text
y, forall {a} {a}.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (Text -> Either Text Amount
checkAmount Text
y)), (Bool
True, [(Text, Text)]
xs))
      go (Bool
_, []) = forall a. Maybe a
Nothing

  zipRow :: Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Left a
e) (Left a
e') = forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just a
e, forall a. a -> Maybe a
Just a
e')
  zipRow (Left a
e) (Right Amount
_) = forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just a
e, forall a. Maybe a
Nothing)
  zipRow (Right Text
_) (Left a
e) = forall a b. a -> Either a b
Left (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just a
e)
  zipRow (Right Text
acct') (Right Amount
amt) = forall a b. b -> Either a b
Right (Posting
nullposting {paccount :: Text
paccount = Text
acct, ptype :: PostingType
ptype = PostingType
atype, pamount :: MixedAmount
pamount = Amount -> MixedAmount
mixedAmount Amount
amt})
    where
      acct :: Text
acct = Text -> Text
accountNameWithoutPostingType Text
acct'
      atype :: PostingType
atype = Text -> PostingType
accountNamePostingType Text
acct'

  errorToFormMsg :: Either HledgerParseErrors c -> Either Text c
errorToFormMsg = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"Invalid value: " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\FilePath
s ParseError Text HledgerParseErrorData
a -> FilePath
s forall a. Semigroup a => a -> a -> a
<> forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> FilePath
parseErrorTextPretty ParseError Text HledgerParseErrorData
a) FilePath
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors)
  checkAccount :: Text -> Either Text Text
checkAccount = forall {c}. Either HledgerParseErrors c -> Either Text c
errorToFormMsg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (forall (m :: * -> *). TextParser m Text
accountnamep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) FilePath
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
  checkAmount :: Text -> Either Text Amount
checkAmount = forall {c}. Either HledgerParseErrors c -> Either Text c
errorToFormMsg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (m :: * -> *). JournalParser m Amount
amountp forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Journal
nulljournal) FilePath
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

  -- Add errors to forms with zero rows if the form is not a FormMissing
  result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
  result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
result = case (FormResult [Text]
acctsRes, FormResult [Text]
amtsRes) of
    (FormResult [Text]
FormMissing, FormResult [Text]
FormMissing) -> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
postings
    (FormResult [Text], FormResult [Text])
_ -> case [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
postings of
      [] -> [ (Text
"", Text
"", forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just Text
"Missing account", forall a. a -> Maybe a
Just Text
"Missing amount"))
           , (Text
"", Text
"", forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just Text
"Missing account", forall a. Maybe a
Nothing))
           ]
      [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
xs -> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
xs

  -- Prepare rows for rendering - resolve Eithers into error messages and pad to
  -- at least four rows
  display' :: [(Text, Text, Maybe Text, Maybe Text)]
display' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
result forall a b. (a -> b) -> a -> b
$ \(Text
acc, Text
amt, Either (Maybe Text, Maybe Text) Posting
res) -> case Either (Maybe Text, Maybe Text) Posting
res of
    Left (Maybe Text
mAccountErr, Maybe Text
mAmountErr) -> (Text
acc, Text
amt, Maybe Text
mAccountErr, Maybe Text
mAmountErr)
    Right Posting
_ -> (Text
acc, Text
amt, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
  display :: [(Text, Text, Maybe Text, Maybe Text)]
display = [(Text, Text, Maybe Text, Maybe Text)]
display' forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
4 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text, Maybe Text, Maybe Text)]
display') (Text
"", Text
"", forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)

  -- And finally prepare the final FormResult [Posting]
  formResult :: FormResult [Posting]
formResult = case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Text
_, Text
_, Either (Maybe Text, Maybe Text) Posting
x) -> Either (Maybe Text, Maybe Text) Posting
x) [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
result of
    Left (Maybe Text, Maybe Text)
_ -> forall a. [Text] -> FormResult a
FormFailure [Text
"Postings validation failed"]
    Right [Posting]
xs -> forall a. a -> FormResult a
FormSuccess [Posting]
xs

  in (FormResult [Posting]
formResult, forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1 :: Int)..] [(Text, Text, Maybe Text, Maybe Text)]
display)

-- helper for add-form.hamlet
toBloodhoundJson :: [Text] -> Markup
toBloodhoundJson :: [Text] -> Markup
toBloodhoundJson [Text]
ts =
  -- This used to work, but since 1.16, it seems like something changed.
  -- toJSON ("a"::Text) gives String "a" instead of "a", etc.
  -- preEscapedString . escapeJSSpecialChars . show . toJSON

  Text -> Markup
preEscapedText forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [
    Text
"[",
    Text -> [Text] -> Text
T.intercalate Text
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (
      (Text
"{\"value\":" forall a. Semigroup a => a -> a -> a
<>)forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (forall a. Semigroup a => a -> a -> a
<> Text
"}")forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      -- This will convert a value such as ``hledger!`` into
      -- ``atob("aGxlZGdlciE=")``. When this gets evaluated on the client,
      -- the resulting string is ``hledger!`` again. The same data is
      -- passed, but the user-controlled bit of that string can only use
      -- characters [a-zA-Z0-9+=/], making it impossible to break out of
      -- string context.
      Text -> Text
b64wrap
      ) [Text]
ts,
    Text
"]"
    ]
  where
    -- decodeBase64EncodedText is defined in add-form.hamlet
    b64wrap :: Text -> Text
b64wrap = (Text
"decodeBase64EncodedText(\""forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<>Text
"\")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
encodeBase64

zipDefault :: a -> [a] -> [a] -> [(a, a)]
zipDefault :: forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault a
def (a
b:[a]
bs) (a
c:[a]
cs) = (a
b, a
c)forall a. a -> [a] -> [a]
:(forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault a
def [a]
bs [a]
cs)
zipDefault a
def (a
b:[a]
bs) [] = (a
b, a
def)forall a. a -> [a] -> [a]
:(forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault a
def [a]
bs [])
zipDefault a
def [] (a
c:[a]
cs) = (a
def, a
c)forall a. a -> [a] -> [a]
:(forall a. a -> [a] -> [a] -> [(a, a)]
zipDefault a
def [] [a]
cs)
zipDefault a
_ [a]
_ [a]
_ = []

formSuccess :: a -> FormResult a -> a
formSuccess :: forall a. a -> FormResult a -> a
formSuccess a
def FormResult a
res = case FormResult a
res of
  FormSuccess a
x -> a
x
  FormResult a
_ -> a
def