{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Ditto.Lucid.Unnamed where
import Data.Foldable (traverse_, fold)
import Ditto.Backend
import Ditto.Core
import Ditto.Generalized as G
import Ditto.Lucid
import Ditto.Result (FormId, Result (Ok), unitRange)
import Lucid
import Web.PathPieces
import qualified Data.Text as T
foldTraverse_ :: (Foldable t, Applicative f, Monoid (f b)) => (a -> t (f b)) -> t a -> f ()
foldTraverse_ f = traverse_ (fold . f)
inputText
:: (Monad m, FormError err input, PathPiece text, Applicative f)
=> (input -> Either err text)
-> text
-> Form m input err (HtmlT f ()) text
inputText getInput initialValue = G.input getInput inputField initialValue
where
inputField i a = input_ [type_ "text", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a)]
inputTextMReq
:: (Monad m, FormError err input, PathPiece text, Applicative f)
=> (input -> Either err text)
-> Maybe text
-> Form m input err (HtmlT f ()) text
inputTextMReq getInput initialValue = G.inputMaybeReq getInput inputField initialValue
where
inputField i Nothing = input_ [type_ "text", id_ (encodeFormId i), name_ (encodeFormId i), required_ "required"]
inputField i (Just a) = input_ [type_ "text", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a), required_ "required"]
inputPassword
:: (Monad m, FormError err input, PathPiece text, Applicative f)
=> (input -> Either err text)
-> text
-> Form m input err (HtmlT f ()) text
inputPassword getInput initialValue = G.input getInput inputField initialValue
where
inputField i a = input_ [type_ "password", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a)]
inputSubmit
:: (Monad m, FormError err input, PathPiece text, Applicative f)
=> (input -> Either err text)
-> text
-> Form m input err (HtmlT f ()) (Maybe text)
inputSubmit getInput initialValue = G.inputMaybe getInput inputField (Just initialValue)
where
inputField i a = input_ [type_ "submit", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a)]
inputReset
:: (Monad m, FormError err input, PathPiece text, Applicative f)
=> text
-> Form m input err (HtmlT f ()) ()
inputReset lbl = G.inputNoData inputField
where
inputField i = input_ [type_ "submit", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece lbl)]
inputHidden
:: (Monad m, FormError err input, PathPiece text, Applicative f)
=> (input -> Either err text)
-> text
-> Form m input err (HtmlT f ()) text
inputHidden getInput initialValue = G.input getInput inputField initialValue
where
inputField i a = input_ [type_ "hidden", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a)]
inputButton
:: (Monad m, FormError err input, PathPiece text, Applicative f)
=> text
-> Form m input err (HtmlT f ()) ()
inputButton lbl = G.inputNoData inputField
where
inputField i = input_ [type_ "button", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece lbl)]
textarea
:: (Monad m, FormError err input, ToHtml text, Monad f)
=> (input -> Either err text)
-> Int -- ^ cols
-> Int -- ^ rows
-> text -- ^ initial text
-> Form m input err (HtmlT f ()) text
textarea getInput cols rows initialValue = G.input getInput textareaView initialValue
where
textareaView i txt =
textarea_
[ rows_ (toPathPiece rows)
, cols_ (toPathPiece cols)
, id_ (encodeFormId i)
, name_ (encodeFormId i)
] $
toHtml txt
-- | Create an @\@ element
--
-- This control may succeed even if the user does not actually select a file to upload. In that case the uploaded name will likely be \"\" and the file contents will be empty as well.
inputFile
:: (Monad m, FormError err input, FormInput input, Applicative f)
=> Form m input err (HtmlT f ()) (FileType input)
inputFile = G.inputFile fileView
where
fileView i = input_ [type_ "file", id_ (encodeFormId i), name_ (encodeFormId i)]
-- | Create a @\