Source

layout-bootstrap / Layout / Bootstrap / Forms.hs

Full commit
{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Module: Layout.Bootstrap.Forms
-- 
-- Generic form builder and processor.
-- Not-so bootstrap, but uses it's widgets.
--
-----------------------------------------------------------------------------

module Layout.Bootstrap.Forms where

import Text.Blaze (ToHtml)
import Text.Blaze.Html5 (toHtml, toValue, (!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import qualified Data.Text as T
import Control.Monad (forM, forM_)
import qualified Data.Map as HM

import Happstack.Server (lookTexts', ServerPartT)

import Layout.Bootstrap.Widgets (
  fieldset, form,
  simpleInput, Input(..),
  formActions, button)

-- | Compose a form from groups of inputs.
data Form = Form { required :: [Input]
                 , optional :: [Input]
                 , extra    :: [Input]
                 , formValues :: HM.Map T.Text [T.Text]
                 , formErrors :: HM.Map T.Text [T.Text]
                 } deriving (Show)

instance ToHtml Form where
    toHtml form = do makeFields "Required" $! required form
                     makeFields "Optional" $! optional form
                     makeFields "Extra" $! extra form

                     case extra form of
                          [] -> ""
                          fs -> extraFields fs

                     formActions $! do
                        button "submit" ["btn-primary"] "Commit Request"
                        button "reset" [] "Reset Form"

                  where
                      value key = case HM.findWithDefault [] (T.toLower key) (formValues form) of
                                    [] -> ""
                                    [""] -> ""
                                    v:vs -> v

                      err key = HM.findWithDefault [] (T.toLower key) (formErrors form)

                      makeFields title fields = case fields of
                                                    [] -> ""
                                                    fs -> fieldset title $ mapM_ toHtml (withErrors . withValues $ fields)

                      withValues = map (\field -> case value (title field) of
                                                      "" -> field
                                                      fv -> field { value = fv })

                      withErrors = map (\field -> case err (title field) of
                                                      [] -> field
                                                      fe -> field { help = "Error" })

                      extraFields fs = forM_ fs (\f -> H.input
                                                       ! A.type_ "hidden"
                                                       ! A.name "extra"
                                                       ! (A.value . toValue . title $ f))

emptyForm extra = Form [] [] (map simpleInput extra) HM.empty HM.empty

textField title placeholder help = Input title placeholder help "" False


-- * Happstack helpers

-- | Fill in form values and errors.
lookValues :: Form -> ServerPartT IO Form
lookValues form = do
    reqd <- formData $ required form
    optl <- formData $ optional form
    extr <- formData $ extra form

    return form { formValues = HM.unions $ map HM.fromList [reqd, optl, extr]
                , formErrors = HM.fromList $ checkRequired reqd }

-- | Load assoc list of values from current request.
formData :: [Input] -> ServerPartT IO [(T.Text, [T.Text])]
formData fs = forM fs
    (\field -> do
        let name = T.toLower $ title field
        value <- lookTexts' $ T.unpack name
        return (name, value))

-- | Check if some items are missing their values.
isRequired title = (title, ["This field is required."])
checkRequired = concatMap (\(title, values) -> case values of
                                                   [] -> [isRequired title]
                                                   [""] -> [isRequired title]
                                                   _ -> [])