{-# 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.App (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) <- HandlerFor App (WidgetFor App (), Enctype)
-> WidgetFor App (WidgetFor App (), Enctype)
forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget (HandlerFor App (WidgetFor App (), Enctype)
 -> WidgetFor App (WidgetFor App (), Enctype))
-> HandlerFor App (WidgetFor App (), Enctype)
-> WidgetFor App (WidgetFor App (), Enctype)
forall a b. (a -> b) -> a -> b
$ (Markup
 -> MForm
      (HandlerFor App)
      (FormResult (Transaction, FilePath), WidgetFor App ()))
-> HandlerFor App (WidgetFor App (), 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
     (HandlerFor App)
     (FormResult (Transaction, FilePath), WidgetFor App ())
addForm Journal
j Day
today)
  WidgetFor App ()
[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 = Text
-> (Markup
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
         Enctype
         Ints
         (HandlerFor App)
         (FormResult (Transaction, FilePath),
          WidgetFor (HandlerSite (HandlerFor App)) ()))
-> Markup
-> RWST
     (Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
     Enctype
     Ints
     (HandlerFor App)
     (FormResult (Transaction, FilePath),
      WidgetFor (HandlerSite (HandlerFor App)) ())
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
  -> RWST
       (Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
       Enctype
       Ints
       (HandlerFor App)
       (FormResult (Transaction, FilePath),
        WidgetFor (HandlerSite (HandlerFor App)) ()))
 -> Markup
 -> RWST
      (Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
      Enctype
      Ints
      (HandlerFor App)
      (FormResult (Transaction, FilePath),
       WidgetFor (HandlerSite (HandlerFor App)) ()))
-> (Markup
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
         Enctype
         Ints
         (HandlerFor App)
         (FormResult (Transaction, FilePath),
          WidgetFor (HandlerSite (HandlerFor App)) ()))
-> Markup
-> RWST
     (Maybe (Env, FileEnv), HandlerSite (HandlerFor App), [Text])
     Enctype
     Ints
     (HandlerFor App)
     (FormResult (Transaction, FilePath),
      WidgetFor (HandlerSite (HandlerFor App)) ())
forall a b. (a -> b) -> a -> b
$ \Markup
extra -> do
  let  -- bindings used in add-form.hamlet
    descriptions :: Set Text
descriptions = ([Text] -> Set Text) -> [[Text]] -> Set Text
forall m a. Monoid m => (a -> m) -> [a] -> m
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]
    files :: [FilePath]
files = (FilePath, Text) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, Text) -> FilePath) -> [(FilePath, Text)] -> [FilePath]
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) <- Field (HandlerFor App) Day
-> FieldSettings (HandlerSite (HandlerFor App))
-> Maybe Day
-> MForm
     (HandlerFor App)
     (FormResult Day, 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) Day
dateField FieldSettings (HandlerSite (HandlerFor App))
forall {master}. FieldSettings master
dateSettings Maybe Day
forall a. Maybe a
Nothing
  (FormResult (Maybe Text)
descRes, FieldView (HandlerSite (HandlerFor App))
descView) <- Field (HandlerFor App) Text
-> FieldSettings (HandlerSite (HandlerFor App))
-> Maybe (Maybe Text)
-> MForm
     (HandlerFor App)
     (FormResult (Maybe Text), FieldView (HandlerSite (HandlerFor App)))
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) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField FieldSettings (HandlerSite (HandlerFor App))
forall {master}. FieldSettings master
descSettings Maybe (Maybe Text)
forall a. Maybe a
Nothing
  (FormResult [Text]
acctsRes, FieldView (HandlerSite (HandlerFor App))
_)       <- Field (HandlerFor App) [Text]
-> FieldSettings (HandlerSite (HandlerFor App))
-> Maybe [Text]
-> MForm
     (HandlerFor App)
     (FormResult [Text], 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 FieldSettings (HandlerSite (HandlerFor App))
forall {master}. FieldSettings master
acctSettings Maybe [Text]
forall a. Maybe a
Nothing
  (FormResult [Text]
amtsRes, FieldView App
_)        <- Field (HandlerFor App) [Text]
-> FieldSettings App
-> Maybe [Text]
-> MForm (HandlerFor App) (FormResult [Text], 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 FieldSettings App
forall {master}. FieldSettings master
amtSettings  Maybe [Text]
forall a. Maybe a
Nothing
  (FormResult (Maybe FilePath)
fileRes, FieldView App
fileView) <- Field (HandlerFor App) FilePath
-> FieldSettings App
-> Maybe (Maybe FilePath)
-> MForm
     (HandlerFor App) (FormResult (Maybe FilePath), FieldView App)
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' FieldSettings App
forall {master}. FieldSettings master
fileSettings Maybe (Maybe FilePath)
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
  (FormResult (Transaction, FilePath), WidgetFor App ())
-> RWST
     (Maybe (Env, FileEnv), App, [Text])
     Enctype
     Ints
     (HandlerFor App)
     (FormResult (Transaction, FilePath), WidgetFor App ())
forall a.
a
-> RWST
     (Maybe (Env, FileEnv), App, [Text]) Enctype Ints (HandlerFor App) a
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 = Field (HandlerFor App) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Field (HandlerFor App) Text
-> (Field (HandlerFor App) Text -> Field (HandlerFor App) Day)
-> Field (HandlerFor App) Day
forall a b. a -> (a -> b) -> b
& (Text -> Handler (Either Text Day))
-> (Day -> Text)
-> Field (HandlerFor App) Text
-> Field (HandlerFor App) 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 -> Handler (Either Text Day)
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Day -> Handler (Either Text Day))
-> (Text -> Either Text Day) -> Text -> Handler (Either Text Day)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EFDay -> Day) -> Either Text EFDay -> Either Text Day
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right EFDay -> Day
fromEFDay (Either Text EFDay -> Either Text Day)
-> (Text -> Either Text EFDay) -> Text -> Either Text Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text EFDay
validateDate) (FilePath -> Text
T.pack (FilePath -> Text) -> (Day -> FilePath) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> FilePath
forall a. Show a => a -> FilePath
show)
      where
        validateDate :: Text -> Either Text EFDay
validateDate Text
s =
          (HledgerParseErrors -> Text)
-> Either HledgerParseErrors EFDay -> Either Text EFDay
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> HledgerParseErrors -> Text
forall a b. a -> b -> a
const (Text
"Invalid date format" :: Text)) (Either HledgerParseErrors EFDay -> Either Text EFDay)
-> Either HledgerParseErrors EFDay -> Either Text EFDay
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 = Handler
  (Either
     (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
-> [FileInfo]
-> Handler
     (Either
        (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
forall a b. a -> b -> a
const (Handler
   (Either
      (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
 -> [FileInfo]
 -> Handler
      (Either
         (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])))
-> ([Text]
    -> Handler
         (Either
            (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])))
-> [Text]
-> [FileInfo]
-> Handler
     (Either
        (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])
-> Handler
     (Either
        (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])
 -> Handler
      (Either
         (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])))
-> ([Text]
    -> Either
         (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
-> [Text]
-> Handler
     (Either
        (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Text]
-> Either
     (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text])
forall a b. b -> Either a b
Right (Maybe [Text]
 -> Either
      (SomeMessage (HandlerSite (HandlerFor App))) (Maybe [Text]))
-> ([Text] -> Maybe [Text])
-> [Text]
-> Either
     (SomeMessage (HandlerSite (HandlerFor App))) (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 (HandlerFor App) [Text]
fieldView = FilePath -> FieldViewFunc (HandlerFor App) [Text]
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' = [(Text, FilePath)] -> Field (HandlerFor App) FilePath
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] Field (HandlerFor App) FilePath
-> (Field (HandlerFor App) FilePath
    -> Field (HandlerFor App) FilePath)
-> Field (HandlerFor App) FilePath
forall a b. a -> (a -> b) -> b
& (FilePath -> Either FormMessage FilePath)
-> Field (HandlerFor App) FilePath
-> Field (HandlerFor App) FilePath
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 FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
fs = FilePath -> Either FormMessage FilePath
forall a b. b -> Either a b
Right FilePath
f
          | Bool
otherwise = FormMessage -> Either FormMessage FilePath
forall a b. a -> Either a b
Left (FormMessage -> Either FormMessage FilePath)
-> FormMessage -> Either FormMessage FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInputNotFound (Text -> FormMessage) -> Text -> FormMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
f
    -- field settings
    dateSettings :: FieldSettings master
dateSettings = 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")]
    descSettings :: FieldSettings master
descSettings = 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")]
    acctSettings :: FieldSettings master
acctSettings = 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
"account" 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") []
    amtSettings :: FieldSettings master
amtSettings  = 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") []
    fileSettings :: FieldSettings master
fileSettings = 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
"file" 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
"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 (Day
 -> Maybe Text
 -> [Posting]
 -> Maybe FilePath
 -> (Transaction, FilePath))
-> FormResult Day
-> FormResult
     (Maybe Text
      -> [Posting] -> Maybe FilePath -> (Transaction, FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormResult Day
dateRes FormResult
  (Maybe Text
   -> [Posting] -> Maybe FilePath -> (Transaction, FilePath))
-> FormResult (Maybe Text)
-> FormResult
     ([Posting] -> Maybe FilePath -> (Transaction, FilePath))
forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult (Maybe Text)
descRes FormResult ([Posting] -> Maybe FilePath -> (Transaction, FilePath))
-> FormResult [Posting]
-> FormResult (Maybe FilePath -> (Transaction, FilePath))
forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult [Posting]
postingsRes FormResult (Maybe FilePath -> (Transaction, FilePath))
-> FormResult (Maybe FilePath)
-> FormResult (Transaction, FilePath)
forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
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     -> [Text] -> FormResult (Transaction, FilePath)
forall a. [Text] -> FormResult a
FormFailure [FilePath -> Text
T.pack FilePath
e]
      Right Transaction
txn' -> (Transaction, FilePath) -> FormResult (Transaction, FilePath)
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 = date
        ,tdescription = fromMaybe "" mdesc
        ,tpostings = postings
        ,tsourcepos = (initialPos f, initialPos f)
        }, FilePath
f)
      where f :: FilePath
f = FilePath -> Maybe FilePath -> FilePath
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 = ((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]
acctsRes) ([Text] -> FormResult [Text] -> [Text]
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 = ((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)
    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) = ((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 = acct, ptype = atype, pamount = mixedAmount 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 = (HledgerParseErrors -> Text)
-> Either HledgerParseErrors c -> Either Text c
forall a b c. (a -> b) -> Either a c -> Either b 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)
-> (HledgerParseErrors -> Text) -> HledgerParseErrors -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text)
-> (HledgerParseErrors -> FilePath) -> HledgerParseErrors -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          (FilePath -> ParseError Text HledgerParseErrorData -> FilePath)
-> FilePath
-> NonEmpty (ParseError Text HledgerParseErrorData)
-> FilePath
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\FilePath
s ParseError Text HledgerParseErrorData
a -> FilePath
s FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ParseError Text HledgerParseErrorData -> FilePath
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> FilePath
parseErrorTextPretty ParseError Text HledgerParseErrorData
a) FilePath
"" (NonEmpty (ParseError Text HledgerParseErrorData) -> FilePath)
-> (HledgerParseErrors
    -> NonEmpty (ParseError Text HledgerParseErrorData))
-> HledgerParseErrors
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          HledgerParseErrors
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors)
  checkAccount :: Text -> Either Text Text
checkAccount = Either HledgerParseErrors Text -> Either Text Text
forall {c}. Either HledgerParseErrors c -> Either Text c
errorToFormMsg (Either HledgerParseErrors Text -> Either Text Text)
-> (Text -> Either HledgerParseErrors Text)
-> Text
-> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec HledgerParseErrorData Text Text
-> FilePath -> Text -> Either HledgerParseErrors Text
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec HledgerParseErrorData Text Text
forall (m :: * -> *). TextParser m Text
accountnamep Parsec HledgerParseErrorData Text Text
-> ParsecT HledgerParseErrorData Text Identity ()
-> Parsec HledgerParseErrorData Text Text
forall a b.
ParsecT HledgerParseErrorData Text Identity a
-> ParsecT HledgerParseErrorData Text Identity b
-> ParsecT HledgerParseErrorData Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) FilePath
"" (Text -> Either HledgerParseErrors Text)
-> (Text -> Text) -> Text -> Either HledgerParseErrors Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
  checkAmount :: Text -> Either Text Amount
checkAmount = Either HledgerParseErrors Amount -> Either Text Amount
forall {c}. Either HledgerParseErrors c -> Either Text c
errorToFormMsg (Either HledgerParseErrors Amount -> Either Text Amount)
-> (Text -> Either HledgerParseErrors Amount)
-> Text
-> Either Text Amount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec HledgerParseErrorData Text Amount
-> FilePath -> Text -> Either HledgerParseErrors Amount
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
-> Journal -> Parsec HledgerParseErrorData Text Amount
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
forall (m :: * -> *). JournalParser m Amount
amountp StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) ()
-> StateT
     Journal (ParsecT HledgerParseErrorData Text Identity) Amount
forall a b.
StateT Journal (ParsecT HledgerParseErrorData Text Identity) a
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) b
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT HledgerParseErrorData Text Identity) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Journal
nulljournal) FilePath
"" (Text -> Either HledgerParseErrors Amount)
-> (Text -> Text) -> Text -> Either HledgerParseErrors 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]
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
"", (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 a b. (a -> b) -> [a] -> [b]
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 a. [a] -> 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)

-- 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 (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
"]"
    ]
  where
    -- decodeBase64EncodedText is defined in add-form.hamlet
    b64wrap :: Text -> Text
b64wrap = (Text
"decodeBase64EncodedText(\""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

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)(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 :: 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