{-# 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 = ()
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
forall a.
a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
down Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [Char]
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"called down with a negative number"
down Int
i = do
    is <- RWST
  (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m Ints
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    put $ IntCons 0 is
    down $ i - 1

up :: Monad m => Int -> MForm m ()
up :: forall (m :: * -> *). Monad m => Int -> MForm m ()
up Int
0 = ()
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
forall a.
a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
up Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [Char]
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"called down with a negative number"
up Int
i = do
    is <- RWST
  (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m Ints
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    case is of
        IntSingle Int
_ -> [Char]
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"up on IntSingle"
        IntCons Int
_ Ints
is' -> Ints
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put Ints
is' RWST
  (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m Lang
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m Lang
forall a b.
RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m b
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RWST
  (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m Lang
forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent RWST
  (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m Lang
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
forall a b.
RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m b
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ()
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m ()
forall a.
a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    up $ i - 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 = MForm (HandlerFor site) (FormResult [a], [FieldView site])
-> AForm (HandlerFor site) [a]
forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm (MForm (HandlerFor site) (FormResult [a], [FieldView site])
 -> AForm (HandlerFor site) [a])
-> MForm (HandlerFor site) (FormResult [a], [FieldView site])
-> AForm (HandlerFor site) [a]
forall a b. (a -> b) -> a -> b
$ do
    theId <- HandlerFor site Lang
-> RWST
     (Maybe (Env, FileEnv), site, [Lang])
     Enctype
     Ints
     (HandlerFor site)
     Lang
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift HandlerFor site Lang
forall (m :: * -> *). MonadHandler m => m Lang
newIdent
    down 1
    countName <- newFormIdent
    addName <- newFormIdent
    (menv, _, _) <- ask
    let readInt Lang
t =
            case Reader a
forall a. Integral a => Reader a
decimal Lang
t of
                Right (a
i, Lang
"") -> a -> Maybe a
forall a. a -> Maybe a
Just a
i
                Either [Char] (a, Lang)
_ -> Maybe a
forall a. Maybe a
Nothing
    let vals =
            case Maybe (Env, FileEnv)
menv of
                Maybe (Env, FileEnv)
Nothing -> (a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe a
forall a. a -> Maybe a
Just ([a] -> [Maybe a]) -> [a] -> [Maybe a]
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [a]
mdef
                Just (Env
env, FileEnv
_) ->
                    let toAdd :: Bool
toAdd = Bool -> ([Lang] -> Bool) -> Maybe [Lang] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> [Lang] -> Bool
forall a b. a -> b -> a
const Bool
True) (Maybe [Lang] -> Bool) -> Maybe [Lang] -> Bool
forall a b. (a -> b) -> a -> b
$ Lang -> Env -> Maybe [Lang]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Lang
addName Env
env
                        count' :: Int
count' = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Lang -> Env -> Maybe [Lang]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Lang
countName Env
env Maybe [Lang] -> ([Lang] -> Maybe Lang) -> Maybe Lang
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Lang] -> Maybe Lang
forall a. [a] -> Maybe a
listToMaybe Maybe Lang -> (Lang -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Lang -> Maybe Int
forall {a}. Integral a => Lang -> Maybe a
readInt
                        count :: Int
count = (if Bool
toAdd then Int
1 else Int
0) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count'
                     in Int -> Maybe a -> [Maybe a]
forall a. Int -> a -> [a]
replicate Int
count Maybe a
forall a. Maybe a
Nothing
    let count = [Maybe a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe a]
vals
    (res, xmls, views) <- liftM fixme $ mapM (withDelete . single) vals
    up 1
    return (res, [FieldView
        { fvLabel = label
        , fvTooltip = Nothing
        , fvId = theId
        , 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 = Nothing
        , fvRequired = 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
    Int -> MForm (HandlerFor site) ()
forall (m :: * -> *). Monad m => Int -> MForm m ()
down Int
1
    deleteName <- RWST
  (Maybe (Env, FileEnv), site, [Lang])
  Enctype
  Ints
  (HandlerFor site)
  Lang
MForm (HandlerFor site) Lang
forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent
    (menv, _, _) <- ask
    res <- case menv >>= Map.lookup deleteName . fst of
        Just (Lang
"yes":[Lang]
_) -> Either (WidgetFor site ()) (FormResult a, [FieldView site])
-> RWST
     (Maybe (Env, FileEnv), site, [Lang])
     Enctype
     Ints
     (HandlerFor site)
     (Either (WidgetFor site ()) (FormResult a, [FieldView site]))
forall a.
a
-> RWST
     (Maybe (Env, FileEnv), site, [Lang])
     Enctype
     Ints
     (HandlerFor site)
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (WidgetFor site ()) (FormResult a, [FieldView site])
 -> RWST
      (Maybe (Env, FileEnv), site, [Lang])
      Enctype
      Ints
      (HandlerFor site)
      (Either (WidgetFor site ()) (FormResult a, [FieldView site])))
-> Either (WidgetFor site ()) (FormResult a, [FieldView site])
-> RWST
     (Maybe (Env, FileEnv), site, [Lang])
     Enctype
     Ints
     (HandlerFor site)
     (Either (WidgetFor site ()) (FormResult a, [FieldView site]))
forall a b. (a -> b) -> a -> b
$ WidgetFor site ()
-> Either (WidgetFor site ()) (FormResult a, [FieldView site])
forall a b. a -> Either a b
Left [whamlet|
$newline never
<input type=hidden name=#{deleteName} value=yes>
|]
        Maybe [Lang]
_ -> do
            (_, xml2) <- AForm (HandlerFor site) Bool
-> MForm
     (HandlerFor site)
     (FormResult Bool, [FieldView site] -> [FieldView site])
forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm (AForm (HandlerFor site) Bool
 -> MForm
      (HandlerFor site)
      (FormResult Bool, [FieldView site] -> [FieldView site]))
-> AForm (HandlerFor site) Bool
-> MForm
     (HandlerFor site)
     (FormResult Bool, [FieldView site] -> [FieldView site])
forall a b. (a -> b) -> a -> b
$ Field (HandlerFor site) Bool
-> FieldSettings site -> Maybe Bool -> AForm (HandlerFor site) Bool
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a -> FieldSettings site -> Maybe a -> AForm m a
areq Field (HandlerFor site) Bool
forall (m :: * -> *). Monad m => Field m Bool
checkBoxField FieldSettings
                { fsLabel :: SomeMessage site
fsLabel = FormMessage -> SomeMessage site
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage FormMessage
MsgDelete
                , fsTooltip :: Maybe (SomeMessage site)
fsTooltip = Maybe (SomeMessage site)
forall a. Maybe a
Nothing
                , fsName :: Maybe Lang
fsName = Lang -> Maybe Lang
forall a. a -> Maybe a
Just Lang
deleteName
                , fsId :: Maybe Lang
fsId = Maybe Lang
forall a. Maybe a
Nothing
                , fsAttrs :: [(Lang, Lang)]
fsAttrs = []
                } (Maybe Bool -> AForm (HandlerFor site) Bool)
-> Maybe Bool -> AForm (HandlerFor site) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
            (res, xml) <- aFormToForm af
            return $ Right (res, xml $ xml2 [])
    up 1
    return 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, ((FormResult a, [FieldView site]) -> [FieldView site])
-> [(FormResult a, [FieldView site])] -> [[FieldView site]]
forall a b. (a -> b) -> [a] -> [b]
map (FormResult a, [FieldView site]) -> [FieldView site]
forall a b. (a, b) -> b
snd [(FormResult a, [FieldView site])]
rest)
  where
    ([xml]
xmls, [(FormResult a, [FieldView site])]
rest) = [Either xml (FormResult a, [FieldView site])]
-> ([xml], [(FormResult a, [FieldView site])])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either xml (FormResult a, [FieldView site])]
eithers
    res :: FormResult [a]
res = [FormResult a] -> FormResult [a]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
Data.Traversable.sequenceA ([FormResult a] -> FormResult [a])
-> [FormResult a] -> FormResult [a]
forall a b. (a -> b) -> a -> b
$ ((FormResult a, [FieldView site]) -> FormResult a)
-> [(FormResult a, [FieldView site])] -> [FormResult a]
forall a b. (a -> b) -> [a] -> [b]
map (FormResult a, [FieldView site]) -> FormResult a
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}
|]