reform-hsp-0.2.7.1/0000755000000000000000000000000012776026215012137 5ustar0000000000000000reform-hsp-0.2.7.1/LICENSE0000644000000000000000000000275712776026215013157 0ustar0000000000000000Copyright (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. reform-hsp-0.2.7.1/reform-hsp.cabal0000644000000000000000000000223512776026215015207 0ustar0000000000000000Name: reform-hsp Version: 0.2.7.1 Synopsis: Add support for using HSP with Reform Description: Reform is a library for building and validating forms using applicative functors. This package add support for using reform with HSP. Homepage: http://www.happstack.com/ License: BSD3 License-file: LICENSE Author: Jeremy Shaw Maintainer: jeremy@n-heptane.com Copyright: 2012 Jeremy Shaw, Jasper Van der Jeugt, SeeReason Partners LLC Category: Web Build-type: Simple Cabal-version: >=1.6 tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 source-repository head type: git location: https://github.com/Happstack/reform-hsp.git Library Exposed-modules: Text.Reform.HSP.Common Text.Reform.HSP.String Text.Reform.HSP.Text Build-depends: base > 4 && <5, hsp >= 0.9 && < 0.11, hsx2hs >= 0.13 && < 0.15, reform >= 0.2.1 && < 0.3, text >= 0.11 && < 1.3 reform-hsp-0.2.7.1/Setup.hs0000644000000000000000000000005612776026215013574 0ustar0000000000000000import Distribution.Simple main = defaultMain reform-hsp-0.2.7.1/Text/0000755000000000000000000000000012776026215013063 5ustar0000000000000000reform-hsp-0.2.7.1/Text/Reform/0000755000000000000000000000000012776026215014315 5ustar0000000000000000reform-hsp-0.2.7.1/Text/Reform/HSP/0000755000000000000000000000000012776026215014747 5ustar0000000000000000reform-hsp-0.2.7.1/Text/Reform/HSP/Common.hs0000644000000000000000000004214612776026215016542 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances, ViewPatterns, OverloadedStrings, QuasiQuotes #-} module Text.Reform.HSP.Common where import Data.List (intercalate) import Data.Monoid ((<>), mconcat) import Data.Text.Lazy (Text, pack) import qualified Data.Text as T import Text.Reform.Backend import Text.Reform.Core import Text.Reform.Generalized as G import Text.Reform.Result (FormId, Result(Ok), unitRange) import Language.Haskell.HSX.QQ (hsx) import HSP.XMLGenerator import HSP.XML instance (XMLGen m, EmbedAsAttr m (Attr Text Text)) => (EmbedAsAttr m (Attr Text FormId)) where asAttr (n := v) = asAttr (n := (pack $ show v)) inputText :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text 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 = [hsx| [] |] inputEmail :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text text)) => (input -> Either error text) -> text -> Form m input error [XMLGenT x (XMLType x)] () text inputEmail getInput initialValue = G.input getInput inputField initialValue where inputField i a = [hsx| [] |] inputPassword :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text 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 = [hsx| [] |] inputSubmit :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text 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 = [hsx| [] |] inputReset :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text text)) => text -> Form m input error [XMLGenT x (XMLType x)] () () inputReset lbl = G.inputNoData inputField lbl where inputField i a = [hsx| [] |] inputHidden :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text 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 = [hsx| [] |] inputButton :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text text)) => text -> Form m input error [XMLGenT x (XMLType x)] () () inputButton label = G.inputNoData inputField label where inputField i a = [hsx| [] |] textarea :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text 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 = [hsx| [] |] -- | 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, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId)) => Form m input error [XMLGenT x (XMLType x)] () (FileType input) inputFile = G.inputFile fileView where fileView i = [hsx| [] |] -- | Create a @\] |] buttonReset :: ( Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsChild x children , EmbedAsAttr x (Attr Text FormId) ) => children -> Form m input error [XMLGenT x (XMLType x)] () () buttonReset c = G.inputNoData inputField Nothing where inputField i a = [hsx| [] |] button :: ( Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsChild x children , EmbedAsAttr x (Attr Text FormId) ) => children -> Form m input error [XMLGenT x (XMLType x)] () () button c = G.inputNoData inputField Nothing where inputField i a = [hsx| [] |] label :: (Monad m, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsChild x c) => c -> Form m input error [XMLGenT x (XMLType x)] () () label c = G.label mkLabel where mkLabel i = [hsx| [] |] -- FIXME: should this use inputMaybe? inputCheckbox :: forall x error input m. (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text 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 getInputText input of (Right _) -> mkCheckbox i True (Left (e :: error) ) -> mkCheckbox i False where mkCheckbox i checked = return ( View $ const $ [hsx| [] |] , 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, StringType x ~ Text, EmbedAsChild x lbl, EmbedAsAttr x (Attr Text 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) = [hsx| [ , ] |] inputRadio :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, StringType x ~ Text, EmbedAsChild x lbl, EmbedAsAttr x (Attr Text 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) = [hsx| [ , ,
] |] inputRadioForms :: forall m x error input lbl proof a. (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, StringType x ~ Text, EmbedAsChild x lbl, EmbedAsAttr x (Attr Text FormId)) => [(Form m input error [XMLGenT x (XMLType x)] proof a, lbl)] -- ^ value, label, initially checked -> a -- ^ default -> Form m input error [XMLGenT x (XMLType x)] proof a inputRadioForms choices def = inputRadioForms' onclick choices def where formIdsJS :: [FormId] -> Text formIdsJS [] = "[]" formIdsJS ids = "['" <> (pack $ intercalate "', '" $ map show ids) <> "']" onclick :: FormId -> FormId -> [FormId] -> Text onclick nm iview iviews = mconcat [ "var views = " <> formIdsJS iviews <> ";" , "var iview = '" <> (pack $ show iview) <> "';" , "for (var i = 0; i < views.length; i++) {" , " if (iview == views[i]) {" , " document.getElementById(iview).style.display='block';" , " } else {" , " document.getElementById(views[i]).style.display='none';" , " }" , "}" ] inputRadioForms' :: forall m x error input lbl proof a. (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, StringType x ~ Text, EmbedAsChild x lbl, EmbedAsAttr x (Attr Text FormId)) => (FormId -> FormId -> [FormId] -> Text) -> [(Form m input error [XMLGenT x (XMLType x)] proof a, lbl)] -- ^ value, label, initially checked -> a -- ^ default -> Form m input error [XMLGenT x (XMLType x)] proof a inputRadioForms' onclick choices def = G.inputChoiceForms def choices mkRadios where iviewsExtract :: [(FormId, Int, FormId, [XMLGenT x (XMLType x)], lbl, Bool)] -> [FormId] iviewsExtract = map (\(_,_, iv, _, _, _) -> iv) mkRadios :: FormId -> [(FormId, Int, FormId, [XMLGenT x (XMLType x)], lbl, Bool)] -> [XMLGenT x (XMLType x)] mkRadios nm choices' = let iviews = iviewsExtract choices' in (concatMap (mkRadio nm iviews) choices') mkRadio nm iviews (i, val, iview, view, lbl, checked) = [hsx| [
<% view %>
] |] select :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, StringType x ~ Text, EmbedAsChild x lbl, EmbedAsAttr x (Attr Text 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' = [hsx| [ ] |] mkOption (_, val, lbl, selected) = [hsx| |] selectMultiple :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, XMLGenerator x, StringType x ~ Text, EmbedAsChild x lbl, EmbedAsAttr x (Attr Text 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' = [hsx| [ ] |] mkOption (_, val, lbl, selected) = [hsx| |] {- inputMultiSelectOptGroup :: (Functor m, XMLGenerator x, StringType x ~ Text, EmbedAsChild x groupLbl, EmbedAsChild x lbl, EmbedAsAttr x (Attr Text 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, StringType x ~ Text, EmbedAsChild x error) => Form m input error [XMLGenT x (XMLType x)] () () errorList = G.errors mkErrors where mkErrors [] = [] mkErrors errs = [hsx| [] |] mkError e = [hsx|
  • <% e %>
    • |] childErrorList :: (Monad m, XMLGenerator x, StringType x ~ Text, EmbedAsChild x error) => Form m input error [XMLGenT x (XMLType x)] () () childErrorList = G.childErrors mkErrors where mkErrors [] = [] mkErrors errs = [hsx| [] |] mkError e = [hsx|
  • <% e %>
    • |] br :: (Monad m, XMLGenerator x, StringType x ~ Text) => Form m input error [XMLGenT x (XMLType x)] () () br = view [hsx| [
    ] |] fieldset :: (Monad m, Functor m, XMLGenerator x, StringType x ~ Text, EmbedAsChild x c) => Form m input error c proof a -> Form m input error [XMLGenT x (XMLType x)] proof a fieldset frm = mapView (\xml -> [hsx| [
    <% xml %>
    ] |]) frm ol :: (Monad m, Functor m, XMLGenerator x, StringType x ~ Text, EmbedAsChild x c) => Form m input error c proof a -> Form m input error [XMLGenT x (XMLType x)] proof a ol frm = mapView (\xml -> [hsx| [
      <% xml %>
    ] |]) frm ul :: (Monad m, Functor m, XMLGenerator x, StringType x ~ Text, EmbedAsChild x c) => Form m input error c proof a -> Form m input error [XMLGenT x (XMLType x)] proof a ul frm = mapView (\xml -> [hsx| [] |]) frm li :: (Monad m, Functor m, XMLGenerator x, StringType x ~ Text, EmbedAsChild x c) => Form m input error c proof a -> Form m input error [XMLGenT x (XMLType x)] proof a li frm = mapView (\xml -> [hsx| [
  • <% xml %>
    • ] |]) frm -- | create @\
    @ form :: (XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text action)) => action -- ^ action url -> [(Text,Text)] -- ^ hidden fields to add to form -> [XMLGenT x (XMLType x)] -- ^ children -> [XMLGenT x (XMLType x)] form action hidden children = [hsx| [ <% mapM mkHidden hidden %> <% children %>
    ] |] where mkHidden (name, value) = [hsx| |] setAttrs :: (EmbedAsAttr x attr, XMLGenerator x, StringType x ~ Text, 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 reform-hsp-0.2.7.1/Text/Reform/HSP/String.hs0000644000000000000000000003233212776026215016554 0ustar0000000000000000{-# 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 inputEmail , inputText , inputPassword , inputSubmit , inputReset , inputHidden , inputButton , inputCheckbox , inputCheckboxes , inputRadio , inputRadioForms , 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 Data.Text.Lazy (Text, pack) import HSP.XMLGenerator import Text.Reform import qualified Text.Reform.HSP.Common as C -- | Create an @\@ element inputEmail :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text String)) => String -- ^ initial value -> Form m input error [XMLGenT x (XMLType x)] () String inputEmail initialValue = C.inputEmail getInputString initialValue -- | Create an @\@ element inputText :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text String)) => 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, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text String)) => 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, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text String)) => 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, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text String)) => 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, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text String)) => 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, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text String)) => 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, StringType x ~ Text, EmbedAsAttr x (Attr Text 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 @\