digestive-functors-lucid (empty) → 0.0.0.1
raw patch · 4 files changed
+244/−0 lines, 4 filesdep +basedep +digestive-functorsdep +lucidsetup-changed
Dependencies added: base, digestive-functors, lucid, text
Files
- LICENSE +31/−0
- Setup.hs +2/−0
- digestive-functors-lucid.cabal +23/−0
- src/Text/Digestive/Lucid/Html5.hs +188/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ digestive-functors-lucid.cabal view
@@ -0,0 +1,23 @@+Name: digestive-functors-lucid+Version: 0.0.0.1+Synopsis: Lucid frontend for the digestive-functors library+Description: Ludic frontend for the digestive-functors library+Homepage: http://github.com/jaspervdj/digestive-functors+License: BSD3+License-file: LICENSE+Author: Athan Clark <athan.clark@gmail.com>+Maintainer: Athan Clark <athan.clark@gmail.com>+Category: Web+Build-type: Simple+Cabal-version: >= 1.6++Library+ Hs-source-dirs: src+ GHC-options: -Wall -fwarn-tabs+ Exposed-modules: Text.Digestive.Lucid.Html5++ Build-depends:+ base >= 4 && < 5,+ lucid >= 2.9,+ digestive-functors >= 0.6 && < 0.8,+ text >= 0.11 && < 1.2
+ src/Text/Digestive/Lucid/Html5.hs view
@@ -0,0 +1,188 @@+--------------------------------------------------------------------------------+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+module Text.Digestive.Lucid.Html5+ ( inputText+ , inputTextArea+ , inputPassword+ , inputHidden+ , inputSelect+ , inputRadio+ , inputCheckbox+ , inputFile+ , inputSubmit+ , label+ , form+ , errorList+ , childErrorList+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (forM_, when)+import Data.Maybe (fromMaybe)+import Data.Monoid (mappend, mempty)+import Data.Text (Text, pack)+import Lucid+import Lucid.Base++--------------------------------------------------------------------------------+import Text.Digestive.View+++--------------------------------------------------------------------------------+ifSingleton :: Bool -> a -> [a]+ifSingleton False _ = []+ifSingleton True a = [a]++--------------------------------------------------------------------------------+inputText :: Text -> View v -> Html ()+inputText ref view = input_+ [ type_ "text"+ , id_ ref'+ , name_ ref'+ , value_ $ fieldInputText ref view+ ]+ where+ ref' = absoluteRef ref view+++--------------------------------------------------------------------------------+inputTextArea :: Maybe Int -- ^ Rows+ -> Maybe Int -- ^ Columns+ -> Text -- ^ Form path+ -> View (Html ()) -- ^ View+ -> Html () -- ^ Resulting HTML+inputTextArea r c ref view = textarea_+ ([ id_ ref'+ , name_ ref'+ ] ++ (rows' r) ++ (cols' c)) $+ toHtmlRaw $ fieldInputText ref view+ where+ ref' = absoluteRef ref view+ rows' (Just x) = [rows_ $ pack $ show x]+ rows' _ = []+ cols' (Just x) = [cols_ $ pack $ show x]+ cols' _ = []+++--------------------------------------------------------------------------------+inputPassword :: Text -> View v -> Html ()+inputPassword ref view = input_+ [ type_ "password"+ , id_ ref'+ , name_ ref'+ , value_ $ fieldInputText ref view+ ]+ where+ ref' = absoluteRef ref view+++--------------------------------------------------------------------------------+inputHidden :: Text -> View v -> Html ()+inputHidden ref view = input_+ [ type_ "hidden"+ , id_ ref'+ , name_ ref'+ , value_ $ fieldInputText ref view+ ]+ where+ ref' = absoluteRef ref view+++--------------------------------------------------------------------------------+inputSelect :: Text -> View (Html ()) -> Html ()+inputSelect ref view = select_+ [ id_ ref'+ , name_ ref'+ ] $ forM_ choices $ \(i, c, sel) -> option_+ ([value_ (value i)] ++ (ifSingleton sel $ selected_ "selected")) c+ where+ ref' = absoluteRef ref view+ value i = ref' `mappend` "." `mappend` i+ choices = fieldInputChoice ref view+++--------------------------------------------------------------------------------+inputRadio :: Bool -- ^ Add @br@ tags?+ -> Text -- ^ Form path+ -> View (Html ()) -- ^ View+ -> Html () -- ^ Resulting HTML+inputRadio brs ref view = forM_ choices $ \(i, c, sel) -> do+ let val = value i+ input_ $ [type_ "radio", value_ val, id_ val, name_ ref']+ ++ (ifSingleton sel checked_)+ label_ [for_ val] c+ when brs (br_ [])+ where+ ref' = absoluteRef ref view+ value i = ref' `mappend` "." `mappend` i+ choices = fieldInputChoice ref view+++--------------------------------------------------------------------------------+inputCheckbox :: Text -> View (Html ()) -> Html ()+inputCheckbox ref view = input_ $+ [ type_ "checkbox"+ , id_ ref'+ , name_ ref'+ ] ++ (ifSingleton selected checked_)+ where+ ref' = absoluteRef ref view+ selected = fieldInputBool ref view+++--------------------------------------------------------------------------------+inputFile :: Text -> View (Html ()) -> Html ()+inputFile ref view = input_+ [ type_ "file"+ , id_ ref'+ , name_ ref'+ , value_ $ pack value+ ]+ where+ ref' = absoluteRef ref view+ value = fromMaybe "" $ fieldInputFile ref view+++--------------------------------------------------------------------------------+inputSubmit :: Text -> Html ()+inputSubmit value = input_+ [ type_ "submit"+ , value_ value+ ]+++--------------------------------------------------------------------------------+label :: Text -> View v -> Html () -> Html ()+label ref view value = label_+ [ for_ ref'+ ] $ value+ where+ ref' = absoluteRef ref view+++--------------------------------------------------------------------------------+form :: View (Html ()) -> Text -> Html () -> Html ()+form view action = form_+ [ method_ "POST"+ , enctype_ (pack $ show $ viewEncType view)+ , action_ action+ ]+++--------------------------------------------------------------------------------+errorList :: Text -> View (Html ()) -> Html ()+errorList ref view = case errors ref view of+ [] -> mempty+ errs -> ul_ [class_ "digestive-functors-error-list"] $ forM_ errs $ \e ->+ li_ [class_ "digestive-functors-error"] e+++--------------------------------------------------------------------------------+childErrorList :: Text -> View (Html ()) -> Html ()+childErrorList ref view = case childErrors ref view of+ [] -> mempty+ errs -> ul_ [class_ "digestive-functors-error-list"] $ forM_ errs $ \e ->+ li_ [class_ "digestive-functors-error"] e