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-heist.cabal b/digestive-functors-heist.cabal new file mode 100644 --- /dev/null +++ b/digestive-functors-heist.cabal @@ -0,0 +1,24 @@ +Name: digestive-functors-heist +Version: 0.3.0.0 +Synopsis: Heist frontend for the digestive-functors library +Description: Heist frontend for the digestive-functors library +Homepage: http://github.com/jaspervdj/digestive-functors +License: BSD3 +License-file: LICENSE +Author: Jasper Van der Jeugt +Maintainer: Jasper Van der Jeugt +Category: Web +Build-type: Simple +Cabal-version: >= 1.6 + +Library + Hs-source-dirs: src + GHC-options: -Wall -fwarn-tabs + Exposed-modules: Text.Digestive.Heist + + Build-depends: + base >= 4 && < 5, + digestive-functors >= 0.3.0.1 && < 0.4, + heist >= 0.8 && < 0.9, + text >= 0.11 && < 0.12, + xmlhtml >= 0.1 && < 0.2 diff --git a/src/Text/Digestive/Heist.hs b/src/Text/Digestive/Heist.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Heist.hs @@ -0,0 +1,287 @@ +-- | This module provides a Heist frontend for the digestive-functors library. +-- +-- Disclaimer: this documentation requires very basic familiarity with +-- digestive-functors. You might want to take a quick look at this tutorial +-- first: +-- +-- +-- +-- This module exports the functions 'digestiveSplices' and +-- 'bindDigestiveSplices', and most users will not require anything else. +-- +-- These splices are used to create HTML for different form elements. This way, +-- the developer doesn't have to care about setting e.g. the previous values in +-- a text field when something goes wrong. +-- +-- For documentation on the different splices, see the different functions +-- exported by this module. All splices have the same name as given in +-- 'digestiveSplices'. +-- +-- You can give arbitrary attributes to most of the elements (i.e. where it +-- makes sense). This means you can do e.g.: +-- +-- > +{-# LANGUAGE OverloadedStrings #-} +module Text.Digestive.Heist + ( -- * Core methods + digestiveSplices + , bindDigestiveSplices + + -- * Splices + , dfInputText + , dfInputTextArea + , dfInputPassword + , dfInputHidden + , dfInputSelect + , dfInputRadio + , dfInputCheckbox + , dfInputSubmit + , dfLabel + , dfForm + , dfErrorList + , dfChildErrorList + , dfSubView + ) where + +import Control.Monad (liftM) +import Data.Maybe (fromMaybe) +import Data.Monoid (mappend) + +import Data.Text (Text) +import Text.Digestive.View +import Text.Templating.Heist +import qualified Data.Text as T +import qualified Text.XmlHtml as X + +bindDigestiveSplices :: Monad m => View Text -> HeistState m -> HeistState m +bindDigestiveSplices = bindSplices . digestiveSplices + +digestiveSplices :: Monad m => View Text -> [(Text, Splice m)] +digestiveSplices view = + [ ("dfInputText", dfInputText view) + , ("dfInputTextArea", dfInputTextArea view) + , ("dfInputPassword", dfInputPassword view) + , ("dfInputHidden", dfInputHidden view) + , ("dfInputSelect", dfInputSelect view) + , ("dfInputRadio", dfInputRadio view) + , ("dfInputCheckbox", dfInputCheckbox view) + , ("dfInputSubmit", dfInputSubmit view) + , ("dfLabel", dfLabel view) + , ("dfForm", dfForm view) + , ("dfErrorList", dfErrorList view) + , ("dfChildErrorList", dfChildErrorList view) + , ("dfSubView", dfSubView view) + ] + +attr :: Bool -> (Text, Text) -> [(Text, Text)] -> [(Text, Text)] +attr False _ = id +attr True a = (a :) + +makeElement :: Text -> [X.Node] -> [(Text, Text)] -> [X.Node] +makeElement name nodes = return . flip (X.Element name) nodes + +getRefAttributes :: Monad m => HeistT m (Text, [(Text, Text)]) +getRefAttributes = do + node <- getParamNode + return $ case node of + X.Element _ as _ -> + let ref = fromMaybe (error $ show node ++ ": missing ref") $ + lookup "ref" as + in (ref, filter ((/= "ref") . fst) as) + _ -> (error "Wrong type of node!", []) + +getContent :: Monad m => HeistT m [X.Node] +getContent = liftM X.childNodes getParamNode + +-- | Generate a text input field. Example: +-- +-- > +dfInputText :: Monad m => View v -> Splice m +dfInputText view = do + (ref, attrs) <- getRefAttributes + let ref' = absoluteRef ref view + value = fieldInputText ref view + return $ makeElement "input" [] $ + ("type", "text") : ("id", ref') : + ("name", ref') : ("value", value) : attrs + +-- | Generate a text area. Example: +-- +-- > +dfInputTextArea :: Monad m => View v -> Splice m +dfInputTextArea view = do + (ref, attrs) <- getRefAttributes + let ref' = absoluteRef ref view + value = fieldInputText ref view + return $ makeElement "textarea" [X.TextNode value] $ + ("id", ref') : ("name", ref') : attrs + +-- | Generate a password field. Example: +-- +-- > +dfInputPassword :: Monad m => View v -> Splice m +dfInputPassword view = do + (ref, attrs) <- getRefAttributes + let ref' = absoluteRef ref view + value = fieldInputText ref view + return $ makeElement "input" [] $ + ("type", "password") : ("id", ref') : + ("name", ref') : ("value", value) : attrs + +-- | Generate a hidden input field. Example: +-- +-- > +dfInputHidden :: Monad m => View v -> Splice m +dfInputHidden view = do + (ref, attrs) <- getRefAttributes + let ref' = absoluteRef ref view + value = fieldInputText ref view + return $ makeElement "input" [] $ + ("type", "hidden") : ("id", ref') : + ("name", ref') : ("value", value) : attrs + +-- | Generate a select button (also known as a combo box). Example: +-- +-- > +dfInputSelect :: Monad m => View Text -> Splice m +dfInputSelect view = do + (ref, attrs) <- getRefAttributes + let ref' = absoluteRef ref view + (choices, idx) = fieldInputChoice ref view + children = zipWith makeOption choices [0 ..] + value i = ref' `mappend` "." `mappend` T.pack (show i) + makeOption c i = X.Element "option" + (attr (idx == i) ("selected", "selected") [("value", value i)]) + [X.TextNode c] + return $ makeElement "select" children $ + ("id", ref') : ("name", ref') : attrs + +-- | Generate a number of radio buttons. Example: +-- +-- > +dfInputRadio :: Monad m => View Text -> Splice m +dfInputRadio view = do + (ref, attrs) <- getRefAttributes + + let ref' = absoluteRef ref view + (choices, idx) = fieldInputChoice ref view + + children = concat $ zipWith makeOption choices [0 ..] + value i = ref' `mappend` "." `mappend` T.pack (show i) + makeOption c i = + [ X.Element "input" + (attr (idx == i) ("checked", "checked") $ + ("type", "radio") : ("value", value i) : + ("id", value i) : ("name", ref') : + attrs ) [] + , X.Element "label" [("for", value i)] [X.TextNode c] + ] + + return children + +-- | Generate a checkbox. Example: +-- +-- > +dfInputCheckbox :: Monad m => View Text -> Splice m +dfInputCheckbox view = do + (ref, attrs) <- getRefAttributes + let ref' = absoluteRef ref view + value = fieldInputBool ref view + return $ makeElement "input" [] $ attr value ("checked", "checked") $ + ("type", "checkbox") : ("id", ref') : ("name", ref') : attrs + +-- | Generate a submit button. Example: +-- +-- > +dfInputSubmit :: Monad m => View v -> Splice m +dfInputSubmit _ = do + (_, attrs) <- getRefAttributes + return $ makeElement "input" [] $ ("type", "submit") : attrs + +-- | Generate a label for a field. Example: +-- +-- > Married: +-- > +dfLabel :: Monad m => View v -> Splice m +dfLabel view = do + (ref, attrs) <- getRefAttributes + content <- getContent + let ref' = absoluteRef ref view + return $ makeElement "label" content $ ("for", ref') : attrs + +-- | Generate a form tag with the @method@ attribute set to @POST@ and the +-- @enctype@ set to the right value (depending on the form). Example: +-- +-- > +-- > +-- > ... +-- > +-- > +dfForm :: Monad m => View v -> Splice m +dfForm view = do + (_, attrs) <- getRefAttributes + content <- getContent + return $ makeElement "form" content $ + ("method", "POST") : + ("enctype", T.pack (show $ viewEncType view)) : + attrs + +errorList :: [Text] -> [(Text, Text)] -> [X.Node] +errorList [] _ = [] +errorList errs attrs = [X.Element "ul" attrs $ map makeError errs] + where + makeError e = X.Element "li" [] [X.TextNode e] + +-- | Display the list of errors for a certain field. Example: +-- +-- > +-- > +dfErrorList :: Monad m => View Text -> Splice m +dfErrorList view = do + (ref, attrs) <- getRefAttributes + return $ errorList (errors ref view) attrs + +-- | Display the list of errors for a certain form and all forms below it. E.g., +-- if there is a subform called @\"user\"@: +-- +-- > +-- +-- Or display /all/ errors for the form: +-- +-- > +dfChildErrorList :: Monad m => View Text -> Splice m +dfChildErrorList view = do + (ref, attrs) <- getRefAttributes + return $ errorList (childErrors ref view) attrs + +-- | This splice allows reuse of templates by selecting some child of a form +-- tree. While this may sound complicated, it's pretty straightforward and +-- practical. Suppose we have: +-- +-- > +-- > +-- > +-- > +-- +-- You may want to abstract the @\"user\"@ parts in some other template so you +-- Don't Repeat Yourself (TM). If you create a template called @\"user-form\"@ +-- with the following contents: +-- +-- > +-- > +-- +-- You will be able to use: +-- +-- > +-- > +-- > +-- > +-- > +dfSubView :: Monad m => View Text -> Splice m +dfSubView view = do + (ref, _) <- getRefAttributes + content <- getContent + let view' = subView ref view + nodes <- localTS (bindDigestiveSplices view') $ runNodeList content + stopRecursion + return nodes