diff --git a/HSP/Formlets.hs b/HSP/Formlets.hs new file mode 100644 --- /dev/null +++ b/HSP/Formlets.hs @@ -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 -> []) + +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 [ ]) + +file :: (XMLGenerator x, Monad v) => Form [XMLGenT x (HSX.XML x)] v File +file = inputFile $ \name -> [] + +label :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v () +label str = xml $ [] + +hidden :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String +hidden = input' (\n v -> []) + +submit :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v Bool +submit val = (generalInput (\n _ -> [
])) `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 -> []) + +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 -> []) (catMaybes <$> (sequenceA $ map mkCheckbox items)) + where + mkCheckbox (val, labelText) = + generalInput (\n mv -> + if mv == (Just val) + then [
  • <% labelText %>
    • ] + else [
  • <% labelText %>
    • ]) + +-- 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 -> []) + +radioItem :: (XMLGenerator x) => String -> Maybe String -> (String, String) -> [XMLGenT x (HSX.XML x)] +radioItem n mv (val, labelText) = + if mv == (Just val) + then [

  • <% labelText %>

    • ] + else [

  • <% labelText %>

    • ] + +-- |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 -> []) + +selectOption :: (XMLGenerator x) => Maybe String -> (String, String) -> [XMLGenT x (HSX.XML x)] +selectOption mv (val, labelText) = + if mv == (Just val) + then [] + else [] + +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 -> + [] + where + mkOption selectedValues (value, label) + | value `elem` selectedValues = + [] + | otherwise = + [] + +-- |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 -> [
    <% xml %>
    ]) `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 -> [<% xml %>]) `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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,9 @@ +import Distribution.Simple +import Distribution.Simple.Program + +trhsxProgram = simpleProgram "trhsx" + +main :: IO () +main = defaultMainWithHooks simpleUserHooks { + hookedPrograms = [trhsxProgram] + } diff --git a/formlets-hsp.cabal b/formlets-hsp.cabal new file mode 100644 --- /dev/null +++ b/formlets-hsp.cabal @@ -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. + + . + 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 +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