digestive-functors-hsp (empty) → 0.2
raw patch · 4 files changed
+207/−0 lines, 4 filesdep +basedep +digestive-functorsdep +hspsetup-changed
Dependencies added: base, digestive-functors, hsp, hsx, text
Files
- LICENSE +30/−0
- Setup.hs +13/−0
- Text/Digestive/HSP/Html4.hs +140/−0
- digestive-functors-hsp.cabal +24/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Jeremy Shaw++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 Jeremy Shaw 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,13 @@+#!/usr/bin/env runghc++module Main where++import Distribution.Simple+import Distribution.Simple.Program++trhsxProgram = simpleProgram "trhsx"++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+ hookedPrograms = [trhsxProgram]+ }
+ Text/Digestive/HSP/Html4.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Text.Digestive.HSP.Html4 where++import Control.Applicative ((<$>))+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(mempty))+import Data.Text (Text)+import qualified Data.Text as Text+import HSP (XMLGenerator, XMLGenT, EmbedAsChild(..), EmbedAsAttr(..), Attr(..), genElement, genEElement, set)+import qualified HSX.XMLGenerator as HSX+import Text.Digestive -- (Form, mapViews)+import Text.Digestive.Common as Common -- (Form, mapViews)+import Text.Digestive.Forms as Forms -- (inputString, inputRead, inputBool, inputChoice)+++showFormId :: FormId -> String+showFormId (FormId p i) = p ++ show i++inputString :: (Monad m, Functor m, XMLGenerator x, FormInput i f)+ => Maybe String+ -> Form m i e [XMLGenT x (HSX.XML x)] String+inputString = + Forms.inputString $ \id' inp ->+ [<input type="text" name=(showFormId id') id=(showFormId id') value=(fromMaybe "" inp) />]++-- FIMXE: we really need a inputText primitive on Common. or maybe inputByteString?+inputText :: (Monad m, Functor m, XMLGenerator x, FormInput i f)+ => Maybe Text+ -> Form m i e [XMLGenT x (HSX.XML x)] Text+inputText v = + Text.pack <$>+ ((Forms.inputString $ \id' inp ->+ [<input type="text" name=(showFormId id') id=(showFormId id') value=(fromMaybe "" inp) />]) (Text.unpack <$> v))++inputTextArea :: (Monad m, Functor m, XMLGenerator x, FormInput i f) =>+ Maybe Int+ -> Maybe Int+ -> Maybe String+ -> Form m i e [XMLGenT x (HSX.XML x)] String+inputTextArea r c = + Forms.inputString $ \id' inp ->+ [<textarea name=(showFormId id') id=(showFormId id') (rows r ++ cols c)><% fromMaybe "" inp %></textarea>]+ where+ rows Nothing = []+ rows (Just n) = [("rows" := n)]+ cols Nothing = []+ cols (Just n) = [("cols" := n)]++inputTextRead :: (Monad m, Functor m, Show a, Read a, XMLGenerator x, FormInput i f)+ => String+ -> Maybe a+ -> Form m i String [XMLGenT x (HSX.XML x)] a+inputTextRead error' =+ flip inputRead error' $ \id' inp ->+ [<input type="text" name=(showFormId id') id=(showFormId id') value=(fromMaybe "" inp) />]++inputPassword :: (Monad m, Functor m, XMLGenerator x, FormInput i f)+ => Form m i e [XMLGenT x (HSX.XML x)] String+inputPassword =+ flip Forms.inputString Nothing $ \id' inp ->+ [<input type="password" name=(showFormId id') id=(showFormId id') value=(fromMaybe "" inp) />]++inputCheckBox :: (Monad m, Functor m, XMLGenerator x, FormInput i f)+ => Bool+ -> Form m i e [XMLGenT x (HSX.XML x)] Bool+inputCheckBox inp =+ flip inputBool inp $ \id' inp ->+ [<input type="checkbox" name=(showFormId id') id=(showFormId id') checked />]+ where+ checked =+ if inp+ then [("checked" := "checked")]+ else []++inputRadio :: (Monad m, Functor m, Eq a, XMLGenerator x, EmbedAsChild x c, Monoid c, FormInput i f)+ => Bool -- ^ Use @<br>@ tags+ -> a -- ^ Default option+ -> [(a, c)] -- ^ Choices with their names+ -> Form m i e [XMLGenT x (HSX.XML x)] a -- ^ Resulting form+inputRadio br def choices =+ inputChoice toView def (map fst choices)+ where+ toView group' id' sel val =+ [ <input type="radio" name=(showFormId group') id=id' value=id' />+ , <label for=id'><% fromMaybe mempty $ lookup val choices %></label>+ ] ++ if br then [<br />] else []++submit :: (Monad m, Functor m, XMLGenerator x, FormInput i f)+ => String+ -> Form m i e [XMLGenT x (HSX.XML x)] String+submit v = + Forms.inputString (\id' inp ->+ [<input type="submit" name=(showFormId id') id=(showFormId id') value=(fromMaybe "" inp) />]) (Just v)++label :: (Monad m, XMLGenerator x, EmbedAsChild x c, EmbedAsAttr x (Attr String String))+ => c+ -> Form m i e [XMLGenT x (HSX.XML x)] ()+label string =+ Common.label $ \id' ->+ [<label for=(showFormId id')><% string %></label>]++errorList :: (XMLGenerator x, EmbedAsChild x c) => [c] -> [XMLGenT x (HSX.XML x)]+errorList [] = []+errorList children =+ [<ul>+ <% mapM (\c -> <li><% c %></li>) children %>+ </ul>+ ]++errors :: (Monad m, XMLGenerator x) => + Form m i String [XMLGenT x (HSX.XML x)] ()+errors = Common.errors errorList++childErrors :: (Monad m, XMLGenerator x) => + Form m i String [XMLGenT x (HSX.XML x)] ()+childErrors = Common.childErrors errorList++{-+-- Test stuff++testRadio = testForm $ inputRadio True "foo" [("foo", [<span>foo</span>])]++testForm :: (Show a) => Form IO String String [XMLGenT Identity XML] a -> IO ()+testForm form =+ do (view', result) <- runForm form (Environment $ const (return Nothing))+ case result of+ (Ok a) -> + do putStrLn $ "the result: " ++ show a+ mapM_ (putStrLn . renderAsHTML . runIdentity . unXMLGenT ) $ unView view' []+ (Error e) -> + do print e+ mapM_ (putStrLn . renderAsHTML . runIdentity . unXMLGenT ) $ unView view' e+-}++setAttrs :: (EmbedAsAttr x attr, XMLGenerator x, Monad m, Functor m) =>+ Form m i e [HSX.GenXML x] a + -> attr + -> Form m i e [HSX.GenXML x] a+setAttrs form attrs = mapView (map (`set` attrs)) form
+ digestive-functors-hsp.cabal view
@@ -0,0 +1,24 @@+Name: digestive-functors-hsp+Version: 0.2+Synopsis: HSP support for digestive-functors+Description: This is an HSP frontend for the digestive-functors library.+Homepage: http://src.seereason.com/digestive-functors-hsp+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw+Maintainer: jeremy@n-heptane.com+Category: Web+Build-type: Simple+Cabal-version: >=1.6+++Library+ Exposed-modules: Text.Digestive.HSP.Html4+ Build-depends: base == 4.*,+ digestive-functors == 0.0.2.*,+ hsp,+ hsx,+ text+ if !os(windows)+ -- Cabal has a bug on windows and cannot find trhsx+ Build-Tools: trhsx