{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
-- | A module providing a means of creating multiple input forms, such as a
-- list of 0 or more recipients.
module Yesod.Form.MassInput
    ( inputList
    , massDivs
    , massTable
    ) where

import Yesod.Form.Types
import Yesod.Form.Functions
import Yesod.Form.Fields (checkBoxField)
import Yesod.Core
import Control.Monad.Trans.RWS (get, put, ask)
import Data.Maybe (fromMaybe)
import Data.Text.Read (decimal)
import Control.Monad (liftM)
import Data.Either (partitionEithers)
import Data.Traversable (sequenceA)
import qualified Data.Map as Map
import Data.Maybe (listToMaybe)

down :: Monad m => Int -> MForm m ()
down :: forall (m :: * -> *). Monad m => Int -> MForm m ()
down Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
down Int
i | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"called down with a negative number"
down Int
i = do
    Ints
is <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put forall a b. (a -> b) -> a -> b
$ Int -> Ints -> Ints
IntCons Int
0 Ints
is
    forall (m :: * -> *). Monad m => Int -> MForm m ()
down forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
- Int
1

up :: Monad m => Int -> MForm m ()
up :: forall (m :: * -> *). Monad m => Int -> MForm m ()
up Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
up Int
i | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"called down with a negative number"
up Int
i = do
    Ints
is <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    case Ints
is of
        IntSingle Int
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"up on IntSingle"
        IntCons Int
_ Ints
is' -> forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put Ints
is' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *). Monad m => Int -> MForm m ()
up forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
- Int
1

-- | Generate a form that accepts 0 or more values from the user, allowing the
-- user to specify that a new row is necessary.
inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
          => Html
          -- ^ label for the form
          -> ([[FieldView site]] -> xml)
          -- ^ how to display the rows, usually either 'massDivs' or 'massTable'
          -> (Maybe a -> AForm (HandlerFor site) a)
          -- ^ display a single row of the form, where @Maybe a@ gives the
          -- previously submitted value
          -> Maybe [a]
          -- ^ default initial values for the form
          -> AForm (HandlerFor site) [a]
inputList :: forall xml site a.
(xml ~ WidgetFor site (), RenderMessage site FormMessage) =>
Html
-> ([[FieldView site]] -> xml)
-> (Maybe a -> AForm (HandlerFor site) a)
-> Maybe [a]
-> AForm (HandlerFor site) [a]
inputList Html
label [[FieldView site]] -> xml
fixXml Maybe a -> AForm (HandlerFor site) a
single Maybe [a]
mdef = forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm forall a b. (a -> b) -> a -> b
$ do
    Lang
theId <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadHandler m => m Lang
newIdent
    forall (m :: * -> *). Monad m => Int -> MForm m ()
down Int
1
    Lang
countName <- forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent
    Lang
addName <- forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent
    (Maybe (Env, FileEnv)
menv, site
_, [Lang]
_) <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
    let readInt :: Lang -> Maybe a
readInt Lang
t =
            case forall a. Integral a => Reader a
decimal Lang
t of
                Right (a
i, Lang
"") -> forall a. a -> Maybe a
Just a
i
                Either [Char] (a, Lang)
_ -> forall a. Maybe a
Nothing
    let vals :: [Maybe a]
vals =
            case Maybe (Env, FileEnv)
menv of
                Maybe (Env, FileEnv)
Nothing -> forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [a]
mdef
                Just (Env
env, FileEnv
_) ->
                    let toAdd :: Bool
toAdd = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Lang
addName Env
env
                        count' :: Int
count' = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Lang
countName Env
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. [a] -> Maybe a
listToMaybe forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}. Integral a => Lang -> Maybe a
readInt
                        count :: Int
count = (if Bool
toAdd then Int
1 else Int
0) forall a. Num a => a -> a -> a
+ Int
count'
                     in forall a. Int -> a -> [a]
replicate Int
count forall a. Maybe a
Nothing
    let count :: Int
count = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe a]
vals
    (FormResult [a]
res, [WidgetFor site ()]
xmls, [[FieldView site]]
views) <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall xml a site.
[Either xml (FormResult a, [FieldView site])]
-> (FormResult [a], [xml], [[FieldView site]])
fixme forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall xml site a.
(xml ~ WidgetFor site (), RenderMessage site FormMessage) =>
AForm (HandlerFor site) a
-> MForm
     (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
withDelete forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> AForm (HandlerFor site) a
single) [Maybe a]
vals
    forall (m :: * -> *). Monad m => Int -> MForm m ()
up Int
1
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult [a]
res, [FieldView
        { fvLabel :: Html
fvLabel = Html
label
        , fvTooltip :: Maybe Html
fvTooltip = forall a. Maybe a
Nothing
        , fvId :: Lang
fvId = Lang
theId
        , fvInput :: WidgetFor site ()
fvInput = [whamlet|
$newline never
^{fixXml views}
<p>
    $forall xml <- xmls
        ^{xml}
    <input .count type=hidden name=#{countName} value=#{count}>
    <input type=checkbox name=#{addName}>
    Add another row
|]
        , fvErrors :: Maybe Html
fvErrors = forall a. Maybe a
Nothing
        , fvRequired :: Bool
fvRequired = Bool
False
        }])

withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
           => AForm (HandlerFor site) a
           -> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
withDelete :: forall xml site a.
(xml ~ WidgetFor site (), RenderMessage site FormMessage) =>
AForm (HandlerFor site) a
-> MForm
     (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
withDelete AForm (HandlerFor site) a
af = do
    forall (m :: * -> *). Monad m => Int -> MForm m ()
down Int
1
    Lang
deleteName <- forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent
    (Maybe (Env, FileEnv)
menv, site
_, [Lang]
_) <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
    Either (WidgetFor site ()) (FormResult a, [FieldView site])
res <- case Maybe (Env, FileEnv)
menv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Lang
deleteName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst of
        Just (Lang
"yes":[Lang]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [whamlet|
$newline never
<input type=hidden name=#{deleteName} value=yes>
|]
        Maybe [Lang]
_ -> do
            (FormResult Bool
_, [FieldView site] -> [FieldView site]
xml2) <- forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm forall a b. (a -> b) -> a -> b
$ forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a -> FieldSettings site -> Maybe a -> AForm m a
areq forall (m :: * -> *). Monad m => Field m Bool
checkBoxField FieldSettings
                { fsLabel :: SomeMessage site
fsLabel = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage FormMessage
MsgDelete
                , fsTooltip :: Maybe (SomeMessage site)
fsTooltip = forall a. Maybe a
Nothing
                , fsName :: Maybe Lang
fsName = forall a. a -> Maybe a
Just Lang
deleteName
                , fsId :: Maybe Lang
fsId = forall a. Maybe a
Nothing
                , fsAttrs :: [(Lang, Lang)]
fsAttrs = []
                } forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False
            (FormResult a
res, [FieldView site] -> [FieldView site]
xml) <- forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm AForm (HandlerFor site) a
af
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (FormResult a
res, [FieldView site] -> [FieldView site]
xml forall a b. (a -> b) -> a -> b
$ [FieldView site] -> [FieldView site]
xml2 [])
    forall (m :: * -> *). Monad m => Int -> MForm m ()
up Int
1
    forall (m :: * -> *) a. Monad m => a -> m a
return Either (WidgetFor site ()) (FormResult a, [FieldView site])
res

fixme :: [Either xml (FormResult a, [FieldView site])]
      -> (FormResult [a], [xml], [[FieldView site]])
fixme :: forall xml a site.
[Either xml (FormResult a, [FieldView site])]
-> (FormResult [a], [xml], [[FieldView site]])
fixme [Either xml (FormResult a, [FieldView site])]
eithers =
    (FormResult [a]
res, [xml]
xmls, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(FormResult a, [FieldView site])]
rest)
  where
    ([xml]
xmls, [(FormResult a, [FieldView site])]
rest) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either xml (FormResult a, [FieldView site])]
eithers
    res :: FormResult [a]
res = forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
Data.Traversable.sequenceA forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(FormResult a, [FieldView site])]
rest

massDivs, massTable
         :: [[FieldView site]]
         -> WidgetFor site ()
massDivs :: forall site. [[FieldView site]] -> WidgetFor site ()
massDivs [[FieldView site]]
viewss = [whamlet|
$newline never
$forall views <- viewss
    <fieldset>
        $forall view <- views
            <div :fvRequired view:.required :not $ fvRequired view:.optional>
                <label for=#{fvId view}>#{fvLabel view}
                $maybe tt <- fvTooltip view
                    <div .tooltip>#{tt}
                ^{fvInput view}
                $maybe err <- fvErrors view
                    <div .errors>#{err}
|]

massTable :: forall site. [[FieldView site]] -> WidgetFor site ()
massTable [[FieldView site]]
viewss = [whamlet|
$newline never
$forall views <- viewss
    <fieldset>
        <table>
            $forall view <- views
                <tr :fvRequired view:.required :not $ fvRequired view:.optional>
                    <td>
                        <label for=#{fvId view}>#{fvLabel view}
                        $maybe tt <- fvTooltip view
                            <div .tooltip>#{tt}
                    <td>^{fvInput view}
                    $maybe err <- fvErrors view
                        <td .errors>#{err}
|]