{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
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 :: Int -> MForm m ()
down Int
0 = () -> MForm m ()
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] -> MForm m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"called down with a negative number"
down Int
i = do
Ints
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
Ints -> MForm m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put (Ints -> MForm m ()) -> Ints -> MForm m ()
forall a b. (a -> b) -> a -> b
$ Int -> Ints -> Ints
IntCons Int
0 Ints
is
Int -> MForm m ()
forall (m :: * -> *). Monad m => Int -> MForm m ()
down (Int -> MForm m ()) -> Int -> MForm m ()
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
up :: Monad m => Int -> MForm m ()
up :: Int -> MForm m ()
up Int
0 = () -> MForm m ()
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] -> MForm m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"called down with a negative number"
up Int
i = do
Ints
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 Ints
is of
IntSingle Int
_ -> [Char] -> MForm m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"up on IntSingle"
IntCons Int
_ Ints
is' -> Ints -> MForm m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put Ints
is' MForm m ()
-> RWST
(Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m Lang
-> RWST
(Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m Lang
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
-> MForm m () -> MForm m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> MForm m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Int -> MForm m ()
forall (m :: * -> *). Monad m => Int -> MForm m ()
up (Int -> MForm m ()) -> Int -> MForm m ()
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
=> Html
-> ([[FieldView site]] -> xml)
-> (Maybe a -> AForm (HandlerFor site) a)
-> Maybe [a]
-> AForm (HandlerFor site) [a]
inputList :: 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
Lang
theId <- HandlerFor site Lang
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
Lang
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift HandlerFor site Lang
forall (m :: * -> *). MonadHandler m => m Lang
newIdent
Int -> MForm (HandlerFor site) ()
forall (m :: * -> *). Monad m => Int -> MForm m ()
down Int
1
Lang
countName <- RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
Lang
forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent
Lang
addName <- RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
Lang
forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent
(Maybe (Env, FileEnv)
menv, site
_, [Lang]
_) <- RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(Maybe (Env, FileEnv), 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 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 :: [Maybe a]
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 (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 (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 :: Int
count = [Maybe a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe a]
vals
(FormResult [a]
res, [WidgetFor site ()]
xmls, [[FieldView site]]
views) <- ([Either (WidgetFor site ()) (FormResult a, [FieldView site])]
-> (FormResult [a], [WidgetFor site ()], [[FieldView site]]))
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
[Either (WidgetFor site ()) (FormResult a, [FieldView site])]
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(FormResult [a], [WidgetFor site ()], [[FieldView site]])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Either (WidgetFor site ()) (FormResult a, [FieldView site])]
-> (FormResult [a], [WidgetFor site ()], [[FieldView site]])
forall xml a site.
[Either xml (FormResult a, [FieldView site])]
-> (FormResult [a], [xml], [[FieldView site]])
fixme (RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
[Either (WidgetFor site ()) (FormResult a, [FieldView site])]
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(FormResult [a], [WidgetFor site ()], [[FieldView site]]))
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
[Either (WidgetFor site ()) (FormResult a, [FieldView site])]
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(FormResult [a], [WidgetFor site ()], [[FieldView site]])
forall a b. (a -> b) -> a -> b
$ (Maybe a
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(Either (WidgetFor site ()) (FormResult a, [FieldView site])))
-> [Maybe a]
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
[Either (WidgetFor site ()) (FormResult a, [FieldView site])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AForm (HandlerFor site) a
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(Either (WidgetFor site ()) (FormResult a, [FieldView site]))
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
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(Either (WidgetFor site ()) (FormResult a, [FieldView site])))
-> (Maybe a -> AForm (HandlerFor site) a)
-> Maybe a
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(Either (WidgetFor site ()) (FormResult a, [FieldView site]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> AForm (HandlerFor site) a
single) [Maybe a]
vals
Int -> MForm (HandlerFor site) ()
forall (m :: * -> *). Monad m => Int -> MForm m ()
up Int
1
(FormResult [a], [FieldView site])
-> RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(FormResult [a], [FieldView site])
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult [a]
res, [FieldView :: forall site.
Html
-> Maybe Html
-> Lang
-> WidgetFor site ()
-> Maybe Html
-> Bool
-> FieldView site
FieldView
{ fvLabel :: Html
fvLabel = Html
label
, fvTooltip :: Maybe Html
fvTooltip = Maybe Html
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 = Maybe Html
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 :: 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
Lang
deleteName <- RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
Lang
forall (m :: * -> *). Monad m => MForm m Lang
newFormIdent
(Maybe (Env, FileEnv)
menv, site
_, [Lang]
_) <- RWST
(Maybe (Env, FileEnv), site, [Lang])
Enctype
Ints
(HandlerFor site)
(Maybe (Env, FileEnv), 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 Maybe (Env, FileEnv)
-> ((Env, FileEnv) -> Maybe [Lang]) -> Maybe [Lang]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Lang -> Env -> Maybe [Lang]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Lang
deleteName (Env -> Maybe [Lang])
-> ((Env, FileEnv) -> Env) -> (Env, FileEnv) -> Maybe [Lang]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Env, FileEnv) -> Env
forall a b. (a, b) -> a
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 (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
(FormResult Bool
_, [FieldView site] -> [FieldView site]
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 :: forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Lang
-> Maybe Lang
-> [(Lang, Lang)]
-> FieldSettings master
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
(FormResult a
res, [FieldView site] -> [FieldView site]
xml) <- AForm (HandlerFor site) a
-> MForm
(HandlerFor site)
(FormResult a, [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) a
af
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 (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
$ (FormResult a, [FieldView site])
-> Either (WidgetFor site ()) (FormResult a, [FieldView site])
forall a b. b -> Either a b
Right (FormResult a
res, [FieldView site] -> [FieldView site]
xml ([FieldView site] -> [FieldView site])
-> [FieldView site] -> [FieldView site]
forall a b. (a -> b) -> a -> b
$ [FieldView site] -> [FieldView site]
xml2 [])
Int -> MForm (HandlerFor site) ()
forall (m :: * -> *). Monad m => Int -> MForm m ()
up Int
1
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 (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 :: [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)
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 :: [[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 :: [[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}
|]