diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2010, Jasper Van der Jeugt +  +All rights reserved. +  +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +  +    * Redistributions of source code must retain the above copyright +      notice, this list of conditions and the following disclaimer. +  +    * Redistributions in binary form must reproduce the above +      copyright notice, this list of conditions and the following +      disclaimer in the documentation and/or other materials provided +      with the distribution. +  +    * Neither the name of Jasper Van der Jeugt nor the names of other +      contributors may be used to endorse or promote products derived +      from this software without specific prior written permission. +  +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/digestive-functors-blaze.cabal b/digestive-functors-blaze.cabal new file mode 100644 --- /dev/null +++ b/digestive-functors-blaze.cabal @@ -0,0 +1,21 @@ +Name: digestive-functors-blaze +Version: 0.0.2.0 +Synopsis: Snap backend for the digestive-functors library +Description: This is a blaze frontend for the digestive-functors library. + +Homepage: http://github.com/jaspervdj/digestive-functors +License: BSD3 +License-file: LICENSE +Author: Jasper Van der Jeugt +Maintainer: jaspervdj@gmail.com +Category: Web +Build-type: Simple +Cabal-version: >=1.6 + + +Library + Hs-source-dirs: src + Exposed-modules: Text.Digestive.Blaze.Html5 + Build-depends: base >= 4 && < 5, + digestive-functors == 0.0.2.*, + blaze-html >= 0.3 && < 0.4 diff --git a/src/Text/Digestive/Blaze/Html5.hs b/src/Text/Digestive/Blaze/Html5.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Blaze/Html5.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.Digestive.Blaze.Html5 + ( BlazeFormHtml + , inputText + , inputTextArea + , inputTextRead + , inputPassword + , inputCheckBox + , inputRadio + , inputFile + , submit + , label + , errors + , childErrors + , module Text.Digestive.Forms.Html + ) where + +import Control.Monad (forM_, unless, when) +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty) + +import Text.Blaze.Html5 (Html, (!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +import Text.Digestive.Types +import Text.Digestive.Forms (FormInput (..)) +import qualified Text.Digestive.Forms as Forms +import qualified Text.Digestive.Common as Common +import Text.Digestive.Forms.Html + +-- | Form HTML generated by blaze +-- +type BlazeFormHtml = FormHtml Html + +-- | 'applyClasses' instantiated for blaze +-- +applyClasses' :: [FormHtmlConfig -> [String]] -- ^ Labels to apply + -> FormHtmlConfig -- ^ Label configuration + -> Html -- ^ HTML element + -> Html -- ^ Resulting element +applyClasses' = applyClasses $ \element value -> + element ! A.class_ (H.stringValue value) + +-- | Checks the input element when the argument is true +-- +checked :: Bool -> Html -> Html +checked False x = x +checked True x = x ! A.checked "checked" + +inputText :: (Monad m, Functor m, FormInput i f) + => Maybe String + -> Form m i e BlazeFormHtml String +inputText = Forms.inputString $ \id' inp -> createFormHtml $ \cfg -> + applyClasses' [htmlInputClasses] cfg $ + H.input ! A.type_ "text" + ! A.name (H.stringValue $ show id') + ! A.id (H.stringValue $ show id') + ! A.value (H.stringValue $ fromMaybe "" inp) + +inputTextArea :: (Monad m, Functor m, FormInput i f) + => Maybe Int -- ^ Rows + -> Maybe Int -- ^ Columns + -> Maybe String -- ^ Default input + -> Form m i e BlazeFormHtml String -- ^ Result +inputTextArea r c = Forms.inputString $ \id' inp -> createFormHtml $ \cfg -> + applyClasses' [htmlInputClasses] cfg $ rows r $ cols c $ + H.textarea ! A.name (H.stringValue $ show id') + ! A.id (H.stringValue $ show id') + $ H.string $ fromMaybe "" inp + where + rows Nothing = id + rows (Just x) = (! A.rows (H.stringValue $ show x)) + cols Nothing = id + cols (Just x) = (! A.cols (H.stringValue $ show x)) + +inputTextRead :: (Monad m, Functor m, FormInput i f, Show a, Read a) + => e + -> Maybe a + -> Form m i e BlazeFormHtml a +inputTextRead error' = flip Forms.inputRead error' $ \id' inp -> + createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $ + H.input ! A.type_ "text" + ! A.name (H.stringValue $ show id') + ! A.id (H.stringValue $ show id') + ! A.value (H.stringValue $ fromMaybe "" inp) + +inputPassword :: (Monad m, Functor m, FormInput i f) + => Form m i e BlazeFormHtml String +inputPassword = flip Forms.inputString Nothing $ \id' inp -> + createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $ + H.input ! A.type_ "password" + ! A.name (H.stringValue $ show id') + ! A.id (H.stringValue $ show id') + ! A.value (H.stringValue $ fromMaybe "" inp) + +inputCheckBox :: (Monad m, Functor m, FormInput i f) + => Bool + -> Form m i e BlazeFormHtml Bool +inputCheckBox inp = flip Forms.inputBool inp $ \id' inp' -> + createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $ + checked inp' $ H.input ! A.type_ "checkbox" + ! A.name (H.stringValue $ show id') + ! A.id (H.stringValue $ show id') + +inputRadio :: (Monad m, Functor m, FormInput i f, Eq a) + => Bool -- ^ Use @
@ tags + -> a -- ^ Default option + -> [(a, Html)] -- ^ Choices with their names + -> Form m i e BlazeFormHtml a -- ^ Resulting form +inputRadio br def choices = Forms.inputChoice toView def (map fst choices) + where + toView group id' sel val = createFormHtml $ \cfg -> do + applyClasses' [htmlInputClasses] cfg $ checked sel $ + H.input ! A.type_ "radio" + ! A.name (H.stringValue $ show group) + ! A.value (H.stringValue id') + ! A.id (H.stringValue id') + H.label ! A.for (H.stringValue id') + $ fromMaybe mempty $ lookup val choices + when br H.br + +inputFile :: (Monad m, Functor m, FormInput i f) + => Form m i e BlazeFormHtml (Maybe f) -- ^ Form +inputFile = Forms.inputFile toView + where + toView id' = createFormHtmlWith MultiPart $ \cfg -> do + applyClasses' [htmlInputClasses] cfg $ + H.input ! A.type_ "file" + ! A.name (H.stringValue $ show id') + ! A.id (H.stringValue $ show id') + +submit :: Monad m + => String -- ^ Text on the submit button + -> Form m String e BlazeFormHtml () -- ^ Submit button +submit text = view $ createFormHtml $ \cfg -> + applyClasses' [htmlInputClasses, htmlSubmitClasses] cfg $ + H.input ! A.type_ "submit" + ! A.value (H.stringValue text) + +label :: Monad m + => String + -> Form m i e BlazeFormHtml () +label string = Common.label $ \id' -> createFormHtml $ \cfg -> + applyClasses' [htmlLabelClasses] cfg $ + H.label ! A.for (H.stringValue $ show id') + $ H.string string + +errorList :: [Html] -> BlazeFormHtml +errorList errors' = createFormHtml $ \cfg -> unless (null errors') $ + applyClasses' [htmlErrorListClasses] cfg $ + H.ul $ forM_ errors' $ applyClasses' [htmlErrorClasses] cfg . H.li + +errors :: Monad m + => Form m i Html BlazeFormHtml () +errors = Common.errors errorList + +childErrors :: Monad m + => Form m i Html BlazeFormHtml () +childErrors = Common.childErrors errorList