formlets-0.1: Text/Formlets.hs

{-# LANGUAGE TypeOperators #-}
module Text.Formlets ( module Text.Formlets.Form
                     , input , password , inputF , passwordF,ensure
                     , FailingForm, validate, runFormState, inputIntegerF
                     , check, liftForm
                     )
                     where

import Text.Formlets.Form
import Control.Applicative
import Control.Applicative.Compose
import Control.Applicative.Error
import Control.Applicative.State
import Text.XHtml.Strict ((!))
import qualified Text.XHtml.Strict as X

-- | Apply a predicate to a value and return Success or Failure as appropriate
ensure :: Show a 
       => (a -> Bool) -- ^ The predicate
       -> String      -- ^ The error message, in case the predicate fails
       -> a           -- ^ The value
       -> Failing a
ensure p msg x | p x = Success x
               | otherwise = Failure [msg]

-- | Helper function for genereting input components based.
input' :: (String -> String -> X.Html) -> Maybe String -> Form String
input' i defaultValue = Form $ \env -> mkInput env <$> freshName
   where mkInput :: Env -> String -> (Collector String, Xml)
         mkInput env name = (`queryParam` name,
                             i name (value name env))
         value name env = maybe (maybe "" id defaultValue) id (lookup name env)

-- | A form whose output may fail
type FailingForm a = (Form :+: Failing) a

runFormState :: Env             -- ^ A previously filled environment (may be empty)
             -> FailingForm a   -- ^ The form
             -> FormState       -- ^ Initial form state
             -> ((Collector (Failing a), Xml), FormState)
runFormState e f s = (runState (deform (decompose f) e) s)

-- | Lifts a function on a Form to a function on a composed form.
liftForm :: (Form (f a) -> Form (f a)) -> (Form :+: f) a -> (Form :+: f) a
liftForm f = Compose . f . decompose

-- | Lift a form component to a failing form component
validate :: Form a -> FailingForm a
validate f = Compose $ pure Success <*> f

-- | Add additional validation to an already validated component
check :: FailingForm a -> (a -> Failing b) -> FailingForm b
check form f = decompose form `chk` checker f
   where chk :: Form a -> (a -> Failing b) -> FailingForm b
         chk form validator = Compose $ pure validator <*> form
         checker :: (a -> Failing b) -> (Failing a -> Failing b)
         checker f (Failure x) = Failure x
         checker f (Success x) = f x

-- | Component: an input field with an optional value
input :: Maybe String -> Form String
input = input' (\n v -> X.textfield n ! [X.value v])

-- | Component: a password field with an optional value
password :: Maybe String -> Form String
password = input' (\n v -> X.password n ! [X.value v])

-- | A trivially validated input component
inputF :: Maybe String -> FailingForm String
inputF = validate . input

-- | A trivially validated password component
passwordF :: Maybe String -> FailingForm String
passwordF = validate . password

-- | A validated integer component
inputIntegerF :: Maybe Integer -> FailingForm Integer
inputIntegerF x = validate (input $ fmap show x) `check` asInteger