reform-lucid 0.0.1.2 → 0.1.0.0

raw patch · 5 files changed

+439/−608 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Text/Reform/Lucid.hs +437/−0
• Text/Reform/Lucid/Common.hs +0/−387
• Text/Reform/Lucid/String.hs +0/−108
• Text/Reform/Lucid/Text.hs +0/−109
• reform-lucid.cabal +2/−4

@@ -0,0 +1,437 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Text.Reform.Lucid where++import Data.Foldable (traverse_)+import Data.Monoid ((<>), mconcat, mempty)+import Data.Text (Text)+import qualified Data.Text as T+import Lucid+import qualified Text.Read+import Text.Reform.Backend+import Text.Reform.Core+import Text.Reform.Generalized as G+import Text.Reform.Result (FormId, Result (Ok), unitRange)+import Web.PathPieces++instance PathPiece FormId where++  toPathPiece fid = T.pack (show fid)++  fromPathPiece fidT = Nothing++inputText+  :: (Monad m, FormError error, PathPiece text, Applicative f)+  => (input -> Either error text)+  -> text+  -> Form m input error (HtmlT f ()) () text+inputText getInput initialValue = G.input getInput inputField initialValue+  where+    inputField i a = input_ [type_ "text", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]++inputPassword+  :: (Monad m, FormError error, PathPiece text, Applicative f)+  => (input -> Either error text)+  -> text+  -> Form m input error (HtmlT f ()) () text+inputPassword getInput initialValue = G.input getInput inputField initialValue+  where+    inputField i a = input_ [type_ "password", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]++inputSubmit+  :: (Monad m, FormError error, PathPiece text, Applicative f)+  => (input -> Either error text)+  -> text+  -> Form m input error (HtmlT f ()) () (Maybe text)+inputSubmit getInput initialValue = G.inputMaybe getInput inputField initialValue+  where+    inputField i a = input_ [type_ "submit", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]++inputReset+  :: (Monad m, FormError error, PathPiece text, Applicative f)+  => text+  -> Form m input error (HtmlT f ()) () ()+inputReset lbl = G.inputNoData inputField lbl+  where+    inputField i a = input_ [type_ "submit", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]++inputHidden+  :: (Monad m, FormError error, PathPiece text, Applicative f)+  => (input -> Either error text)+  -> text+  -> Form m input error (HtmlT f ()) () text+inputHidden getInput initialValue = G.input getInput inputField initialValue+  where+    inputField i a = input_ [type_ "hidden", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]++inputButton+  :: (Monad m, FormError error, PathPiece text, Applicative f)+  => text+  -> Form m input error (HtmlT f ()) () ()+inputButton label = G.inputNoData inputField label+  where+    inputField i a = input_ [type_ "button", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]++textarea+  :: (Monad m, FormError error, ToHtml text, Monad f)+  => (input -> Either error text)+  -> Int -- ^ cols+  -> Int -- ^ rows+  -> text -- ^ initial text+  -> Form m input error (HtmlT f ()) () text+textarea getInput cols rows initialValue = G.input getInput textareaView initialValue+  where+    textareaView i txt =+      textarea_+        [ rows_ (toPathPiece rows)+        , cols_ (toPathPiece cols)+        , id_ (toPathPiece i)+        , name_ (toPathPiece i)+        ] $+        toHtml txt++-- | Create an @\<input type=\"file\"\>@ 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, Applicative f)+  => Form m input error (HtmlT f ()) () (FileType input)+inputFile = G.inputFile fileView+  where+    fileView i = input_ [type_ "file", id_ (toPathPiece i), name_ (toPathPiece i)]++-- | Create a @\<button type=\"submit\"\>@ element+buttonSubmit+  :: (Monad m, FormError error, PathPiece text, ToHtml children, Monad f)+  => (input -> Either error text)+  -> text+  -> children+  -> Form m input error (HtmlT f ()) () (Maybe text)+buttonSubmit getInput text c = G.inputMaybe getInput inputField text+  where+    inputField i a = button_ [type_ "submit", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)] $ toHtml c++-- | create a  @\<button type=\"reset\"\>\<\/button\>@ element+--+-- This element does not add any data to the form data set.+buttonReset+  :: (Monad m, FormError error, ToHtml children, Monad f)+  => children+  -> Form m input error (HtmlT f ()) () ()+buttonReset c = G.inputNoData inputField Nothing+  where+    inputField i a = button_ [type_ "reset", id_ (toPathPiece i), name_ (toPathPiece i)] $ toHtml c++-- | create a  @\<button type=\"button\"\>\<\/button\>@ element+--+-- This element does not add any data to the form data set.+button+  :: (Monad m, FormError error, ToHtml children, Monad f)+  => children+  -> Form m input error (HtmlT f ()) () ()+button c = G.inputNoData inputField Nothing+  where+    inputField i a = button_ [type_ "button", id_ (toPathPiece i), name_ (toPathPiece i)] $ toHtml c++-- | create a @\<label\>@ element.+--+-- Use this with <++ or ++> to ensure that the @for@ attribute references the correct @id@.+--+-- > label "some input field: " ++> inputText ""+label+  :: (Monad m, Monad f)+  => HtmlT f ()+  -> Form m input error (HtmlT f ()) () ()+label c = G.label mkLabel+  where+    mkLabel i = label_ [for_ (toPathPiece i)] c++arbitraryHtml :: Monad m => view -> Form m input error view () ()+arbitraryHtml wrap =+  Form $ do+    id' <- getFormId+    pure+      ( View (const $ wrap)+      , pure+        ( Ok $ Proved+          { proofs = ()+          , pos = unitRange id'+          , unProved = ()+          }+        )+      )++inputInt+  :: (Monad m, FormError err, Applicative f)+  => (input -> Either err Int)+  -> Int+  -> Form m input err (HtmlT f ()) () Int+inputInt getInput initialValue = G.input getInput inputField initialValue+  where+    min = toPathPiece (minBound :: Int)+    {-# INLINE min #-}+    max = toPathPiece (maxBound :: Int)+    {-# INLINE max #-}+    inputField i a =+      input_+        [ type_ "number"+        , id_ (toPathPiece i)+        , name_ (toPathPiece i)+        , value_ (toPathPiece a)+        , min_ min+        , max_ max+        ]++inputDouble+  :: (Monad m, FormError err, Applicative f)+  => (input -> Either err Double)+  -> Double+  -> Form m input err (HtmlT f ()) () Double+inputDouble getInput initialValue = G.input getInput inputField initialValue+  where+    inputField i a = input_ [type_ "number", step_ "any", id_ (toPathPiece i), name_ (toPathPiece i), value_ (T.pack $ show a)]++-- | Create a single @\<input type=\"checkbox\"\>@ element+--+-- returns a 'Bool' indicating if it was checked or not.+--+-- see also 'inputCheckboxes'+-- FIXME: Should this built on something in Generalized?+inputCheckbox+  :: forall x error input m f. (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f)+  => Bool -- ^ initially checked+  -> Form m input error (HtmlT f ()) () 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 =+      let checkbox =+            input_ $+              (if checked then (:) checked_ else id)+                [type_ "checkbox", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece i)]+       in pure+            ( View $ const $ checkbox+            , pure $+              Ok+                ( Proved+                  { proofs = ()+                  , pos = unitRange i+                  , unProved = if checked then True else False+                  }+                )+            )++-- | Create a group of @\<input type=\"checkbox\"\>@ elements+--+inputCheckboxes+  :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToHtml lbl, Monad f)+  => [(a, lbl)] -- ^ value, label, initially checked+  -> (a -> Bool) -- ^ function which indicates if a value should be checked initially+  -> Form m input error (HtmlT f ()) () [a]+inputCheckboxes choices isChecked =+  G.inputMulti choices mkCheckboxes isChecked+  where+    mkCheckboxes nm choices' = mconcat $ concatMap (mkCheckbox nm) choices'+    mkCheckbox nm (i, val, lbl, checked) =+      [ input_ $+          ( (if checked then (checked_ :) else id)+            [type_ "checkbox", id_ (toPathPiece i), name_ (toPathPiece nm), value_ (toPathPiece val)]+          )+      , label_ [for_ (toPathPiece i)] $ toHtml lbl+      ]++-- | Create a group of @\<input type=\"radio\"\>@ elements+inputRadio+  :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToHtml lbl, Monad f)+  => [(a, lbl)] -- ^ value, label, initially checked+  -> (a -> Bool) -- ^ isDefault+  -> Form m input error (HtmlT f ()) () a+inputRadio choices isDefault =+  G.inputChoice isDefault choices mkRadios+  where+    mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'+    mkRadio nm (i, val, lbl, checked) =+      [ input_ $+          (if checked then (checked_ :) else id)+            [type_ "radio", id_ (toPathPiece i), name_ (toPathPiece nm), value_ (toPathPiece val)]+      , label_ [for_ (toPathPiece i)] $ toHtml lbl+      , br_ []+      ]++-- | create @\<select\>\<\/select\>@ element plus its @\<option\>\<\/option\>@ children.+--+-- see also: 'selectMultiple'+select+  :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToHtml lbl, Monad f)+  => [(a, lbl)] -- ^ value, label+  -> (a -> Bool) -- ^ isDefault, must match *exactly one* element in the list of choices+  -> Form m input error (HtmlT f ()) () a+select choices isDefault =+  G.inputChoice isDefault choices mkSelect+  where+    mkSelect :: (ToHtml lbl, Monad f) => FormId -> [(a, Int, lbl, Bool)] -> HtmlT f ()+    mkSelect nm choices' =+      select_ [name_ (toPathPiece nm)] $+        traverse_ mkOption choices'+    mkOption :: (ToHtml lbl, Monad f) => (a, Int, lbl, Bool) -> HtmlT f ()+    mkOption (_, val, lbl, selected) =+      option_+        ( (if selected then ((:) (selected_ "selected")) else id)+          [value_ (toPathPiece val)]+        )+        (toHtml lbl)++-- | create @\<select multiple=\"multiple\"\>\<\/select\>@ element plus its @\<option\>\<\/option\>@ children.+--+-- This creates a @\<select\>@ element which allows more than one item to be selected.+selectMultiple+  :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToHtml lbl, Monad f)+  => [(a, lbl)] -- ^ value, label, initially checked+  -> (a -> Bool) -- ^ isSelected initially+  -> Form m input error (HtmlT f ()) () [a]+selectMultiple choices isSelected =+  G.inputMulti choices mkSelect isSelected+  where+    mkSelect :: (ToHtml lbl, Monad f) => FormId -> [(a, Int, lbl, Bool)] -> HtmlT f ()+    mkSelect nm choices' =+      select_ [name_ (toPathPiece nm), multiple_ "multiple"] $+        traverse_ mkOption choices'+    mkOption :: (ToHtml lbl, Monad f) => (a, Int, lbl, Bool) -> HtmlT f ()+    mkOption (_, val, lbl, selected) =+      option_+        ( (if selected then ((:) (selected_ "selected")) else id)+          [value_ (toPathPiece val)]+        )+        (toHtml lbl)++{-+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, Applicative f) =>+                   [(groupLbl, [(a, lbl, Bool)])]  -- ^ value, label, initially checked+                -> Form m input error (HtmlT f ()) () [a]+inputMultiSelectOptGroup choices =+    G.inputMulti choices mkSelect+    where+      mkSelect nm choices' =+          [<select name=nm multiple="multiple">+            <% mapM mkOptGroup choices' %>+           </select>+          ]+      mkOptGroup (grpLabel, options) =+          <optgroup label=grpLabel>+           <% mapM mkOption options %>+          </optgroup>+      mkOption (_, val, lbl, selected) =+          <option value=val (if selected then ["selected" := "selected"] else [])>+           <% lbl %>+          </option>+-}++-- | create a @\<ul\>@ which contains all the errors related to the 'Form'.+--+-- The @<\ul\>@ will have the attribute @class=\"reform-error-list\"@.+errorList+  :: (Monad m, ToHtml error, Monad f)+  => Form m input error (HtmlT f ()) () ()+errorList = G.errors mkErrors+  where+    mkErrors :: Monad f => ToHtml a => [a] -> HtmlT f ()+    mkErrors [] = mempty+    mkErrors errs = ul_ [class_ "reform-error-list"] $ traverse_ mkError errs+    mkError :: Monad f => ToHtml a => a -> HtmlT f ()+    mkError e = li_ [] $ toHtml e++-- | create a @\<ul\>@ which contains all the errors related to the 'Form'.+--+-- Includes errors from child forms.+--+-- The @<\ul\>@ will have the attribute @class=\"reform-error-list\"@.+childErrorList+  :: (Monad m, ToHtml error, Monad f)+  => Form m input error (HtmlT f ()) () ()+childErrorList = G.childErrors mkErrors+  where+    mkErrors :: Monad f => ToHtml a => [a] -> HtmlT f ()+    mkErrors [] = mempty+    mkErrors errs = ul_ [class_ "reform-error-list"] $ traverse_ mkError errs+    mkError :: Monad f => ToHtml a => a -> HtmlT f ()+    mkError e = li_ [] $ toHtml e++-- | create a @\<br\>@ tag.+br :: (Monad m, Applicative f) => Form m input error (HtmlT f ()) () ()+br = view (br_ [])++-- | wrap a @\<fieldset class=\"reform\"\>@ around a 'Form'+--+fieldset+  :: (Monad m, Functor m, Applicative f)+  => Form m input error (HtmlT f ()) proof a+  -> Form m input error (HtmlT f ()) proof a+fieldset frm = mapView (fieldset_ [class_ "reform"]) frm++-- | wrap an @\<ol class=\"reform\"\>@ around a 'Form'+ol+  :: (Monad m, Functor m, Applicative f)+  => Form m input error (HtmlT f ()) proof a+  -> Form m input error (HtmlT f ()) proof a+ol frm = mapView (ol_ [class_ "reform"]) frm++-- | wrap a @\<ul class=\"reform\"\>@ around a 'Form'+ul+  :: (Monad m, Functor m, Applicative f)+  => Form m input error (HtmlT f ()) proof a+  -> Form m input error (HtmlT f ()) proof a+ul frm = mapView (ul_ [class_ "reform"]) frm++-- | wrap a @\<li class=\"reform\"\>@ around a 'Form'+li+  :: (Monad m, Functor m, Applicative f)+  => Form m input error (HtmlT f ()) proof a+  -> Form m input error (HtmlT f ()) proof a+li frm = mapView (li_ [class_ "reform"]) frm++-- | create @\<form action=action method=\"GET\" enctype=\"multipart/form-data\"\>@+formGenGET+  :: (Applicative m)+  => Text -- ^ action url+  -> [(Text, Text)] -- ^ hidden fields to add to form+  -> HtmlT m b+  -> HtmlT m b+formGenGET action hidden children = do+  form_ [action_ action, method_ "GET", enctype_ "multipart/form-data"] $+    traverse_ mkHidden hidden *>+    children+  where+    mkHidden (name, value) = input_ [type_ "hidden", name_ name, value_ value]++-- | create @\<form action=action method=\"POST\" enctype=\"multipart/form-data\"\>@+formGenPOST+  :: (Applicative m)+  => Text -- ^ action url+  -> [(Text, Text)] -- ^ hidden fields to add to form+  -> HtmlT m b+  -> HtmlT m b+formGenPOST action hidden children = do+  form_ [action_ action, method_ "POST", enctype_ "multipart/form-data"] $+    traverse_ mkHidden hidden *>+    children+  where+    mkHidden (name, value) = input_ [type_ "hidden", name_ name, value_ value]++-- | add an attribute to the 'Html' for a form element.+setAttr+  :: (Monad m, Functor m, Applicative f)+  => Form m input error (HtmlT f ()) proof a+  -> [Attribute]+  -> Form m input error (HtmlT f ()) proof a+setAttr form attr = mapView (\x -> x `with` attr) form

@@ -1,387 +0,0 @@-{-# LANGUAGE -    OverloadedStrings-  , ScopedTypeVariables-  , TypeFamilies -#-}--module Text.Reform.Lucid.Common where--import Data.Monoid (mconcat, mempty, (<>))-import Lucid-import Data.Text (Text)-import Text.Reform.Backend-import Text.Reform.Core-import Text.Reform.Generalized as G-import Text.Reform.Result (FormId, Result(Ok), unitRange)-import Web.PathPieces-import Data.Foldable (traverse_)-import qualified Text.Read-import qualified Data.Text as T--instance PathPiece FormId where-  toPathPiece fid = T.pack (show fid)-  fromPathPiece fidT = Nothing--inputText :: (Monad m, FormError error, PathPiece text, Applicative f) =>-             (input -> Either error text)-          -> text-          -> Form m input error (HtmlT f ()) () text-inputText getInput initialValue = G.input getInput inputField initialValue-    where-      inputField i a = input_ [type_ "text", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]--inputPassword :: (Monad m, FormError error, PathPiece text, Applicative f) =>-             (input -> Either error text)-          -> text-          -> Form m input error (HtmlT f ()) () text-inputPassword getInput initialValue = G.input getInput inputField initialValue-    where-      inputField i a = input_ [type_ "password", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]--inputSubmit :: (Monad m, FormError error, PathPiece text, Applicative f) =>-             (input -> Either error text)-          -> text-          -> Form m input error (HtmlT f ()) () (Maybe text)-inputSubmit getInput initialValue = G.inputMaybe getInput inputField initialValue-    where-      inputField i a = input_ [type_ "submit", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]--inputReset :: (Monad m, FormError error, PathPiece text, Applicative f) =>-              text-           -> Form m input error (HtmlT f ()) () ()-inputReset lbl = G.inputNoData inputField lbl-    where-      inputField i a = input_ [type_ "submit", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]--inputHidden :: (Monad m, FormError error, PathPiece text, Applicative f) =>-             (input -> Either error text)-          -> text-          -> Form m input error (HtmlT f ()) () text-inputHidden getInput initialValue = G.input getInput inputField initialValue-    where-      inputField i a = input_ [type_ "hidden", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]--inputButton :: (Monad m, FormError error, PathPiece text, Applicative f) =>-             text-          -> Form m input error (HtmlT f ()) () ()-inputButton label = G.inputNoData inputField label-    where-      inputField i a = input_ [type_ "button", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]---textarea :: (Monad m, FormError error, ToHtml text, Monad f) =>-            (input -> Either error text)-         -> Int    -- ^ cols-         -> Int    -- ^ rows-         -> text   -- ^ initial text-         -> Form m input error (HtmlT f ()) () text-textarea getInput cols rows initialValue = G.input getInput textareaView initialValue-    where-      textareaView i txt =-          textarea_ [ rows_ (toPathPiece rows)-                    , cols_ (toPathPiece cols)-                    , id_   (toPathPiece i)-                    , name_ (toPathPiece i)-                    ] $ toHtml txt----- | Create an @\<input type=\"file\"\>@ 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, Applicative f) =>-             Form m input error (HtmlT f ()) () (FileType input)-inputFile = G.inputFile fileView-    where-      fileView i = input_ [type_ "file", id_ (toPathPiece i), name_ (toPathPiece i)]----- | Create a @\<button type=\"submit\"\>@ element-buttonSubmit :: (Monad m, FormError error, PathPiece text, ToHtml children, Monad f) =>-                (input -> Either error text)-             -> text-             -> children-             -> Form m input error (HtmlT f ()) () (Maybe text)-buttonSubmit getInput text c = G.inputMaybe getInput inputField text-    where-      inputField i a = button_ [type_ "submit", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)] $ toHtml c---- | create a  @\<button type=\"reset\"\>\<\/button\>@ element------ This element does not add any data to the form data set.-buttonReset :: (Monad m, FormError error, ToHtml children, Monad f) =>-               children-             -> Form m input error (HtmlT f ()) () ()-buttonReset c = G.inputNoData inputField Nothing-    where-      inputField i a = button_ [type_ "reset", id_ (toPathPiece i), name_ (toPathPiece i)] $ toHtml c---- | create a  @\<button type=\"button\"\>\<\/button\>@ element------ This element does not add any data to the form data set.-button :: (Monad m, FormError error, ToHtml children, Monad f) =>-          children-       -> Form m input error (HtmlT f ()) () ()-button c = G.inputNoData inputField Nothing-    where-      inputField i a = button_ [type_ "button", id_ (toPathPiece i), name_ (toPathPiece i)] $ toHtml c----- | create a @\<label\>@ element.------ Use this with <++ or ++> to ensure that the @for@ attribute references the correct @id@.------ > label "some input field: " ++> inputText ""-label :: (Monad m, Monad f) -  => HtmlT f ()-  -> Form m input error (HtmlT f ()) () ()-label c = G.label mkLabel-  where-  mkLabel i = label_ [for_ (toPathPiece i)] c--arbitraryHtml :: Monad m => view -> Form m input error view () ()-arbitraryHtml wrap = Form $ do-    id' <- getFormId-    return ( View (const $ wrap)-           , return (Ok $ Proved { proofs   = ()-                                 , pos      = unitRange id'-                                 , unProved = ()-                                 })-           )--inputInt :: (Monad m, FormError err, Applicative f)-  => (input -> Either err Int)-  -> Int-  -> Form m input err (HtmlT f ()) () Int-inputInt getInput initialValue = G.input getInput inputField initialValue-  where-  inputField i a = input_ [type_ "number", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece a)]--inputDouble :: (Monad m, FormError err, Applicative f)-  => (input -> Either err Double)-  -> Double-  -> Form m input err (HtmlT f ()) () Double-inputDouble getInput initialValue = G.input getInput inputField initialValue-  where-  inputField i a = input_ [type_ "number", step_ "any", id_ (toPathPiece i), name_ (toPathPiece i), value_ (T.pack $ show a)]---- | Create a single @\<input type=\"checkbox\"\>@ element------ returns a 'Bool' indicating if it was checked or not.------ see also 'inputCheckboxes'--- FIXME: Should this built on something in Generalized?-inputCheckbox :: forall x error input m f. (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-                   Bool  -- ^ initially checked-                -> Form m input error (HtmlT f ()) () 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 =-          let checkbox  = input_ $ (if checked then (:) checked_ else id) -                                   [type_ "checkbox", id_ (toPathPiece i), name_ (toPathPiece i), value_ (toPathPiece i)]-          in-          return ( View $ const $ checkbox-                 , return $ Ok (Proved { proofs   = ()-                                       , pos      = unitRange i-                                       , unProved = if checked then True else False-                                       })-                 )---- | Create a group of @\<input type=\"checkbox\"\>@ elements----inputCheckboxes :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToHtml lbl, Monad f) =>-                  [(a, lbl)]  -- ^ value, label, initially checked-                -> (a -> Bool) -- ^ function which indicates if a value should be checked initially-                -> Form m input error (HtmlT f ()) () [a]-inputCheckboxes choices isChecked =-    G.inputMulti choices mkCheckboxes isChecked-    where-      mkCheckboxes nm choices' = mconcat $ concatMap (mkCheckbox nm) choices'-      mkCheckbox nm (i, val, lbl, checked) =-          [ input_ $ ((if checked then (checked_ :) else id)-                     [type_ "checkbox", id_ (toPathPiece i), name_ (toPathPiece nm), value_ (toPathPiece val)])-          , label_ [for_ (toPathPiece i)] $ toHtml lbl-          ]---- | Create a group of @\<input type=\"radio\"\>@ elements-inputRadio :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToHtml lbl, Monad f) =>-              [(a, lbl)]  -- ^ value, label, initially checked-           -> (a -> Bool) -- ^ isDefault-           -> Form m input error (HtmlT f ()) () a-inputRadio choices isDefault =-    G.inputChoice isDefault choices mkRadios-    where-      mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'-      mkRadio nm (i, val, lbl, checked) =-          [  input_ $ (if checked then (checked_ :) else id)-                      [type_ "radio", id_ (toPathPiece i), name_ (toPathPiece nm), value_ (toPathPiece val)]-          ,  label_ [for_ (toPathPiece i)] $ toHtml lbl-          ,  br_ []-          ]---- | create @\<select\>\<\/select\>@ element plus its @\<option\>\<\/option\>@ children.------ see also: 'selectMultiple'-select :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToHtml lbl, Monad f) -  => [(a, lbl)]  -- ^ value, label-  -> (a -> Bool) -- ^ isDefault, must match *exactly one* element in the list of choices-  -> Form m input error (HtmlT f ()) () a-select choices isDefault  =-  G.inputChoice isDefault choices mkSelect-  where-  mkSelect :: (ToHtml lbl, Monad f) => FormId -> [(a, Int, lbl, Bool)] -> HtmlT f ()-  mkSelect nm choices' =-    select_ [name_ (toPathPiece nm)] $-      traverse_ mkOption choices'--  mkOption :: (ToHtml lbl, Monad f) => (a, Int, lbl, Bool) -> HtmlT f ()-  mkOption (_, val, lbl, selected) =-    option_ -      ( (if selected then ((:) (selected_ "selected")) else id)-        [value_ (toPathPiece val)]-      )-      (toHtml lbl)---- | create @\<select multiple=\"multiple\"\>\<\/select\>@ element plus its @\<option\>\<\/option\>@ children.------ This creates a @\<select\>@ element which allows more than one item to be selected.-selectMultiple :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToHtml lbl, Monad f)-  => [(a, lbl)]  -- ^ value, label, initially checked-  -> (a -> Bool)  -- ^ isSelected initially-  -> Form m input error (HtmlT f ()) () [a]-selectMultiple choices isSelected =-  G.inputMulti choices mkSelect isSelected-  where-  mkSelect :: (ToHtml lbl, Monad f) => FormId -> [(a, Int, lbl, Bool)] -> HtmlT f ()-  mkSelect nm choices' =-    select_ [name_ (toPathPiece nm), multiple_ "multiple"] $-      traverse_ mkOption choices'--  mkOption :: (ToHtml lbl, Monad f) => (a, Int, lbl, Bool) -> HtmlT f ()-  mkOption (_, val, lbl, selected) = option_-    ( (if selected then ((:) (selected_ "selected")) else id)-      [value_ (toPathPiece val)]-    ) -    (toHtml lbl)--{--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, Applicative f) =>-                   [(groupLbl, [(a, lbl, Bool)])]  -- ^ value, label, initially checked-                -> Form m input error (HtmlT f ()) () [a]-inputMultiSelectOptGroup choices =-    G.inputMulti choices mkSelect-    where-      mkSelect nm choices' =-          [<select name=nm multiple="multiple">-            <% mapM mkOptGroup choices' %>-           </select>-          ]-      mkOptGroup (grpLabel, options) =-          <optgroup label=grpLabel>-           <% mapM mkOption options %>-          </optgroup>-      mkOption (_, val, lbl, selected) =-          <option value=val (if selected then ["selected" := "selected"] else [])>-           <% lbl %>-          </option>--}---- | create a @\<ul\>@ which contains all the errors related to the 'Form'.------ The @<\ul\>@ will have the attribute @class=\"reform-error-list\"@.-errorList :: (Monad m, ToHtml error, Monad f) =>-             Form m input error (HtmlT f ()) () ()-errorList = G.errors mkErrors-  where-  mkErrors :: Monad f => ToHtml a => [a] -> HtmlT f ()-  mkErrors []   = mempty-  mkErrors errs = ul_ [class_ "reform-error-list"] $ traverse_ mkError errs-  mkError :: Monad f => ToHtml a => a -> HtmlT f ()-  mkError e     = li_ [] $ toHtml e---- | create a @\<ul\>@ which contains all the errors related to the 'Form'.------ Includes errors from child forms.------ The @<\ul\>@ will have the attribute @class=\"reform-error-list\"@.-childErrorList :: (Monad m, ToHtml error, Monad f) =>-             Form m input error (HtmlT f ()) () ()-childErrorList = G.childErrors mkErrors-  where-  mkErrors :: Monad f => ToHtml a => [a] -> HtmlT f ()-  mkErrors []   = mempty-  mkErrors errs = ul_ [class_ "reform-error-list"] $ traverse_ mkError errs-  mkError :: Monad f => ToHtml a => a -> HtmlT f ()-  mkError e     = li_ [] $ toHtml e----- | create a @\<br\>@ tag.-br :: (Monad m, Applicative f) => Form m input error (HtmlT f ()) () ()-br = view (br_ [])---- | wrap a @\<fieldset class=\"reform\"\>@ around a 'Form'----fieldset :: (Monad m, Functor m, Applicative f) =>-            Form m input error (HtmlT f ()) proof a-         -> Form m input error (HtmlT f ()) proof a-fieldset frm = mapView (fieldset_ [class_ "reform"]) frm---- | wrap an @\<ol class=\"reform\"\>@ around a 'Form'-ol :: (Monad m, Functor m, Applicative f) =>-      Form m input error (HtmlT f ()) proof a-   -> Form m input error (HtmlT f ()) proof a-ol frm = mapView (ol_ [class_ "reform"]) frm---- | wrap a @\<ul class=\"reform\"\>@ around a 'Form'-ul :: (Monad m, Functor m, Applicative f) =>-      Form m input error (HtmlT f ()) proof a-   -> Form m input error (HtmlT f ()) proof a-ul frm = mapView (ul_ [class_ "reform"]) frm---- | wrap a @\<li class=\"reform\"\>@ around a 'Form'-li :: (Monad m, Functor m, Applicative f) =>-      Form m input error (HtmlT f ()) proof a-   -> Form m input error (HtmlT f ()) proof a-li frm = mapView (li_ [class_ "reform"]) frm---- | create @\<form action=action method=\"GET\" enctype=\"multipart/form-data\"\>@-formGenGET :: (Applicative m)-  => Text -- ^ action url-  -> [(Text,Text)] -- ^ hidden fields to add to form-  -> HtmlT m b-  -> HtmlT m b-formGenGET action hidden children = do -  form_ [action_ action, method_ "GET", enctype_ "multipart/form-data"] $-       traverse_ mkHidden hidden-    *> children-  where-  mkHidden (name, value) = input_ [type_ "hidden", name_ name, value_ value]---- | create @\<form action=action method=\"POST\" enctype=\"multipart/form-data\"\>@-formGenPOST :: (Applicative m)-  => Text -- ^ action url-  -> [(Text,Text)] -- ^ hidden fields to add to form-  -> HtmlT m b-  -> HtmlT m b-formGenPOST action hidden children = do -  form_ [action_ action, method_ "POST", enctype_ "multipart/form-data"] $-       traverse_ mkHidden hidden-    *> children-  where-  mkHidden (name, value) = input_ [type_ "hidden", name_ name, value_ value]---- | add an attribute to the 'Html' for a form element.-setAttr :: (Monad m, Functor m, Applicative f) =>-           Form m input error (HtmlT f ()) proof a-         -> [Attribute]-         -> Form m input error (HtmlT f ()) proof a-setAttr form attr = mapView (\x -> x `with` attr) form

@@ -1,108 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances, ViewPatterns #-}-{- |-This module provides functions creating Reform using lucid 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.Blaze.Text".---}-module Text.Reform.Lucid.String-    ( -- * \<input\> element-      inputText-    , inputPassword-    , inputSubmit-    , inputReset-    , inputHidden-    , inputButton-    , C.inputCheckbox-    , C.inputCheckboxes-    , C.inputRadio-    , C.inputFile-      -- * \<textarea\> element-    , textarea-      -- * \<button\> element-    , buttonSubmit-    , C.buttonReset-    , C.button-      -- * \<select\> element-    , C.select-    , C.selectMultiple-      -- * \<label\> element-    , C.label-      -- * errors-    , C.errorList-    , C.childErrorList-      -- * layout functions-    , C.br-    , C.fieldset-    , C.ol-    , C.ul-    , C.li-    , C.formGenGET-    , C.formGenPOST-    ) where--import Lucid (ToHtml, HtmlT)-import Text.Reform-import qualified Text.Reform.Lucid.Common as C---- | Create an @\<input type=\"text\"\>@ element-inputText :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-               String -- ^ initial value-            -> Form m input error (HtmlT f ()) () String-inputText initialValue = C.inputText getInputString initialValue---- | Create an @\<input type=\"password\"\>@ element-inputPassword :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-                 Form m input error (HtmlT f ()) () String-inputPassword = C.inputPassword getInputString ""---- | Create an @\<input type=\"submit\"\>@ 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, Applicative f) =>-               String -- ^ @value@ attribute. Used for button label, and value if button is submitted.-            -> Form m input error (HtmlT f ()) () (Maybe String)-inputSubmit initialValue = C.inputSubmit getInputString initialValue---- | Create an @\<input type=\"reset\"\>@ element------ This element does not add any data to the form data set.-inputReset :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-              String -- ^ value attribute. Used only to label the button.-           -> Form m input error (HtmlT f ()) () ()-inputReset = C.inputReset---- | Create an @\<input type=\"hidden\"\>@ element-inputHidden :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-               String -- ^ value to store in the hidden element-            -> Form m input error (HtmlT f ()) () String-inputHidden initialValue = C.inputHidden getInputString initialValue---- | Create an @\<input type=\"button\"\>@ 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, Applicative f) =>-               String -- ^ value attribute. Used to label the button.-            -> Form m input error (HtmlT f ()) () ()-inputButton label = C.inputButton label---- | Create a \<textarea\>\<\/textarea\> element-textarea :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Monad f) =>-            Int    -- ^ cols-         -> Int    -- ^ rows-         -> String -- ^ initial contents-         -> Form m input error (HtmlT f ()) () String-textarea rows cols initialValue = C.textarea getInputString rows cols initialValue---- | create a  @\<button type=\"submit\"\>\<\/button\>@ element-buttonSubmit :: ( Monad m, FormError error, FormInput input, ErrorInputType error ~ input, ToHtml children, Monad f) =>-                String -- ^ value attribute. Returned if this button submits the form.-             -> children -- ^ children to embed in the \<button\>-             -> Form m input error (HtmlT f ()) () (Maybe String)-buttonSubmit = C.buttonSubmit getInputString

@@ -1,109 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances, ViewPatterns #-}-{- |-This module provides functions creating Reform using lucid markup.--This module assumes that you wish for text based controls such as 'inputText' and 'textarea' to using 'Text' values. If you prefer 'String' see "Text.Reform.Blaze.String".---}-module Text.Reform.Lucid.Text-    ( -- * \<input\> element-      inputText-    , inputPassword-    , inputSubmit-    , inputReset-    , inputHidden-    , inputButton-    , C.inputCheckbox-    , C.inputCheckboxes-    , C.inputRadio-    , C.inputFile-      -- * \<textarea\> element-    , textarea-      -- * \<button\> element-    , buttonSubmit-    , C.buttonReset-    , C.button-      -- * \<select\> element-    , C.select-    , C.selectMultiple-      -- * \<label\> element-    , C.label-      -- * errors-    , C.errorList-    , C.childErrorList-      -- * layout functions-    , C.br-    , C.fieldset-    , C.ol-    , C.ul-    , C.li-    , C.formGenGET-    , C.formGenPOST-    ) where--import Data.Text (Text, empty)-import Lucid (ToHtml, HtmlT)-import Text.Reform-import qualified Text.Reform.Lucid.Common as C---- | Create an @\<input type=\"text\"\>@ element-inputText :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-               Text -- ^ initial value-            -> Form m input error (HtmlT f ()) () Text-inputText initialValue = C.inputText getInputText initialValue---- | Create an @\<input type=\"password\"\>@ element-inputPassword :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-                 Form m input error (HtmlT f ()) () Text-inputPassword = C.inputPassword getInputText empty---- | Create an @\<input type=\"submit\"\>@ 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, Applicative f) =>-               Text -- ^ @value@ attribute. Used for button label, and value if button is submitted.-            -> Form m input error (HtmlT f ()) () (Maybe Text)-inputSubmit initialValue = C.inputSubmit getInputText initialValue---- | Create an @\<input type=\"reset\"\>@ element------ This element does not add any data to the form data set.-inputReset :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-              Text -- ^ value attribute. Used only to label the button.-           -> Form m input error (HtmlT f ()) () ()-inputReset = C.inputReset---- | Create an @\<input type=\"hidden\"\>@ element-inputHidden :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Applicative f) =>-               Text -- ^ value to store in the hidden element-            -> Form m input error (HtmlT f ()) () Text-inputHidden initialValue = C.inputHidden getInputText initialValue---- | Create an @\<input type=\"button\"\>@ 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, Applicative f) =>-               Text -- ^ value attribute. Used to label the button.-            -> Form m input error (HtmlT f ()) () ()-inputButton label = C.inputButton label---- | Create a \<textarea\>\<\/textarea\> element-textarea :: (Monad m, FormInput input, FormError error, ErrorInputType error ~ input, Monad f) =>-            Int    -- ^ cols-         -> Int    -- ^ rows-         -> Text -- ^ initial contents-         -> Form m input error (HtmlT f ()) () Text-textarea rows cols initialValue = C.textarea getInputText rows cols initialValue---- | create a  @\<button type=\"submit\"\>\<\/button\>@ element-buttonSubmit :: ( Monad m, FormError error, FormInput input, ErrorInputType error ~ input, ToHtml children, Monad f) =>-                Text -- ^ value attribute. Returned if this button submits the form.-             -> children -- ^ children to embed in the \<button\>-             -> Form m input error (HtmlT f ()) () (Maybe Text)-buttonSubmit = C.buttonSubmit getInputText

@@ -1,5 +1,5 @@ Name:                reform-lucid-Version:             0.0.1.2+Version:             0.1.0.0 Synopsis:            Add support for using lucid with Reform Description:         Reform is a library for building and validating forms using applicative functors. This package add support for using reform with lucid. License:             BSD3@@ -18,9 +18,7 @@  Library   exposed-modules: -    Text.Reform.Lucid.Common-    Text.Reform.Lucid.String-    Text.Reform.Lucid.Text+    Text.Reform.Lucid    build-depends:       base >4.5 && <5