formlets-hsp (empty) → 2.2.3
raw patch · 4 files changed
+217/−0 lines, 4 filesdep +applicative-extrasdep +basedep +formletsbuild-type:Customsetup-changed
Dependencies added: applicative-extras, base, formlets, haskell98, hsp, hsx, mtl
Files
- HSP/Formlets.hs +148/−0
- LICENSE +30/−0
- Setup.hs +9/−0
- formlets-hsp.cabal +30/−0
+ HSP/Formlets.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, TypeFamilies, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-}+module HSP.Formlets + ( input+ , textarea+ , file+ , label+ , hidden+ , submit+ , password+ , checkboxes+ , select+ , selectMulti+ , radio+ , div+ , span+ , withAttrs+ , fset+ ) where++import Control.Arrow (first)+import Control.Applicative (Applicative(pure),(<$>))+import Control.Applicative.Error (Failing(Success), maybeRead')+import Data.Maybe (catMaybes)+import Data.Monoid (Monoid)+import Data.Traversable (sequenceA)+import HSP+import qualified HSX.XMLGenerator as HSX+import Text.Formlets (Form, File, Rect(rectRows, rectCols), check, generalInput, generalInputMulti, input', inputFile, plug, xml)+import Prelude hiding (div, span)++input :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String+input = input' (\n v -> [<input type="text" name=n value=v />])++textarea :: (XMLGenerator x, Monad v) => (String -> Rect) -> Maybe String -> Form [XMLGenT x (HSX.XML x)] v String+textarea calcRect =+ input' (\n v -> + let rect = calcRect v+ in [ <textarea rows=(rectRows rect) cols=(rectCols rect) name=n ><% v %></textarea> ])++file :: (XMLGenerator x, Monad v) => Form [XMLGenT x (HSX.XML x)] v File+file = inputFile $ \name -> [<input type="file" name=name />]++label :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v ()+label str = xml $ [<label><% str %></label>]++hidden :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String+hidden = input' (\n v -> [<input type="hidden" name=n value=v />])++submit :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v Bool+submit val = (generalInput (\n _ -> [<div><input type="submit" name=n value=val /></div>])) `check` + (\res -> + case res of+ Nothing -> pure False+ (Just "") -> pure False+ _ -> pure True+ )++-- |A password field with an optional value+password :: (Monad v, HSX.XMLGenerator x) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String+password = input' (\n v -> [<input type="password" name=n value=v />])++checkboxes :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v [a]+checkboxes items = checkboxes' (map (first show) items) `check` (\strs -> sequenceA $ map (flip maybeRead' "Could not parse checkbox data") strs)++{-+Normally checkboxes all have the same 'name' element, and you get an+array of results back. But we don't want to parse the array, so we use+a trick and just give each checkbox a unique name.+-}+checkboxes' :: (XMLGenerator x, Monad v, Applicative v) => [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v [String]+checkboxes' items =+ plug (\listItems -> [<ul class="checkboxes"><% listItems %></ul>]) (catMaybes <$> (sequenceA $ map mkCheckbox items))+ where + mkCheckbox (val, labelText) =+ generalInput (\n mv ->+ if mv == (Just val)+ then [<li><input type="checkbox" name=n value=val checked="checked"/><% labelText %></li>]+ else [<li><input type="checkbox" name=n value=val /> <% labelText %></li>])++-- todo: make the label be any valid markup, not just a string+radio :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)+radio items = radio'' (map (first show) items) `check` checkItem+ where+ checkItem Nothing = Success Nothing+ checkItem (Just str) = Just <$> maybeRead' str ("Could not parse radio data: " ++ str)++radio'' :: (XMLGenerator x, Applicative v, Monad v) => [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe String)+radio'' items = generalInput (\n mv -> [<ul class="radios"><% concatMap (radioItem n mv) items %></ul>])++radioItem :: (XMLGenerator x) => String -> Maybe String -> (String, String) -> [XMLGenT x (HSX.XML x)]+radioItem n mv (val, labelText) =+ if mv == (Just val)+ then [<li><p><input type="radio" name=n value=val checked="checked"/><% labelText %></p></li>]+ else [<li><p><input type="radio" name=n value=val /> <% labelText %></p></li>]++-- |drop down box+select :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => Maybe a -> [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe a)+select defaultSelection items = select' (show <$> defaultSelection) (map (first show) items) `check` checkOption+ where+ checkOption Nothing = Success Nothing+ checkOption (Just str) = Just <$> maybeRead' str ("Could not parse select data: " ++ str)++select' :: (XMLGenerator x, Applicative v, Monad v) => Maybe String -> [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v (Maybe String)+select' defaultSelection items = generalInput (\n mv -> [<select name=n><% concatMap (selectOption (maybe defaultSelection Just mv)) items %></select>])++selectOption :: (XMLGenerator x) => Maybe String -> (String, String) -> [XMLGenT x (HSX.XML x)]+selectOption mv (val, labelText) =+ if mv == (Just val)+ then [<option value=val selected="selected"><% labelText %></option>]+ else [<option value=val ><% labelText %></option>]++selectMulti :: (XMLGenerator x, Monad v, Applicative v, Read a, Show a) => [(a, String)] -> Form [XMLGenT x (HSX.XML x)] v [a]+selectMulti items = selectMulti' (map (first show) items) `check` (\strs -> sequenceA $ map (flip maybeRead' "Could not parse select data") strs)++selectMulti' :: (XMLGenerator x, Monad v, Applicative v) => [(String, String)] -> Form [XMLGenT x (HSX.XML x)] v [String]+selectMulti' items =+ generalInputMulti $ \name selectedValues ->+ [<select name=name multiple="multiple">+ <% mapM (mkOption selectedValues) items %>+ </select>]+ where+ mkOption selectedValues (value, label)+ | value `elem` selectedValues =+ [<option value=value selected="selected"><% label %></option>]+ | otherwise =+ [<option value=value ><% label %></option>]++-- |A convenience function to wrap a form inside a div. This could+-- have been defined outside this module, but it is handy to put it+-- here.+div :: (Monad m1, EmbedAsChild m xml, EmbedAsAttr m (Attr [Char] a), Monoid xml) => a -> Form xml m1 b -> Form [XMLGenT m (HSX.XML m)] m1 b+div c frm = (\ xml -> [<div class=c><% xml %></div>]) `plug` frm++-- |Like div, for span.+span :: (Monad m1, EmbedAsChild m xml, EmbedAsAttr m (Attr [Char] a), Monoid xml) => a -> Form xml m1 b -> Form [XMLGenT m (HSX.XML m)] m1 b+span c frm = (\ xml -> [<span class=c><% xml %></span>]) `plug` frm++-- |add additional attributes to the xml element(s)+-- See also: 'fset'+withAttrs :: (EmbedAsAttr x (Attr attr val), XMLGenerator x, Monad v) => [Attr attr val] -> Form [XMLGenT x (HSX.XML x)] v a -> Form [XMLGenT x (HSX.XML x)] v a+withAttrs attrs = plug (map (`set` attrs))++-- |add additional attributes to the xml element(s)+-- same as withAttrs but with the arguments reversed+-- See also: 'withAttrs'+fset :: (EmbedAsAttr x (Attr attr val), XMLGenerator x, Monad v) => Form [XMLGenT x (HSX.XML x)] v a -> [Attr attr val] -> Form [XMLGenT x (HSX.XML x)] v a+fset = flip withAttrs
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010, 2009, 2008, 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 Tupil 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,9 @@+import Distribution.Simple+import Distribution.Simple.Program++trhsxProgram = simpleProgram "trhsx"++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+ hookedPrograms = [trhsxProgram]+ }
+ formlets-hsp.cabal view
@@ -0,0 +1,30 @@+Name: formlets-hsp+Version: 2.2.3+Synopsis: HSP support for Formlets+Description: A modular way to build forms based on applicative functors, as+ described in:+ .+ * Ezra Cooper, Samuel Lindley, Philip Wadler and Jeremy Yallop+ \"An idiom's guide to formlets\"+ Technical Report, EDI-INF-RR-1263.+ <http://groups.inf.ed.ac.uk/links/formlets/>+ .+ This library extends formlets with support for HSP+Category: XML, Web, User Interfaces, Text+License: BSD3+License-file: LICENSE+Copyright: (c) Jeremy Yallop / Tupil, Jeremy Shaw+Author: Jeremy Yallop, Chris Eidhof, Jeremy Shaw, David Fox+Maintainer: Jeremy Shaw <jeremy@seereason.com>+Cabal-version: >= 1.6+Build-Type: Custom++Library+ Exposed-Modules: HSP.Formlets+ Build-Depends: base >3 && < 5, haskell98, formlets >= 0.7.1, hsx, hsp, mtl, applicative-extras+ Build-Tools: trhsx++source-repository head+ type: darcs+ subdir: happstack+ location: http://src.seereason.com/formlets-hsp