{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Ditto.Lucid.Named where
import Data.Foldable (traverse_, fold)
import Data.List.NonEmpty
import Data.Text (Text)
import Ditto.Backend
import Ditto.Core
import Ditto.Generalized.Named as G
import Ditto.Types
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
:: (Environment m input, FormError input err, PathPiece text, Applicative f)
=> (input -> Either err text)
-> Text
-> text
-> Form m input err (HtmlT f ()) text
inputText getInput name initialValue = G.input name getInput inputField initialValue
where
inputField i a = input_ [type_ "text", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a)]
inputMaybeText
:: (Environment m input, FormError input err, PathPiece text, Applicative f)
=> (input -> Either err text)
-> Text
-> Maybe text
-> Form m input err (HtmlT f ()) (Maybe text)
inputMaybeText getInput name initialValue = G.inputMaybe name getInput inputField initialValue
where
inputField i a = let attrs = maybe [] (pure . value_ . toPathPiece) a in
input_ $ type_ "text" : id_ (encodeFormId i) : name_ (encodeFormId i) : attrs
inputPassword
:: (Environment m input, FormError input err, PathPiece text, Applicative f)
=> (input -> Either err text)
-> Text
-> text
-> Form m input err (HtmlT f ()) text
inputPassword getInput name initialValue = G.input name getInput inputField initialValue
where
inputField i a = input_ [type_ "password", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a)]
inputSubmit
:: (Environment m input, FormError input err, PathPiece text, Applicative f)
=> (input -> Either err text)
-> Text
-> text
-> Form m input err (HtmlT f ()) (Maybe text)
inputSubmit getInput name initialValue = G.inputMaybe name getInput inputField (Just initialValue)
where
inputField i a = input_ [type_ "submit", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a)]
inputReset
:: (Environment m input, FormError input err, PathPiece text, Applicative f)
=> Text
-> text
-> Form m input err (HtmlT f ()) ()
inputReset name lbl = G.inputNoData name inputField
where
inputField i = input_ [type_ "submit", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece lbl)]
inputHidden
:: (Environment m input, FormError input err, PathPiece text, Applicative f)
=> (input -> Either err text)
-> Text
-> text
-> Form m input err (HtmlT f ()) text
inputHidden getInput name initialValue = G.input name getInput inputField initialValue
where
inputField i a = input_ [type_ "hidden", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece a)]
inputButton
:: (Environment m input, FormError input err, PathPiece text, Applicative f)
=> Text
-> text
-> Form m input err (HtmlT f ()) ()
inputButton name lbl = G.inputNoData name inputField
where
inputField i = input_ [type_ "button", id_ (encodeFormId i), name_ (encodeFormId i), value_ (toPathPiece lbl)]
textarea
:: (Environment m input, FormError input err, ToHtml text, Monad f)
=> (input -> Either err text)
-> Int -- ^ cols
-> Int -- ^ rows
-> Text
-> text -- ^ initial text
-> Form m input err (HtmlT f ()) text
textarea getInput cols rows name initialValue = G.input name 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
:: (Environment m input, FormError input err, FormInput input, Applicative f, ft ~ FileType input, Monoid ft)
=> Text
-> Form m input err (HtmlT f ()) (FileType input)
inputFile name = G.inputFile name fileView
where
fileView i = input_ [type_ "file", id_ (encodeFormId i), name_ (encodeFormId i)]
-- | Create a @\