reform-hsp 0.2.5 → 0.2.6
raw patch · 2 files changed
+52/−50 lines, 2 filesdep +hsx2hs
Dependencies added: hsx2hs
Files
- Text/Reform/HSP/Common.hs +48/−47
- reform-hsp.cabal +4/−3
Text/Reform/HSP/Common.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances, ViewPatterns, OverloadedStrings #-}-{-# OPTIONS_GHC -F -pgmFhsx2hs #-}+{-# 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 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 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 @@ -22,7 +22,7 @@ -> Form m input error [XMLGenT x (XMLType x)] () text inputText getInput initialValue = G.input getInput inputField initialValue where- inputField i a = [<input type="text" id=i name=i value=a />]+ inputField i a = [hsx| [<input type="text" id=i name=i value=a />] |] inputPassword :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text text)) => (input -> Either error text)@@ -30,7 +30,7 @@ -> Form m input error [XMLGenT x (XMLType x)] () text inputPassword getInput initialValue = G.input getInput inputField initialValue where- inputField i a = [<input type="password" id=i name=i value=a />]+ inputField i a = [hsx| [<input type="password" id=i name=i value=a />] |] inputSubmit :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text text)) => (input -> Either error text)@@ -38,14 +38,14 @@ -> Form m input error [XMLGenT x (XMLType x)] () (Maybe text) inputSubmit getInput initialValue = G.inputMaybe getInput inputField initialValue where- inputField i a = [<input type="submit" id=i name=i value=a />]+ inputField i a = [hsx| [<input type="submit" id=i name=i value=a />] |] 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 = [<input type="reset" id=i name=i value=a />]+ inputField i a = [hsx| [<input type="reset" id=i name=i value=a />] |] inputHidden :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text text)) => (input -> Either error text)@@ -53,14 +53,14 @@ -> Form m input error [XMLGenT x (XMLType x)] () text inputHidden getInput initialValue = G.input getInput inputField initialValue where- inputField i a = [<input type="hidden" id=i name=i value=a />]+ inputField i a = [hsx| [<input type="hidden" id=i name=i value=a />] |] 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 = [<input type="button" id=i name=i value=a />]+ inputField i a = [hsx| [<input type="button" id=i name=i value=a />] |] textarea :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsChild x text) => (input -> Either error text)@@ -70,7 +70,7 @@ -> Form m input error [XMLGenT x (XMLType x)] () text textarea getInput cols rows initialValue = G.input getInput textareaView initialValue where- textareaView i txt = [<textarea rows=rows cols=cols id=i name=i><% txt %></textarea>]+ textareaView i txt = [hsx| [<textarea rows=rows cols=cols id=i name=i><% txt %></textarea>] |] -- | Create an @\<input type=\"file\"\>@ element --@@ -79,7 +79,7 @@ Form m input error [XMLGenT x (XMLType x)] () (FileType input) inputFile = G.inputFile fileView where- fileView i = [<input type="file" name=i id=i />]+ fileView i = [hsx| [<input type="file" name=i id=i />] |] -- | Create a @\<button type=\"submit\"\>@ element buttonSubmit :: ( Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsChild x children , EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text text)) =>@@ -89,7 +89,7 @@ -> Form m input error [XMLGenT x (XMLType x)] () (Maybe text) buttonSubmit getInput text c = G.inputMaybe getInput inputField text where- inputField i a = [<button type="submit" id=i name=i value=a><% c %></button>]+ inputField i a = [hsx| [<button type="submit" id=i name=i value=a><% c %></button>] |] buttonReset :: ( Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsChild x children , EmbedAsAttr x (Attr Text FormId) ) =>@@ -97,7 +97,7 @@ -> Form m input error [XMLGenT x (XMLType x)] () () buttonReset c = G.inputNoData inputField Nothing where- inputField i a = [<button type="reset" id=i name=i><% c %></button>]+ inputField i a = [hsx| [<button type="reset" id=i name=i><% c %></button>] |] button :: ( Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsChild x children , EmbedAsAttr x (Attr Text FormId) ) =>@@ -105,14 +105,14 @@ -> Form m input error [XMLGenT x (XMLType x)] () () button c = G.inputNoData inputField Nothing where- inputField i a = [<button type="button" id=i name=i><% c %></button>]+ inputField i a = [hsx| [<button type="button" id=i name=i><% c %></button>] |] 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 = [<label for=i><% c %></label>]+ mkLabel i = [hsx| [<label for=i><% c %></label>] |] -- 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)) =>@@ -131,7 +131,7 @@ (Left (e :: error) ) -> mkCheckbox i False where mkCheckbox i checked =- return ( View $ const $ [<input type="checkbox" id=i name=i value=i (if checked then [("checked" := "checked") :: Attr Text Text] else []) />]+ return ( View $ const $ [hsx| [<input type="checkbox" id=i name=i value=i (if checked then [("checked" := "checked") :: Attr Text Text] else []) />] |] , return $ Ok (Proved { proofs = () , pos = unitRange i , unProved = if checked then True else False@@ -146,10 +146,10 @@ G.inputMulti choices mkCheckboxes isChecked where mkCheckboxes nm choices' = concatMap (mkCheckbox nm) choices'- mkCheckbox nm (i, val, lbl, checked) =+ mkCheckbox nm (i, val, lbl, checked) = [hsx| [ <input type="checkbox" id=i name=nm value=(pack $ show val) (if checked then [("checked" := "checked") :: Attr Text Text] else []) /> , <label for=i><% lbl %></label>- ]+ ] |] 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@@ -159,11 +159,11 @@ G.inputChoice isDefault choices mkRadios where mkRadios nm choices' = concatMap (mkRadio nm) choices'- mkRadio nm (i, val, lbl, checked) =+ mkRadio nm (i, val, lbl, checked) = [hsx| [ <input type="radio" id=i name=nm value=(pack $ show val) (if checked then [("checked" := "checked") :: Attr Text Text] else []) /> , <label for=i><% lbl %></label> , <br />- ]+ ] |] 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@@ -206,13 +206,13 @@ let iviews = iviewsExtract choices' in (concatMap (mkRadio nm iviews) choices') - mkRadio nm iviews (i, val, iview, view, lbl, checked) =+ mkRadio nm iviews (i, val, iview, view, lbl, checked) = [hsx| [ <div> <input type="radio" onclick=(onclick nm iview iviews) id=i name=nm value=(pack $ show val) (if checked then [("checked" := "checked") :: Attr Text Text] else []) /> <label for=i><% lbl %></label> <div id=iview (if checked then [] else [("style" := "display:none;") :: Attr Text Text])><% view %></div> </div>- ]+ ] |] 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@@ -221,16 +221,16 @@ select choices isDefault = G.inputChoice isDefault choices mkSelect where- mkSelect nm choices' =+ mkSelect nm choices' = [hsx| [<select name=nm> <% mapM mkOption choices' %> </select>- ]+ ] |] - mkOption (_, val, lbl, selected) =+ mkOption (_, val, lbl, selected) = [hsx| <option value=val (if selected then [("selected" := "selected") :: Attr Text Text] else []) > <% lbl %>- </option>+ </option> |] 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@@ -239,15 +239,15 @@ selectMultiple choices isSelected = G.inputMulti choices mkSelect isSelected where- mkSelect nm choices' =+ mkSelect nm choices' = [hsx| [<select name=nm multiple="multiple"> <% mapM mkOption choices' %> </select>- ]- mkOption (_, val, lbl, selected) =+ ] |]+ mkOption (_, val, lbl, selected) = [hsx| <option value=val (if selected then [("selected" := "selected") :: Attr Text Text] else [])> <% lbl %>- </option>+ </option> |] {- 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@@ -275,40 +275,40 @@ errorList = G.errors mkErrors where mkErrors [] = []- mkErrors errs = [<ul class="reform-error-list"><% mapM mkError errs %></ul>]- mkError e = <li><% e %></li>+ mkErrors errs = [hsx| [<ul class="reform-error-list"><% mapM mkError errs %></ul>] |]+ mkError e = [hsx| <li><% e %></li> |] 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 = [<ul class="reform-error-list"><% mapM mkError errs %></ul>]- mkError e = <li><% e %></li>+ mkErrors errs = [hsx| [<ul class="reform-error-list"><% mapM mkError errs %></ul>] |]+ mkError e = [hsx| <li><% e %></li> |] br :: (Monad m, XMLGenerator x, StringType x ~ Text) => Form m input error [XMLGenT x (XMLType x)] () ()-br = view [<br />]+br = view [hsx| [<br />] |] 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 -> [<fieldset class="reform"><% xml %></fieldset>]) frm+fieldset frm = mapView (\xml -> [hsx| [<fieldset class="reform"><% xml %></fieldset>] |]) 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 -> [<ol class="reform"><% xml %></ol>]) frm+ol frm = mapView (\xml -> [hsx| [<ol class="reform"><% xml %></ol>] |]) 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 -> [<ul class="reform"><% xml %></ul>]) frm+ul frm = mapView (\xml -> [hsx| [<ul class="reform"><% xml %></ul>] |]) 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 -> [<li class="reform"><% xml %></li>]) frm+li frm = mapView (\xml -> [hsx| [<li class="reform"><% xml %></li>] |]) frm -- | create @\<form action=action method=\"POST\" enctype=\"multipart/form-data\"\>@ form :: (XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text action)) =>@@ -317,14 +317,15 @@ -> [XMLGenT x (XMLType x)] -- ^ children -> [XMLGenT x (XMLType x)] form action hidden children- = [ <form action=action method="POST" enctype="multipart/form-data">+ = [hsx|+ [ <form action=action method="POST" enctype="multipart/form-data"> <% mapM mkHidden hidden %> <% children %> </form>- ]+ ] |] where mkHidden (name, value) =- <input type="hidden" name=name value=value />+ [hsx| <input type="hidden" name=name value=value /> |] setAttrs :: (EmbedAsAttr x attr, XMLGenerator x, StringType x ~ Text, Monad m, Functor m) => Form m input error [GenXML x] proof a
reform-hsp.cabal view
@@ -1,5 +1,5 @@ Name: reform-hsp-Version: 0.2.5+Version: 0.2.6 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/@@ -13,9 +13,9 @@ Cabal-version: >=1.6 source-repository head- type: darcs+ type: git subdir: reform-hsp- location: http://hub.darcs.net/stepcut/reform+ location: https://github.com/Happstack/reform.git Library Exposed-modules: Text.Reform.HSP.Common@@ -23,5 +23,6 @@ Text.Reform.HSP.Text Build-depends: base > 4 && <5, hsp >= 0.9 && < 0.11,+ hsx2hs >= 0.13 && < 0.14, reform >= 0.2.1 && < 0.3, text >= 0.11 && < 1.3