diff --git a/README b/README --- a/README +++ b/README @@ -5,5 +5,6 @@ * Eelco Lempsink * Jeremy Shaw * Judah Jacobson +* Jasper Van der Jeugt The formlets repository is hosted on github: http://github.com/chriseidhof/formlets/ diff --git a/Text/Blaze/Html5/Formlets.hs b/Text/Blaze/Html5/Formlets.hs new file mode 100644 --- /dev/null +++ b/Text/Blaze/Html5/Formlets.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.Blaze.Html5.Formlets + ( input + , textarea + , password + , hidden + , inputInteger + , file + , checkbox + , radio + , enumRadio + , label + , selectHtml + , selectRaw + , select + , Html5Form + , Html5Formlet + , module Text.Formlets + ) where + +import Data.List (elemIndex) +import Text.Formlets hiding (massInput) +import Text.Blaze.Html5 ((!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Data.Monoid (mconcat) + +import Control.Applicative +import Control.Applicative.Error + +type Html5Form m a = Form H.Html m a +type Html5Formlet m a = Formlet H.Html m a + +-- | An input field with an optional value +-- +input :: Monad m => Html5Formlet m String +input = input' $ \n v -> H.input ! A.type_ "text" + ! A.name (H.stringValue n) + ! A.id (H.stringValue n) + ! A.value (H.stringValue v) + +-- | A textarea with optional rows and columns, and an optional value +-- +textarea :: Monad m => Maybe Int -> Maybe Int -> Html5Formlet m String +textarea r c = input' $ \n v -> (applyAttrs n H.textarea) (H.string v) + where + applyAttrs n = (! A.name (H.stringValue n)) . rows r . cols c + rows = maybe id $ \x -> (! A.rows (H.stringValue $ show x)) + cols = maybe id $ \x -> (! A.cols (H.stringValue $ show x)) + +-- | A password field with an optional value +-- +password :: Monad m => Html5Formlet m String +password = input' $ \n v -> H.input ! A.type_ "password" + ! A.name (H.stringValue n) + ! A.id (H.stringValue n) + ! A.value (H.stringValue v) + +-- | A hidden input field +-- +hidden :: Monad m => Html5Formlet m String +hidden = input' $ \n v -> H.input ! A.type_ "hidden" + ! A.name (H.stringValue n) + ! A.id (H.stringValue n) + ! A.value (H.stringValue v) + +-- | A validated integer component +-- +inputInteger :: Monad m => Html5Formlet m Integer +inputInteger x = input (fmap show x) `check` asInteger + +-- | A file upload form +-- +file :: Monad m => Html5Form m File +file = inputFile $ \n -> H.input ! A.type_ "file" + ! A.name (H.stringValue n) + ! A.id (H.stringValue n) + +-- | A checkbox with an optional default value +-- +checkbox :: Monad m => Html5Formlet m Bool +checkbox d = (optionalInput (html d)) `check` asBool + where + asBool (Just _) = Success True + asBool Nothing = Success False + html (Just True) n = H.input ! A.type_ "checkbox" + ! A.name (H.stringValue n) + ! A.id (H.stringValue n) + ! A.value "on" + ! A.checked "checked" + html _ n = H.input ! A.type_ "checkbox" + ! A.name (H.stringValue n) + ! A.id (H.stringValue n) + ! A.value "on" + +-- | A radio choice +-- +radio :: Monad m => [(String, String)] -> Html5Formlet m String +radio choices = input' $ \n v -> + mconcat $ map (makeRadio n v) $ zip choices [1 :: Integer ..] + -- todo: validate that the result was in the choices + where + makeRadio name selected ((value, label'), idx) = do + applyAttrs (radio' name value id') + H.label ! A.for (H.stringValue id') + ! A.class_ "radio" + $ H.string label' + where + applyAttrs | selected == value = (! A.checked "checked") + | otherwise = id + id' = name ++ "_" ++ show idx + + radio' n v i = H.input ! A.type_ "radio" + ! A.name (H.stringValue n) + ! A.id (H.stringValue i) + ! A.class_ "radio" + ! A.value (H.stringValue v) + +-- | An radio choice for Enums +-- +enumRadio :: (Monad m, Enum a) => [(a, String)] -> Html5Formlet m a +enumRadio values defaultValue = + radio (map toS values) (show . fromEnum <$> defaultValue) + `check` convert `check` tryToEnum + where + toS = fmapFst (show . fromEnum) + convert v = maybeRead' v "Conversion error" + +-- | A label +-- +label :: Monad m => String -> Form H.Html m () +label = xml . H.label . H.string + +-- | This is a helper function to generate select boxes +-- +selectHtml :: [(String, H.Html)] -- ^ The values and their labels + -> String -- ^ The name + -> String -- ^ The value that is selected + -> H.Html +selectHtml choices name selected = + H.select ! A.name (H.stringValue name) + $ mconcat $ map makeChoice choices + where + makeChoice (value, label') = applyAttrs $ + H.option ! A.value (H.stringValue value) $ label' + where + applyAttrs | selected == value = (! A.selected "selected") + | otherwise = id + +-- | A drop-down for selecting values +-- +selectRaw :: (Monad m) + => [(String, H.Html)] -- ^ Pairs of value/label + -> Html5Formlet m String -- ^ Resulting formlet +selectRaw = input' . selectHtml -- todo: validate that result was in choices + +-- | A drop-down for anything that is an instance of Eq +-- +select :: (Eq a, Monad m) + => [(a, H.Html)] -- ^ Pairs of value/label + -> Html5Formlet m a -- ^ Resulting formlet +select ls v = selectRaw (map f $ zip [0 :: Integer ..] ls) selected + `check` asInt `check` convert + where + selected = show <$> (v >>= flip elemIndex (map fst ls)) + f (idx, (_,l)) = (show idx, l) + convert i | i >= length ls || i < 0 = Failure ["Out of bounds"] + | otherwise = Success $ fst $ ls !! i + asInt s = maybeRead' s (s ++ " is not a valid int") diff --git a/formlets.cabal b/formlets.cabal --- a/formlets.cabal +++ b/formlets.cabal @@ -1,5 +1,5 @@ Name: formlets -Version: 0.7.2 +Version: 0.7.3 Synopsis: Formlets implemented in Haskell Description: A modular way to build forms based on applicative functors, based on the work described in: @@ -25,7 +25,8 @@ mtl, xhtml, applicative-extras >= 0.1.3, - bytestring + bytestring, + blaze-html >= 0.2 if flag(base4) Build-Depends: base >= 4 && < 5, syb else @@ -35,6 +36,7 @@ , Text.Formlets.MassInput , Text.XHtml.Strict.Formlets , Text.XHtml.Transitional.Formlets + , Text.Blaze.Html5.Formlets Other-Modules: Text.Formlets.FormResult