{-# 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)
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.Settings (widgetFile)

addModal ::
     ( MonadWidget m
     , r ~ Route (HandlerSite m)
     , m ~ WidgetFor (HandlerSite m)
     , RenderMessage (HandlerSite m) FormMessage
     )
  => r -> Journal -> Day -> m ()
addModal :: r -> Journal -> Day -> m ()
addModal r
addR Journal
j Day
today = do
  (WidgetFor (HandlerSite m) ()
addView, Enctype
addEnctype) <- (Markup
 -> MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ()))
-> m (WidgetFor (HandlerSite m) (), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Markup -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost (Journal
-> Day
-> Markup
-> MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ())
forall site (m :: * -> *).
(site ~ HandlerSite m, RenderMessage site FormMessage,
 MonadHandler m) =>
Journal
-> Day
-> Markup
-> MForm m (FormResult Transaction, WidgetFor site ())
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 ::
     (site ~ HandlerSite m, RenderMessage site FormMessage, MonadHandler m)
  => Journal
  -> Day
  -> Markup
  -> MForm m (FormResult Transaction, WidgetFor site ())
addForm :: Journal
-> Day
-> Markup
-> MForm m (FormResult Transaction, WidgetFor site ())
addForm Journal
j Day
today = Text
-> (Markup
    -> MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ()))
-> Markup
-> MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ())
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" ((Markup
  -> MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ()))
 -> Markup
 -> MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ()))
-> (Markup
    -> MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ()))
-> Markup
-> MForm m (FormResult Transaction, WidgetFor (HandlerSite m) ())
forall a b. (a -> b) -> a -> b
$ \Markup
extra -> do
  (FormResult Day
dateRes, FieldView site
dateView) <- Field m Day
-> FieldSettings site
-> Maybe Day
-> MForm m (FormResult Day, FieldView site)
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 m Day
dateField FieldSettings site
forall master. FieldSettings master
dateFS Maybe Day
forall a. Maybe a
Nothing
  (FormResult Text
descRes, FieldView site
descView) <- Field m Text
-> FieldSettings site
-> Maybe Text
-> MForm m (FormResult Text, FieldView site)
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 m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField FieldSettings site
forall master. FieldSettings master
descFS Maybe Text
forall a. Maybe a
Nothing
  (FormResult [Text]
acctRes, FieldView site
_) <- Field m [Text]
-> FieldSettings site
-> Maybe [Text]
-> MForm m (FormResult [Text], FieldView site)
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 m [Text]
listField FieldSettings site
forall master. FieldSettings master
acctFS Maybe [Text]
forall a. Maybe a
Nothing
  (FormResult [Text]
amtRes, FieldView site
_) <- Field m [Text]
-> FieldSettings site
-> Maybe [Text]
-> MForm m (FormResult [Text], FieldView site)
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 m [Text]
listField FieldSettings site
forall master. FieldSettings master
amtFS Maybe [Text]
forall a. Maybe a
Nothing
  let (FormResult [Posting]
postRes, [(Int, (Text, Text, Maybe Text, Maybe Text))]
displayRows) = FormResult [Text]
-> FormResult [Text]
-> (FormResult [Posting],
    [(Int, (Text, Text, Maybe Text, Maybe Text))])
validatePostings FormResult [Text]
acctRes FormResult [Text]
amtRes

  -- bindings used in add-form.hamlet
  let descriptions :: Set Text
descriptions = ([Text] -> Set Text) -> [[Text]] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Journal -> [Text]
journalPayeesDeclaredOrUsed Journal
j, Journal -> [Text]
journalDescriptions Journal
j]
      journals :: [String]
journals = (String, Text) -> String
forall a b. (a, b) -> a
fst ((String, Text) -> String) -> [(String, Text)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Journal -> [(String, Text)]
jfiles Journal
j

  (FormResult Transaction, WidgetFor site ())
-> RWST
     (Maybe (Map Text [Text], Map Text [FileInfo]), site, [Text])
     Enctype
     Ints
     m
     (FormResult Transaction, WidgetFor site ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormResult Day
-> FormResult Text
-> FormResult [Posting]
-> FormResult Transaction
validateTransaction FormResult Day
dateRes FormResult Text
descRes FormResult [Posting]
postRes, $(widgetFile "add-form"))

  where
    dateFS :: FieldSettings master
dateFS = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"date" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date")
      [(Text
"class", Text
"form-control input-lg"), (Text
"placeholder", Text
"Date")]
    descFS :: FieldSettings master
descFS = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"desc" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"description")
      [(Text
"class", Text
"form-control input-lg typeahead"), (Text
"placeholder", Text
"Description"), (Text
"size", Text
"40")]
    acctFS :: FieldSettings master
acctFS = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"amount" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"account") []
    amtFS :: FieldSettings master
amtFS = SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings SomeMessage master
"amount" Maybe (SomeMessage master)
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"amount") []
    dateField :: Field m Day
dateField = (Text -> m (Either Text Day))
-> (Day -> Text) -> Field m Text -> Field m Day
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 (Either Text Day -> m (Either Text Day)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Day -> m (Either Text Day))
-> (Text -> Either Text Day) -> Text -> m (Either Text Day)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Day
validateDate) (String -> Text
T.pack (String -> Text) -> (Day -> String) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> String
forall a. Show a => a -> String
show) Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField
    validateDate :: Text -> Either Text Day
validateDate Text
s =
      (ParseErrorBundle Text CustomErr -> Text)
-> Either (ParseErrorBundle Text CustomErr) Day -> Either Text Day
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ParseErrorBundle Text CustomErr -> Text
forall a b. a -> b -> a
const (Text
"Invalid date format" :: Text)) (Either (ParseErrorBundle Text CustomErr) Day -> Either Text Day)
-> Either (ParseErrorBundle Text CustomErr) Day -> Either Text Day
forall a b. (a -> b) -> a -> b
$
      Day -> Text -> Either (ParseErrorBundle Text CustomErr) Day
fixSmartDateStrEither' Day
today (Text -> Text
T.strip Text
s)

    listField :: Field m [Text]
listField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
      { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
fieldParse = m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
forall a b. a -> b -> a
const (m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text])))
-> ([Text]
    -> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text])))
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (SomeMessage (HandlerSite m)) (Maybe [Text])
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (SomeMessage (HandlerSite m)) (Maybe [Text])
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text])))
-> ([Text] -> Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
-> [Text]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Text] -> Either (SomeMessage (HandlerSite m)) (Maybe [Text])
forall a b. b -> Either a b
Right (Maybe [Text]
 -> Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
-> ([Text] -> Maybe [Text])
-> [Text]
-> Either (SomeMessage (HandlerSite m)) (Maybe [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text])
-> ([Text] -> [Text]) -> [Text] -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Text -> Bool
T.null
      , fieldView :: FieldViewFunc m [Text]
fieldView = String -> FieldViewFunc m [Text]
forall a. HasCallStack => String -> a
error String
"Don't render using this!"  -- PARTIAL:
      , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
      }

    -- Used in 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 (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [
        Text
"[",
        Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (
          (Text
"{\"value\":" 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 -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}")(Text -> Text) -> (Text -> Text) -> Text -> 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
"]"
        ]
b64wrap :: Text -> Text
b64wrap :: Text -> Text
b64wrap = (Text
"atob(\""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 -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"\")") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
encodeBase64

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


-- | 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]
acctRes FormResult [Text]
amtRes = let

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

  -- 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 = ((Bool, [(Text, Text)])
 -> Maybe
      ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
       (Bool, [(Text, Text)])))
-> (Bool, [(Text, Text)])
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
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)
  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) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
 (Bool, [(Text, Text)]))
-> Maybe
     ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
      (Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
x, Text
"", Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
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
forall a b. a -> Either a b
Left Text
"Missing amount")), (Bool
True, (Text, Text)
y(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:[(Text, Text)]
xs))
  go (Bool
True, (Text
x, Text
""):[(Text, Text)]
xs) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
 (Bool, [(Text, Text)]))
-> Maybe
     ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
      (Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
x, Text
"", Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
forall a a.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
checkAccount Text
x) (Amount -> Either Text Amount
forall a b. b -> Either a b
Right Amount
missingamt)), (Bool
False, [(Text, Text)]
xs))
  go (Bool
False, (Text
x, Text
""):[(Text, Text)]
xs) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
 (Bool, [(Text, Text)]))
-> Maybe
     ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
      (Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
x, Text
"", Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
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
forall a b. a -> Either a b
Left Text
"Missing amount")), (Bool
False, [(Text, Text)]
xs))
  go (Bool
_, (Text
"", Text
y):[(Text, Text)]
xs) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
 (Bool, [(Text, Text)]))
-> Maybe
     ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
      (Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
"", Text
y, Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
forall a a.
Either a Text
-> Either a Amount -> Either (Maybe a, Maybe a) Posting
zipRow (Text -> Either Text Text
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) = ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
 (Bool, [(Text, Text)]))
-> Maybe
     ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
      (Bool, [(Text, Text)]))
forall a. a -> Maybe a
Just ((Text
x, Text
y, Either Text Text
-> Either Text Amount -> Either (Maybe Text, Maybe Text) Posting
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
_, []) = Maybe
  ((Text, Text, Either (Maybe Text, Maybe Text) Posting),
   (Bool, [(Text, Text)]))
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') = (Maybe a, Maybe a) -> Either (Maybe a, Maybe a) Posting
forall a b. a -> Either a b
Left (a -> Maybe a
forall a. a -> Maybe a
Just a
e, a -> Maybe a
forall a. a -> Maybe a
Just a
e')
  zipRow (Left a
e) (Right Amount
_) = (Maybe a, Maybe a) -> Either (Maybe a, Maybe a) Posting
forall a b. a -> Either a b
Left (a -> Maybe a
forall a. a -> Maybe a
Just a
e, Maybe a
forall a. Maybe a
Nothing)
  zipRow (Right Text
_) (Left a
e) = (Maybe a, Maybe a) -> Either (Maybe a, Maybe a) Posting
forall a b. a -> Either a b
Left (Maybe a
forall a. Maybe a
Nothing, a -> Maybe a
forall a. a -> Maybe a
Just a
e)
  zipRow (Right Text
acct') (Right Amount
amt) = Posting -> Either (Maybe a, Maybe a) Posting
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 (ParseErrorBundle Text CustomErr) c -> Either Text c
errorToFormMsg = (ParseErrorBundle Text CustomErr -> Text)
-> Either (ParseErrorBundle Text CustomErr) c -> Either Text c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"Invalid value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> (ParseErrorBundle Text CustomErr -> Text)
-> ParseErrorBundle Text CustomErr
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (ParseErrorBundle Text CustomErr -> String)
-> ParseErrorBundle Text CustomErr
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          (String -> ParseError Text CustomErr -> String)
-> String -> NonEmpty (ParseError Text CustomErr) -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String
s ParseError Text CustomErr
a -> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseError Text CustomErr -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorTextPretty ParseError Text CustomErr
a) String
"" (NonEmpty (ParseError Text CustomErr) -> String)
-> (ParseErrorBundle Text CustomErr
    -> NonEmpty (ParseError Text CustomErr))
-> ParseErrorBundle Text CustomErr
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          ParseErrorBundle Text CustomErr
-> NonEmpty (ParseError Text CustomErr)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors)
  checkAccount :: Text -> Either Text Text
checkAccount = Either (ParseErrorBundle Text CustomErr) Text -> Either Text Text
forall c.
Either (ParseErrorBundle Text CustomErr) c -> Either Text c
errorToFormMsg (Either (ParseErrorBundle Text CustomErr) Text -> Either Text Text)
-> (Text -> Either (ParseErrorBundle Text CustomErr) Text)
-> Text
-> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec CustomErr Text Text
-> String -> Text -> Either (ParseErrorBundle Text CustomErr) Text
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec CustomErr Text Text
forall (m :: * -> *). TextParser m Text
accountnamep Parsec CustomErr Text Text
-> ParsecT CustomErr Text Identity () -> Parsec CustomErr Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"" (Text -> Either (ParseErrorBundle Text CustomErr) Text)
-> (Text -> Text)
-> Text
-> Either (ParseErrorBundle Text CustomErr) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
  checkAmount :: Text -> Either Text Amount
checkAmount = Either (ParseErrorBundle Text CustomErr) Amount
-> Either Text Amount
forall c.
Either (ParseErrorBundle Text CustomErr) c -> Either Text c
errorToFormMsg (Either (ParseErrorBundle Text CustomErr) Amount
 -> Either Text Amount)
-> (Text -> Either (ParseErrorBundle Text CustomErr) Amount)
-> Text
-> Either Text Amount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec CustomErr Text Amount
-> String
-> Text
-> Either (ParseErrorBundle Text CustomErr) Amount
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (StateT Journal (ParsecT CustomErr Text Identity) Amount
-> Journal -> Parsec CustomErr Text Amount
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT Journal (ParsecT CustomErr Text Identity) Amount
forall (m :: * -> *). JournalParser m Amount
amountp StateT Journal (ParsecT CustomErr Text Identity) Amount
-> StateT Journal (ParsecT CustomErr Text Identity) ()
-> StateT Journal (ParsecT CustomErr Text Identity) Amount
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT CustomErr Text Identity) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Journal
nulljournal) String
"" (Text -> Either (ParseErrorBundle Text CustomErr) Amount)
-> (Text -> Text)
-> Text
-> Either (ParseErrorBundle Text CustomErr) Amount
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]
acctRes, FormResult [Text]
amtRes) 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
"", (Maybe Text, Maybe Text) -> Either (Maybe Text, Maybe Text) Posting
forall a b. a -> Either a b
Left (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Missing account", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Missing amount"))
           , (Text
"", Text
"", (Maybe Text, Maybe Text) -> Either (Maybe Text, Maybe Text) Posting
forall a b. a -> Either a b
Left (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Missing account", Maybe Text
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' = (((Text, Text, Either (Maybe Text, Maybe Text) Posting)
  -> (Text, Text, Maybe Text, Maybe Text))
 -> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
 -> [(Text, Text, Maybe Text, Maybe Text)])
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
-> ((Text, Text, Either (Maybe Text, Maybe Text) Posting)
    -> (Text, Text, Maybe Text, Maybe Text))
-> [(Text, Text, Maybe Text, Maybe Text)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, Text, Either (Maybe Text, Maybe Text) Posting)
 -> (Text, Text, Maybe Text, Maybe Text))
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
-> [(Text, Text, Maybe Text, Maybe Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
result (((Text, Text, Either (Maybe Text, Maybe Text) Posting)
  -> (Text, Text, Maybe Text, Maybe Text))
 -> [(Text, Text, Maybe Text, Maybe Text)])
-> ((Text, Text, Either (Maybe Text, Maybe Text) Posting)
    -> (Text, Text, Maybe Text, Maybe Text))
-> [(Text, Text, Maybe Text, Maybe Text)]
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, Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)
  display :: [(Text, Text, Maybe Text, Maybe Text)]
display = [(Text, Text, Maybe Text, Maybe Text)]
display' [(Text, Text, Maybe Text, Maybe Text)]
-> [(Text, Text, Maybe Text, Maybe Text)]
-> [(Text, Text, Maybe Text, Maybe Text)]
forall a. [a] -> [a] -> [a]
++ Int
-> (Text, Text, Maybe Text, Maybe Text)
-> [(Text, Text, Maybe Text, Maybe Text)]
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(Text, Text, Maybe Text, Maybe Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text, Maybe Text, Maybe Text)]
display') (Text
"", Text
"", Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)

  -- And finally prepare the final FormResult [Posting]
  formResult :: FormResult [Posting]
formResult = case ((Text, Text, Either (Maybe Text, Maybe Text) Posting)
 -> Either (Maybe Text, Maybe Text) Posting)
-> [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]
-> Either (Maybe Text, Maybe Text) [Posting]
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)
_ -> [Text] -> FormResult [Posting]
forall a. [Text] -> FormResult a
FormFailure [Text
"Postings validation failed"]
    Right [Posting]
xs -> [Posting] -> FormResult [Posting]
forall a. a -> FormResult a
FormSuccess [Posting]
xs

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


zipDefault :: a -> [a] -> [a] -> [(a, a)]
zipDefault :: a -> [a] -> [a] -> [(a, a)]
zipDefault a
def (a
b:[a]
bs) (a
c:[a]
cs) = (a
b, a
c)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:(a -> [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)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:(a -> [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)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:(a -> [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 :: a -> FormResult a -> a
formSuccess a
def FormResult a
res = case FormResult a
res of
  FormSuccess a
x -> a
x
  FormResult a
_ -> a
def