digestive-functors-blaze 0.2.1.0 → 0.3.0.0

raw patch · 2 files changed

+131/−322 lines, 2 filesdep ~digestive-functorsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: digestive-functors

API changes (from Hackage documentation)

Files

• digestive-functors-blaze.cabal +9/−12
• src/Text/Digestive/Blaze/Html5.hs +122/−310

@@ -1,8 +1,7 @@ Name:          digestive-functors-blaze-Version:       0.2.1.0+Version:       0.3.0.0 Synopsis:      Blaze frontend for the digestive-functors library-Description:   This is a blaze frontend for the digestive-functors library.-+Description:   Blaze frontend for the digestive-functors library Homepage:      http://github.com/jaspervdj/digestive-functors License:       BSD3 License-file:  LICENSE@@ -13,14 +12,12 @@ Cabal-version: >= 1.6  Library-  Hs-source-dirs: src-  GHC-options:    -Wall -fwarn-tabs--  Exposed-modules:-    Text.Digestive.Blaze.Html5+  Hs-source-dirs:  src+  GHC-options:     -Wall -fwarn-tabs+  Exposed-modules: Text.Digestive.Blaze.Html5    Build-depends:-    base               >= 4     && < 5,-    digestive-functors >= 0.1.0 && < 0.3,-    blaze-html         >= 0.4   && < 0.6,-    text               >= 0.11  && < 0.12+    base               >= 4    && < 5,+    digestive-functors >= 0.3  && < 0.4,+    blaze-html         >= 0.4  && < 0.6,+    text               >= 0.11 && < 0.12

@@ -1,344 +1,156 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs, OverloadedStrings #-} module Text.Digestive.Blaze.Html5-    ( BlazeFormHtml-    , inputText-    , inputText'-    , inputHidden-    , inputHidden'+    ( inputText     , inputTextArea-    , inputTextArea'-    , inputTextRead     , inputPassword-    , inputPassword'-    , inputCheckBox+    , inputHidden+    , inputSelect     , inputRadio+    , inputCheckbox     , inputFile-    , inputSelect-    , submit+    , inputSubmit     , label-    , errors-    , childErrors-    , inputList-    , inputListJs-    , module Text.Digestive.Forms.Html+    , form+    , errorList+    , childErrorList     ) where -import Control.Monad (forM_, unless, when) import Data.Maybe (fromMaybe)-import Data.Monoid (mempty)-import Data.String (IsString(..))-import Data.Text (Text)+import Data.Monoid (mappend, mempty)+import Control.Monad (forM_, when) -import Text.Blaze (Attribute)-import Text.Blaze.Html5 (Html, (!), toValue, toHtml)+import Data.Text (Text)+import Text.Blaze.Internal as H 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_ (toValue value)---- | Applies an attribute to some HTML, but only if an associated--- boolean value is true.-attrWhenTrue :: Attribute -> Bool -> Html -> Html-attrWhenTrue a True  h = h ! a-attrWhenTrue _ False h = h---- | Checks the input element when the argument is true-checked :: Bool -> Html -> Html-checked = attrWhenTrue (A.checked "checked")---- | Selects an @<option>@ when the argument is true.-selected :: Bool -> Html -> Html-selected = attrWhenTrue (A.selected "selected")--inputText :: (Monad m, Functor m, FormInput i f)-          => Formlet m i e BlazeFormHtml Text-inputText = Forms.inputText inputTextHTML--inputText' :: (Monad m, Functor m, FormInput i f)-           => Formlet m i e BlazeFormHtml String-inputText' = Forms.inputString inputTextHTML--inputTextHTML :: (H.ToValue b, IsString b, Show a)-              => a -> Maybe b -> FormHtml Html-inputTextHTML id' inp = createFormHtml $ \cfg ->-    applyClasses' [htmlInputClasses] cfg $-        H.input ! A.type_ "text"-                ! A.name (toValue $ show id')-                ! A.id (toValue $ show id')-                ! A.value (toValue $ fromMaybe "" inp)--inputHidden :: (Monad m, Functor m, FormInput i f)-            => Formlet m i e BlazeFormHtml Text-inputHidden = Forms.inputText inputHiddenHTML--inputHidden' :: (Monad m, Functor m, FormInput i f)-             => Formlet m i e BlazeFormHtml String-inputHidden' = Forms.inputString inputHiddenHTML--inputHiddenHTML :: (H.ToValue b, IsString b, Show a)-                => a -> Maybe b -> FormHtml Html-inputHiddenHTML id' inp = createFormHtml $ \cfg ->-    applyClasses' [htmlInputClasses] cfg $-        H.input ! A.type_ "hidden"-                ! A.name (toValue $ show id')-                ! A.id (toValue $ show id')-                ! A.value (toValue $ fromMaybe "" inp)+import Text.Digestive.View -inputTextArea :: (Monad m, Functor m, FormInput i f)-              => Maybe Int                        -- ^ Rows-              -> Maybe Int                        -- ^ Columns-              -> Maybe Text                       -- ^ Default input-              -> Form m i e BlazeFormHtml Text    -- ^ Result-inputTextArea r c = Forms.inputText $ inputTextAreaHTML r c+(!?) :: H.Attributable h => h -> (Bool, H.Attribute) -> h+(!?) h (False, _) = h+(!?) h (True,  a) = h ! a -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 $ inputTextAreaHTML r c+absoluteRef :: Text -> View v -> Text+absoluteRef ref view = fromPath $ absolutePath ref view -inputTextAreaHTML :: (H.ToHtml d, IsString d, Show b, Show c, Show a)-                  => Maybe a -> Maybe b -> c -> Maybe d -> FormHtml Html-inputTextAreaHTML r c id' inp = createFormHtml $ \cfg ->-    applyClasses' [htmlInputClasses] cfg $ rows r $ cols c $-        H.textarea ! A.name (toValue $ show id')-                   ! A.id (toValue $ show id')-                   $ toHtml $ fromMaybe "" inp+label :: Text -> View v -> Html -> Html+label ref view value = H.label+    ! A.for (H.toValue ref')+    $ value   where-    rows Nothing = id-    rows (Just x) = (! A.rows (toValue $ show x))-    cols Nothing = id-    cols (Just x) = (! A.cols (toValue $ 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 (toValue $ show id')-                ! A.id (toValue $ show id')-                ! A.value (toValue $ fromMaybe "" inp)--inputPassword :: (Monad m, Functor m, FormInput i f)-              => Bool                                 -- ^ Retain input?-              -> Form m i e BlazeFormHtml Text        -- ^ Resulting form-inputPassword retain = Forms.inputText (inputPasswordHTML retain) Nothing--inputPassword' :: (Monad m, Functor m, FormInput i f)-               => Bool                                -- ^ Retain input?-               -> Form m i e BlazeFormHtml String     -- ^ Resulting form-inputPassword' retain = Forms.inputString (inputPasswordHTML retain) Nothing+    ref' = absoluteRef ref view -inputPasswordHTML :: (H.ToValue b, IsString b, Show a)-                  => Bool -> a -> Maybe b -> FormHtml Html-inputPasswordHTML retain id' inp =-    createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $-        H.input ! A.type_ "password"-                ! A.name (toValue $ show id')-                ! A.id (toValue $ show id')-                ! A.value (toValue value)+inputText :: Text -> View v -> Html+inputText ref view = H.input+    ! A.type_ "text"+    ! A.id    (H.toValue ref')+    ! A.name  (H.toValue ref')+    ! A.value (H.toValue $ fieldInputText ref view)   where-    value = if retain then fromMaybe "" inp else ""+    ref' = absoluteRef ref view -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 (toValue $ show id')-                               ! A.id (toValue $ show id')+inputTextArea :: Maybe Int  -- ^ Rows+              -> Maybe Int  -- ^ Columns+              -> Text       -- ^ Form path+              -> View Html  -- ^ View+              -> Html       -- ^ Resulting HTML+inputTextArea r c ref view = rows r $ cols c $ H.textarea+    ! A.id     (H.toValue ref')+    ! A.name   (H.toValue ref')+    $ H.toHtml (fieldInputText ref view)+  where+    ref'          = absoluteRef ref view+    rows (Just x) = (! A.rows (H.toValue x))+    rows _        = id+    cols (Just x) = (! A.cols (H.toValue x))+    cols _        = id -inputRadio :: (Monad m, Functor m, FormInput i f, Eq a)-           => Bool                        -- ^ Use @<br>@ 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)+inputPassword :: Text -> View v -> Html+inputPassword ref view = H.input+    ! A.type_ "password"+    ! A.id    (H.toValue ref')+    ! A.name  (H.toValue ref')+    ! A.value (H.toValue $ fieldInputText ref view)   where-    toView group id' sel val = createFormHtml $ \cfg -> do-        applyClasses' [htmlInputClasses] cfg $ checked sel $-            H.input ! A.type_ "radio"-                    ! A.name (toValue $ show group)-                    ! A.value (toValue id')-                    ! A.id (toValue id')-        H.label ! A.for (toValue id')-                $ fromMaybe mempty $ lookup val choices-        when br H.br+    ref' = absoluteRef ref view -inputSelect :: (Monad m, Functor m, FormInput i f, Eq a)-            => a                           -- ^ Default option-            -> [(a, Html)]                 -- ^ Choices with their names-            -> Form m i e BlazeFormHtml a  -- ^ Resulting form-inputSelect def choices = Form $ do-    id' <- getFormId-    unForm $ mapViewHtml (H.select ! A.name (toValue $ show id') ) $-        Forms.inputChoice toView def (map fst choices)+inputHidden :: Text -> View v -> Html+inputHidden ref view = H.input+    ! A.type_ "hidden"+    ! A.id    (H.toValue ref')+    ! A.name  (H.toValue ref')+    ! A.value (H.toValue $ fieldInputText ref view)   where-    toView _ id' sel val = createFormHtml $ \cfg -> do-        applyClasses' [htmlInputClasses] cfg $ selected sel $-            H.option ! A.type_ "radio"-                     ! A.value (toValue id')-                     $ fromMaybe mempty $ lookup val choices+    ref' = absoluteRef ref view -inputFile :: (Monad m, Functor m, FormInput i f)-          => Form m i e BlazeFormHtml (Maybe f)  -- ^ Form-inputFile = Forms.inputFile toView+inputSelect :: Text -> View Html -> Html+inputSelect ref view = H.select+    ! A.id    (H.toValue ref')+    ! A.name  (H.toValue ref')+    $ forM_ (zip choices [0 ..]) $ \(c, i) -> H.option+        !  A.value (value i)+        !? (i == idx, A.selected "selected")+        $ c   where-    toView id' = createFormHtmlWith MultiPart $ \cfg ->-        applyClasses' [htmlInputClasses] cfg $-            H.input ! A.type_ "file"-                    ! A.name (toValue $ show id')-                    ! A.id (toValue $ show id')+    ref'           = absoluteRef ref view+    value i        = H.toValue ref' `mappend` "." `mappend` H.toValue i+    (choices, idx) = fieldInputChoice ref view -submit :: Monad m-       => String                       -- ^ Text on the submit button-       -> Form m i e BlazeFormHtml ()  -- ^ Submit button-submit text = view $ createFormHtml $ \cfg ->-    applyClasses' [htmlInputClasses, htmlSubmitClasses] cfg $-        H.input ! A.type_ "submit"-                ! A.value (toValue text)+inputRadio :: Bool       -- ^ Add @br@ tags?+           -> Text       -- ^ Form path+           -> View Html  -- ^ View+           -> Html       -- ^ Resulting HTML+inputRadio brs ref view = forM_ (zip choices [0 ..]) $ \(c, i) -> do+    let val = value i+    H.input ! A.type_ "radio" ! A.value val ! A.id val ! A.name (H.toValue ref')+        !? (i == idx, A.checked "checked")+    H.label ! A.for val $ c+    when brs H.br+  where+    ref'           = absoluteRef ref view+    value i        = H.toValue ref' `mappend` "." `mappend` H.toValue i+    (choices, idx) = fieldInputChoice ref view -label :: Monad m-      => String-      -> Form m i e BlazeFormHtml ()-label string = Common.label $ \id' -> createFormHtml $ \cfg ->-    applyClasses' [htmlLabelClasses] cfg $-        H.label ! A.for (toValue $ show id')-                $ toHtml string+inputCheckbox :: Text -> View Html -> Html+inputCheckbox ref view = H.input+    !  A.type_ "checkbox"+    !  A.id    (H.toValue ref')+    !  A.name  (H.toValue ref')+    !? (selected, A.checked "checked")+  where+    ref'     = absoluteRef ref view+    selected = fieldInputBool ref view -errorList :: [Html] -> BlazeFormHtml-errorList errors' = createFormHtml $ \cfg -> unless (null errors') $-    applyClasses' [htmlErrorListClasses] cfg $-        H.ul $ forM_ errors' $ applyClasses' [htmlErrorClasses] cfg . H.li+inputFile :: Text -> View Html -> Html+inputFile ref view = H.input+    ! A.type_ "file"+    ! A.id    (H.toValue ref')+    ! A.name  (H.toValue ref')+    ! A.value (H.toValue value)+  where+    ref'  = absoluteRef ref view+    value = fromMaybe "" $ fieldInputFile ref view -errors :: Monad m-       => Form m i Html BlazeFormHtml ()-errors = Common.errors errorList+inputSubmit :: Text -> Html+inputSubmit value = H.input+    ! A.type_ "submit"+    ! A.value (H.toValue value) -childErrors :: Monad m-            => Form m i Html BlazeFormHtml ()-childErrors = Common.childErrors errorList+form :: View Html -> Text -> Html -> Html+form view action = H.form+    ! A.method  "POST"+    ! A.enctype (H.toValue $ show $ viewEncType view)+    ! A.action  (H.toValue action) --- | Wraps the more generic 'Text.Digestive.Forms.inputList' function to--- provide a reasonable default for adding add/remove controls to a form.--- The whole thing is wrapped in another div with the class inputList.  For--- this function to work, the javascript code in 'inputListJs' or something--- similar must be in scope.------ The user needs to specify the hidden formlet because transformRead requires--- an error parameter, and this function can't specify it without loss of--- generality.  The idea is that the extra power of being able to customize--- the formlet is worth the small amount of extra code compared to having to--- specify the error.----inputList :: (Monad m, Functor m, FormInput i f)-          => Formlet m i e BlazeFormHtml Int-          -- ^ The formlet holding the number of items in the list-          -> Formlet m i e BlazeFormHtml a-          -- ^ The formlet used for each list item.  This function surrounds it-          -- with a div tag with the inputListItem class.-          -> Formlet m i e BlazeFormHtml [a]-          -- ^ The dynamic list formlet-inputList hidden single d =-    mapView (fmap addControls) $ Forms.inputList hidden s d-  where-    s def = mapView (fmap (H.div ! A.class_ "inputListItem")) $ single def-    addControls form =-        H.div ! A.class_ "inputList" $ do-            H.div $ do-                H.input ! A.type_ "button"-                        ! A.onclick "addItem(this); return false;"-                        ! A.value "Add Item"-                H.input ! A.type_ "button"-                        ! A.onclick "removeItem(this); return false;"-                        ! A.value "Remove Item"-            form+errorList :: Text -> View Html -> Html+errorList ref view = case errors ref view of+    []   -> mempty+    errs -> H.ul ! A.class_ "digestive-functors-error-list" $ forM_ errs $ \e ->+        H.li ! A.class_ "digestive-functors-error" $ e --- | A string containing the javascript functions needed for inputList.  This--- code requires JQuery.----inputListJs :: String-inputListJs = unlines-    ["// Requires that JQuery also be in scope"-    ,"function findInputList(button) {"-    ,"  var mainDiv = $(button).parent();"-    ,"  while ( !mainDiv.hasClass('inputList') ) {"-    ,"    mainDiv = $(mainDiv).parent();"-    ,"  }"-    ,"  return mainDiv;"-    ,"}"-    ,""-    ,"function findItems(button) {"-    ,"  return $('.inputListItem', findInputList(button));"-    ,"}"-    ,""-    ,"function addItem(button) {"-    ,"  var count = $(':hidden', findInputList(button))[0];"-    ,"  var items = findItems(button);"-    ,"  var item = $(items[items.length-1]);"-    ,"  var newItem = item.clone(true);"-    ,"  var i;"-    ,""-    ,"  // Increment counter"-    ,"  $(count).val(parseInt($(count).val())+1);"-    ,""-    ,"  // We have to change the raw html because IE doesn't allow the"-    ,"  // name field to be changed."-    ,"  newItem.html(newItem.html().replace(/fval\\[(\\d+\\.)*(\\d+)\\.(\\d+)\\]/g,"-    ,"    function(a, b, c, d) {"-    ,"      var newC = parseInt(c)+1;"-    ,"      return a.replace(/\\d+\\.\\d+\\]/, newC+'.'+d+']');"-    ,"    }"-    ,"  ));"-    ,"  newItem.appendTo(item.parent());"-    ,""-    ,"  // Copy the values of all children that had the name attribute set."-    ,"  // The direct html insertion does not preserve the most current"-    ,"  // values.  It only preserves default values, so if we want values"-    ,"  // copied, we have to use an approach like this."-    ,"  var items2 = findItems(button);"-    ,"  var newLast = $(items2[items2.length-1]);"-    ,"  var c1 = $('[name]', item);"-    ,"  var c2 = $('[name]', newLast);"-    ,"  if ( c1.length == c2.length ) {"-    ,"    for ( i = 0; i < c1.length; i++ ) {"-    ,"      $(c2[i]).val($(c1[i]).val());"-    ,"    }"-    ,"  }"-    ,"}"-    ,""-    ,"function removeItem(button) {"-    ,"  var items = findItems(button);"-    ,"  if ( items.length > 1 ) {"-    ,"    var count = $(':hidden', findInputList(button))[0];"-    ,"    var item = $(items[items.length-1]);"-    ,"    item.remove();"-    ,""-    ,"    // Decrement counter"-    ,"    $(count).val(parseInt($(count).val())-1);"-    ,"  } else {"-    ,"    alert('Cannot remove any more rows');"-    ,"  }"-    ,"}"-    ]+childErrorList :: Text -> View Html -> Html+childErrorList ref view = case childErrors ref view of+    []   -> mempty+    errs -> H.ul ! A.class_ "digestive-functors-error-list" $ forM_ errs $ \e ->+        H.li ! A.class_ "digestive-functors-error" $ e