diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, 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. 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/Text/Reform/HSP/Common.hs b/Text/Reform/HSP/Common.hs new file mode 100644 --- /dev/null +++ b/Text/Reform/HSP/Common.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances, ViewPatterns #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Text.Reform.HSP.Common where + +import Text.Reform.Backend +import Text.Reform.Core +import Text.Reform.Generalized as G +import Text.Reform.Result (FormId, Result(Ok), unitRange) +import HSP + +instance (EmbedAsAttr m (Attr String String)) => (EmbedAsAttr m (Attr String FormId)) where + asAttr (n := v) = asAttr (n := show v) + +inputText :: (Monad m, FormError error, XMLGenerator x, EmbedAsAttr x (Attr String FormId), EmbedAsAttr x (Attr String text)) => + (input -> Either error text) + -> text + -> Form m input error [XMLGenT x (XMLType x)] () text +inputText getInput initialValue = G.input getInput inputField initialValue + where + inputField i a = [] + +inputPassword :: (Monad m, FormError error, XMLGenerator x, EmbedAsAttr x (Attr String FormId), EmbedAsAttr x (Attr String text)) => + (input -> Either error text) + -> text + -> Form m input error [XMLGenT x (XMLType x)] () text +inputPassword getInput initialValue = G.input getInput inputField initialValue + where + inputField i a = [] + +inputSubmit :: (Monad m, FormError error, XMLGenerator x, EmbedAsAttr x (Attr String FormId), EmbedAsAttr x (Attr String text)) => + (input -> Either error text) + -> text + -> Form m input error [XMLGenT x (XMLType x)] () (Maybe text) +inputSubmit getInput initialValue = G.inputMaybe getInput inputField initialValue + where + inputField i a = [] + +inputReset :: (Monad m, FormError error, XMLGenerator x, EmbedAsAttr x (Attr String FormId), EmbedAsAttr x (Attr String text)) => + text + -> Form m input error [XMLGenT x (XMLType x)] () () +inputReset lbl = G.inputNoData inputField lbl + where + inputField i a = [] + +inputHidden :: (Monad m, FormError error, XMLGenerator x, EmbedAsAttr x (Attr String FormId), EmbedAsAttr x (Attr String text)) => + (input -> Either error text) + -> text + -> Form m input error [XMLGenT x (XMLType x)] () text +inputHidden getInput initialValue = G.input getInput inputField initialValue + where + inputField i a = [] + +inputButton :: (Monad m, FormError error, XMLGenerator x, EmbedAsAttr x (Attr String FormId), EmbedAsAttr x (Attr String text)) => + text + -> Form m input error [XMLGenT x (XMLType x)] () () +inputButton label = G.inputNoData inputField label + where + inputField i a = [] + +textarea :: (Monad m, FormError error, XMLGenerator x, EmbedAsAttr x (Attr String FormId), EmbedAsChild x text) => + (input -> Either error text) + -> Int -- ^ cols + -> Int -- ^ rows + -> text -- ^ initial text + -> Form m input error [XMLGenT x (XMLType x)] () text +textarea getInput cols rows initialValue = G.input getInput textareaView initialValue + where + textareaView i txt = [] + +-- | Create an @\@ element +-- +-- This control may succeed even if the user does not actually select a file to upload. In that case the uploaded name will likely be "" and the file contents will be empty as well. +inputFile :: (Monad m, FormError error, FormInput input, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + Form m input error [XMLGenT x (XMLType x)] () (FileType input) +inputFile = G.inputFile fileView + where + fileView i = [] + +-- | Create a @\] + +buttonReset :: ( Monad m, FormError error, XMLGenerator x, EmbedAsChild x children , EmbedAsAttr x (Attr String FormId) + ) => + children + -> Form m input error [XMLGenT x (XMLType x)] () () +buttonReset c = G.inputNoData inputField Nothing + where + inputField i a = [] + +button :: ( Monad m, FormError error, XMLGenerator x, EmbedAsChild x children , EmbedAsAttr x (Attr String FormId) + ) => + children + -> Form m input error [XMLGenT x (XMLType x)] () () +button c = G.inputNoData inputField Nothing + where + inputField i a = [] + +label :: (Monad m, XMLGenerator x, EmbedAsAttr x (Attr String FormId), EmbedAsChild x c) => + c + -> Form m input error [XMLGenT x (XMLType x)] () () +label c = G.label mkLabel + where + mkLabel i = [] + +-- FIXME: should this use inputMaybe? +inputCheckbox :: forall x error input m. (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + Bool -- ^ initially checked + -> Form m input error [XMLGenT x (XMLType x)] () Bool +inputCheckbox initiallyChecked = + Form $ + do i <- getFormId + v <- getFormInput' i + case v of + Default -> mkCheckbox i initiallyChecked + Missing -> mkCheckbox i False -- checkboxes only appear in the submitted data when checked + (Found input) -> + case getInputString input of + (Right _) -> mkCheckbox i True + (Left (e :: error) ) -> mkCheckbox i False + where + mkCheckbox i checked = + return ( View $ const $ [] + , return $ Ok (Proved { proofs = () + , pos = unitRange i + , unProved = if checked then True else False + }) + ) + +inputCheckboxes :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, EmbedAsChild x lbl, EmbedAsAttr x (Attr String FormId)) => + [(a, lbl)] -- ^ value, label, initially checked + -> (a -> Bool) -- ^ function which indicates if a value should be checked initially + -> Form m input error [XMLGenT x (XMLType x)] () [a] +inputCheckboxes choices isChecked = + G.inputMulti choices mkCheckboxes isChecked + where + mkCheckboxes nm choices' = concatMap (mkCheckbox nm) choices' + mkCheckbox nm (i, val, lbl, checked) = + [ + , + ] + +inputRadio :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, EmbedAsChild x lbl, EmbedAsAttr x (Attr String FormId)) => + [(a, lbl)] -- ^ value, label, initially checked + -> (a -> Bool) -- ^ isDefault + -> Form m input error [XMLGenT x (XMLType x)] () a +inputRadio choices isDefault = + G.inputChoice isDefault choices mkRadios + where + mkRadios nm choices' = concatMap (mkRadio nm) choices' + mkRadio nm (i, val, lbl, checked) = + [ + , + ,
+ ] + +select :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, EmbedAsChild x lbl, EmbedAsAttr x (Attr String FormId)) => + [(a, lbl)] -- ^ value, label + -> (a -> Bool) -- ^ isDefault, must match *exactly one* element in the list of choices + -> Form m input error [XMLGenT x (XMLType x)] () a +select choices isDefault = + G.inputChoice isDefault choices mkSelect + where + mkSelect nm choices' = + [ + ] + + mkOption (_, val, lbl, selected) = + + +selectMultiple :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, EmbedAsChild x lbl, EmbedAsAttr x (Attr String FormId)) => + [(a, lbl)] -- ^ value, label, initially checked + -> (a -> Bool) -- ^ isSelected initially + -> Form m input error [XMLGenT x (XMLType x)] () [a] +selectMultiple choices isSelected = + G.inputMulti choices mkSelect isSelected + where + mkSelect nm choices' = + [ + ] + mkOption (_, val, lbl, selected) = + +{- +inputMultiSelectOptGroup :: (Functor m, XMLGenerator x, EmbedAsChild x groupLbl, EmbedAsChild x lbl, EmbedAsAttr x (Attr String FormId), FormError error, ErrorInputType error ~ input, FormInput input, Monad m) => + [(groupLbl, [(a, lbl, Bool)])] -- ^ value, label, initially checked + -> Form m input error [XMLGenT x (XMLType x)] () [a] +inputMultiSelectOptGroup choices = + G.inputMulti choices mkSelect + where + mkSelect nm choices' = + [ + ] + mkOptGroup (grpLabel, options) = + + <% mapM mkOption options %> + + mkOption (_, val, lbl, selected) = + +-} + +errorList :: (Monad m, XMLGenerator x, EmbedAsChild x error) => + Form m input error [XMLGenT x (XMLType x)] () () +errorList = G.errors mkErrors + where + mkErrors [] = [] + mkErrors errs = [] + mkError e =
  • <% e %>
    • + +childErrorList :: (Monad m, XMLGenerator x, EmbedAsChild x error) => + Form m input error [XMLGenT x (XMLType x)] () () +childErrorList = G.childErrors mkErrors + where + mkErrors [] = [] + mkErrors errs = [] + mkError e =
  • <% e %>
    • + + +br :: (Monad m, XMLGenerator x) => Form m input error [XMLGenT x (XMLType x)] () () +br = view [
    ] + +fieldset :: (Monad m, Functor m, XMLGenerator x, EmbedAsChild x c) => + Form m input error c proof a + -> Form m input error [XMLGenT x (XMLType x)] proof a +fieldset frm = mapView (\xml -> [
    <% xml %>
    ]) frm + +ol :: (Monad m, Functor m, XMLGenerator x, EmbedAsChild x c) => + Form m input error c proof a + -> Form m input error [XMLGenT x (XMLType x)] proof a +ol frm = mapView (\xml -> [
      <% xml %>
    ]) frm + +ul :: (Monad m, Functor m, XMLGenerator x, EmbedAsChild x c) => + Form m input error c proof a + -> Form m input error [XMLGenT x (XMLType x)] proof a +ul frm = mapView (\xml -> []) frm + +li :: (Monad m, Functor m, XMLGenerator x, EmbedAsChild x c) => + Form m input error c proof a + -> Form m input error [XMLGenT x (XMLType x)] proof a +li frm = mapView (\xml -> [
  • <% xml %>
    • ]) frm + +-- | create @\
    @ +form :: (XMLGenerator x, EmbedAsAttr x (Attr String action)) => + action -- ^ action url + -> [(String,String)] -- ^ hidden fields to add to form + -> [XMLGenT x (XMLType x)] -- ^ childern + -> [XMLGenT x (XMLType x)] +form action hidden children + = [ + <% mapM mkHidden hidden %> + <% children %> +
    + ] + where + mkHidden (name, value) = + + +setAttrs :: (EmbedAsAttr x attr, XMLGenerator x, Monad m, Functor m) => + Form m input error [GenXML x] proof a + -> attr + -> Form m input error [GenXML x] proof a +setAttrs form attrs = mapView (map (`set` attrs)) form diff --git a/Text/Reform/HSP/String.hs b/Text/Reform/HSP/String.hs new file mode 100644 --- /dev/null +++ b/Text/Reform/HSP/String.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances, ViewPatterns #-} +{- | +This module provides functions creating Reform using HSP markup. + +This module assumes that you wish for text based controls such as 'inputText' and 'textarea' to using 'String' values. If you prefer 'Data.Text.Text' see "Text.Reform.HSP.Text". + +-} +module Text.Reform.HSP.String + ( -- * \ element + inputText + , inputPassword + , inputSubmit + , inputReset + , inputHidden + , inputButton + , inputCheckbox + , inputCheckboxes + , inputRadio + , inputFile + -- * \ element + , textarea + -- * \ element + , buttonSubmit + , buttonReset + , button + -- * \ element + , select + , selectMultiple + -- * \ element + , label + -- * errors + , errorList + , childErrorList + -- * layout functions + , br + , fieldset + , ol + , ul + , li + , form + , setAttrs + ) where + +import HSP +import Text.Reform +import qualified Text.Reform.HSP.Common as C + +-- | Create an @\@ element +inputText :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + String -- ^ initial value + -> Form m input error [XMLGenT x (XMLType x)] () String +inputText initialValue = C.inputText getInputString initialValue + +-- | Create an @\@ element +inputPassword :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + Form m input error [XMLGenT x (XMLType x)] () String +inputPassword = C.inputPassword getInputString "" + +-- | Create an @\@ element +-- +-- returns: +-- +-- [@Just@ /value/] if this button was used to submit the form. +-- +-- [@Nothing@] if this button was not used to submit the form. +inputSubmit :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + String -- ^ @value@ attribute. Used for button label, and value if button is submitted. + -> Form m input error [XMLGenT x (XMLType x)] () (Maybe String) +inputSubmit initialValue = C.inputSubmit getInputString initialValue + +-- | Create an @\@ element +-- +-- This element does not add any data to the form data set. +inputReset :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + String -- ^ value attribute. Used only to label the button. + -> Form m input error [XMLGenT x (XMLType x)] () () +inputReset = C.inputReset + +-- | Create an @\@ element +inputHidden :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + String -- ^ value to store in the hidden element + -> Form m input error [XMLGenT x (XMLType x)] () String +inputHidden initialValue = C.inputHidden getInputString initialValue + +-- | Create an @\@ element +-- +-- The element is a push button with a text label. The button does nothing by default, but actions can be added using javascript. This element does not add any data to the form data set. +-- +-- see also: 'C.button' +inputButton :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + String -- ^ value attribute. Used to label the button. + -> Form m input error [XMLGenT x (XMLType x)] () () +inputButton label = C.inputButton label + +-- | Create a \\<\/textarea\> element +textarea :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, EmbedAsAttr x (Attr String FormId)) => + Int -- ^ cols + -> Int -- ^ rows + -> String -- ^ initial contents + -> Form m input error [XMLGenT x (XMLType x)] () String +textarea rows cols initialValue = C.textarea getInputString rows cols initialValue + +-- | create a @\