packages feed

simple-form (empty) → 0.1

raw patch · 12 files changed

+1362/−0 lines, 12 filesdep +basedep +blaze-htmldep +digestive-functorssetup-changed

Dependencies added: base, blaze-html, digestive-functors, email-validate, network, old-locale, text, time, transformers

Files

+ COPYING view
@@ -0,0 +1,13 @@+Copyright © 2013, Stephen Paul Weber <singpolyma.net>++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ README view
@@ -0,0 +1,2 @@+Inspired by the RubyGem of the same name, this package allows you to+easily build validating forms that infer defaults based on type.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ SimpleForm.hs view
@@ -0,0 +1,519 @@+-- | Forms that configure themselves based on type+module SimpleForm (+	Widget,+	DefaultWidget(..),+	Input(..),+	-- * Options+	InputOptions(..),+	Label(..),+	-- * Wrappers+	ShowRead(..),+	unShowRead,+	SelectEnum(..),+	unSelectEnum,+	-- * Widgets+	button,+	hidden,+	checkbox,+	file,+	-- ** Text-like+	text,+	textarea,+	password,+	search,+	email,+	uri,+	tel,+	-- ** Numbers+	number,+	integral,+	boundedNumber,+	boundedIntegral,+	-- ** Dates and times+	date,+	time,+	datetime,+	datetime_local,+	-- ** Collections+	GroupedCollection,+	Collection,+	select,+	multi_select,+	radio_buttons,+	checkboxes,+	-- * Helpers+	input_tag,+	selectEnum,+	enum,+	group_,+	multiEnum,+	humanize,+	maybeCons,+	applyAttrs+) where++import Data.Maybe+import Data.Char (isUpper)+import Data.Monoid+import Data.Ratio+import Data.Function (on)+import Data.Foldable (foldl', forM_)+import Data.List (nubBy)+import Control.Arrow (first)+import Control.Applicative ((<|>))+import Control.Monad (join)+import Data.Time (UTCTime, LocalTime, ZonedTime, Day, TimeOfDay, formatTime, FormatTime)+import System.Locale (defaultTimeLocale, iso8601DateFormat)+import Text.Blaze.XHtml5 (Html, (!), toValue)+import qualified Text.Blaze.XHtml5 as HTML+import qualified Text.Blaze.XHtml5.Attributes as HTML hiding (label, span)+import qualified Text.Blaze.XHtml5.Attributes as HTMLA+import Data.Text (Text)+import qualified Data.Text as T+import Data.String++-- | Representation of an input widget in HTML+data Input = Input Html | MultiInput [Html] | SelfLabelInput Html++instance Monoid Input where+	mempty = Input mempty+	(Input x) `mappend` (Input y) = MultiInput [x,y]+	(Input x) `mappend` (MultiInput y) = MultiInput (x:y)+	(MultiInput x) `mappend` (Input y) = MultiInput (x ++ [y])+	(MultiInput x) `mappend` (MultiInput y) = MultiInput (x ++ y)+	(SelfLabelInput x) `mappend` y = Input x `mappend` y+	x `mappend` (SelfLabelInput y) = x `mappend` Input y++-- | A block label, inline label, or implied value label+data Label = Label Text | InlineLabel Text | DefaultLabel+	deriving (Show, Eq)++instance IsString Label where+	fromString = Label . fromString++-- | The setup for rendering an input. Blank is 'Data.Monoid.mempty'+data InputOptions = InputOptions {+		label :: Maybe Label,+		hint :: Maybe Text,+		required :: Bool,+		disabled :: Bool,+		input_html :: [(Text,Text)],+		label_html :: [(Text,Text)],+		error_html :: [(Text,Text)],+		hint_html :: [(Text,Text)],+		wrapper_html :: [(Text,Text)]+	} deriving (Show, Eq)++instance Monoid InputOptions where+	mempty = InputOptions {+		label = Just DefaultLabel,+		hint = Nothing,+		required = True,+		disabled = False,+		input_html = [],+		label_html = [],+		error_html = [],+		hint_html = [],+		wrapper_html = []+	}++	mappend a b = InputOptions {+		label = label (if label b == Just DefaultLabel then a else b),+		hint = monoidOr (hint b) (hint a),+		required = required (if required b then a else b),+		disabled = disabled (if not (disabled b) then a else b),+		input_html = input_html a ++ input_html b,+		label_html = label_html a ++ label_html b,+		error_html = error_html a ++ error_html b,+		hint_html = hint_html a ++ hint_html b,+		wrapper_html = wrapper_html a ++ wrapper_html b+	}++monoidOr :: (Monoid a, Eq a) => a -> a -> a+monoidOr a b+	| a == mempty = b+	| otherwise = a++-- | Format identifiers nicely for humans to read+humanize :: Text -> Text+humanize =+	T.unwords . map titleWord . titleFirstWord . T.words . T.concatMap go+	where+	titlecase word = T.toUpper (T.singleton $ T.head word)+		`T.append` T.tail word+	titleFirstWord [] = []+	titleFirstWord (w:ws) = titlecase w : ws+	titleWord word+		| T.length word < 4 = word+		| otherwise = titlecase word+	go c+		| isUpper c = T.singleton ' ' `T.append` T.toLower (T.singleton c)+		| c == '_' = T.singleton ' '+		| otherwise = T.singleton c++-- | Infer a 'Widget' based on type+class DefaultWidget a where+	wdef :: Widget a+	wdefList :: Widget [a]+	wdefList _ _ _ _ =+		-- Some things just can't be multi-selected (like Text)+		Input $ HTML.p $ HTML.toHtml "No useful multi-select box for this type."++instance (DefaultWidget a) => DefaultWidget [a] where+	wdef = wdefList++instance DefaultWidget Bool where+	wdef = checkbox+	wdefList = wdefList . fmap (map SelectEnum)++instance DefaultWidget Text where+	wdef = text++instance DefaultWidget Char where+	wdef = text . fmap T.singleton+	wdefList = text . fmap T.pack -- Heh, hack for 'String'++instance DefaultWidget Integer where+	wdef = integral++instance DefaultWidget Int where+	wdef = boundedIntegral+	wdefList = wdefList . fmap (map SelectEnum)++instance DefaultWidget Float where+	wdef = number++instance DefaultWidget Double where+	wdef = number++instance DefaultWidget UTCTime where+	wdef = datetime++instance DefaultWidget ZonedTime where+	wdef = datetime++instance DefaultWidget LocalTime where+	wdef = datetime_local++instance DefaultWidget Day where+	wdef = date++instance DefaultWidget TimeOfDay where+	wdef = time++instance (Integral a, Show a) => DefaultWidget (Ratio a) where+	wdef = number++instance (DefaultWidget a, DefaultWidget b) => DefaultWidget (a, b) where+	wdef v u n opt = wdef (fmap fst v) u n opt `mappend` wdef (fmap snd v) u n opt++instance (DefaultWidget a) => DefaultWidget (Maybe a) where+	wdef = wdef . join++-- | Wrapper for types that should be rendered using 'show'+newtype ShowRead a = ShowRead a deriving (Eq, Ord)++unShowRead :: ShowRead a -> a+unShowRead (ShowRead x) = x++instance (Show a, Read a) => Show (ShowRead a) where+	show (ShowRead x) = show x++instance (Read a) => Read (ShowRead a) where+	readsPrec n s = map (first ShowRead) (readsPrec n s)++instance (Show a, Read a) => DefaultWidget (ShowRead a) where+	wdef = text . fmap (T.pack . show)++-- | Wrapper for select boxes on enumerable types+newtype SelectEnum a = SelectEnum a deriving (Eq, Ord)++unSelectEnum :: SelectEnum a -> a+unSelectEnum (SelectEnum x) = x++instance (Show a, Read a) => Show (SelectEnum a) where+	show (SelectEnum x) = show x++instance (Read a) => Read (SelectEnum a) where+	readsPrec n s = map (first SelectEnum) (readsPrec n s)++instance (Bounded a) => Bounded (SelectEnum a) where+	minBound = SelectEnum minBound+	maxBound = SelectEnum maxBound++instance (Enum a) => Enum (SelectEnum a) where+	toEnum = SelectEnum . toEnum+	fromEnum (SelectEnum x) = fromEnum x++-- | Collection of items for the user to choose from, with optional grouping+--+-- A trivial 'GroupedCollection' (with just one, blankly-named group)+-- should be treated by 'Widget's as if it were just a 'Collection'+type GroupedCollection = [(Text, [(Text, Text)])]++-- | Collection of items for the user to choose from+type Collection = [(Text, Text)]++-- | Derive a collection from an enumerable type+selectEnum :: (Show a, Read a, Bounded a, Enum a) => a -> Collection+selectEnum v = map (\x -> let x' = T.pack $ show x in (x', humanize x')) opts+	where+	opts = [minBound `asTypeOf` v .. maxBound `asTypeOf` v]++-- | Feed a collection 'Widget' from an enumerable type+enum :: (Show a, Read a, Bounded a, Enum a) => (GroupedCollection -> Widget Text) -> Widget a+enum w v = w (group_ $ selectEnum $ fromJust v) (fmap (T.pack . show) v)++-- | Feed a multi-select collection 'Widget' from an enumerable type+multiEnum :: (Show a, Read a, Bounded a, Enum a) => (GroupedCollection -> Widget [Text]) -> Widget [a]+multiEnum w v = w (group_ $ selectEnum $ head $ fromJust v) (fmap (fmap (T.pack . show)) v)++-- | Push any 'Collection' to a trivial 'GroupedCollection'+group_ :: Collection -> GroupedCollection+group_ c = [(mempty, c)]++instance (Show a, Read a, Bounded a, Enum a) => DefaultWidget (SelectEnum a) where+	wdef = enum select+	wdefList = multiEnum multi_select++-- | The type of a widget renderer+type Widget a = (Maybe a -> Maybe Text -> Text -> InputOptions -> Input)++text :: Widget Text+text v u n = Input . input_tag n (v <|> u) (T.pack "text") []++password :: Widget Text+password v u n = Input . input_tag n (v <|> u) (T.pack "password") []++search :: Widget Text+search v u n = Input . input_tag n (v <|> u) (T.pack "search") []++email :: Widget Text+email v u n = Input . input_tag n (v <|> u) (T.pack "email") []++uri :: Widget Text+uri v u n = Input . input_tag n (v <|> u) (T.pack "url") []++tel :: Widget Text+tel v u n = Input . input_tag n (v <|> u) (T.pack "tel") []++number :: (Num a, Show a) => Widget a+number v u n =+	Input . input_tag n (fmap (T.pack . show) v <|> u) (T.pack "number") [+		[(T.pack "step", T.pack "any")]+	]++integral :: (Integral a, Show a) => Widget a+integral v u n =+	Input . input_tag n (fmap (T.pack . show) v <|> u) (T.pack "number") [+		[(T.pack "step", T.pack "1")]+	]++boundedNumber :: (Bounded a, Num a, Show a) => Widget a+boundedNumber v u n =+	Input . input_tag n (fmap (T.pack . show) v <|> u) (T.pack "number") [+		[(T.pack "step", T.pack "any")],+		[(T.pack "min", T.pack $ show (minBound `asTypeOf` fromJust v))],+		[(T.pack "max", T.pack $ show (maxBound `asTypeOf` fromJust v))]+	]++boundedIntegral :: (Bounded a, Integral a, Show a) => Widget a+boundedIntegral v u n =+	Input . input_tag n (fmap (T.pack . show) v <|> u) (T.pack "number") [+		[(T.pack "step", T.pack "1")],+		[(T.pack "min", T.pack $ show (minBound `asTypeOf` fromJust v))],+		[(T.pack "max", T.pack $ show (maxBound `asTypeOf` fromJust v))]+	]++textarea :: Widget Text+textarea v u n (InputOptions {disabled = d, required = r, input_html =    iattrs}) = Input $+	applyAttrs (+		maybeCons d (T.pack "disabled", T.pack "disabled") $+		maybeCons r (T.pack "required", T.pack "required")+		[(T.pack "rows", T.pack "10"),(T.pack "cols", T.pack "55")]+	) iattrs (+		HTML.textarea ! HTML.name (toValue n) $+			maybe mempty HTML.toHtml (v <|> u)+	)++button :: Widget Text+button v _ n (InputOptions {label = l, disabled = d, input_html = iattrs}) = SelfLabelInput $+	applyAttrs (+		maybeCons d (T.pack "disabled", T.pack "disabled")+		[(T.pack "type", T.pack "submit")]+	) iattrs $ maybe id (\v' h -> h ! HTML.value (toValue v')) v (+		HTML.button ! HTML.name (toValue n) $+			maybe mempty (HTML.toHtml . getLabel) l+	)+	where+	getLabel (Label s) = s+	getLabel (InlineLabel s) = s+	getLabel DefaultLabel = humanize n++hidden :: Widget Text+hidden v u n = SelfLabelInput . input_tag n (v <|> u) (T.pack "hidden") []++file :: Widget Text+file v u n = Input . input_tag n (v <|> u) (T.pack "file") []++checkbox :: Widget Bool+checkbox v u n = Input . input_tag n Nothing (T.pack "checkbox") [+		[(T.pack "checked", T.pack "checked") | isChecked]+	]+	where+	isChecked = fromMaybe (maybe False (/=mempty) u) v++date :: (FormatTime a) => Widget a+date v u n = Input . input_tag n (fmap fmt v <|> u) (T.pack "date") []+	where+	fmt = T.pack . formatTime defaultTimeLocale format+	format = iso8601DateFormat Nothing++time :: (FormatTime a) => Widget a+time v u n = Input . input_tag n (fmap fmt v <|> u) (T.pack "time") []+	where+	fmt = T.pack . formatTime defaultTimeLocale format+	format = "%H:%M:%S%Q"++datetime :: (FormatTime a) => Widget a+datetime v u n = Input . input_tag n (fmap fmt v <|> u) (T.pack "datetime") []+	where+	fmt = T.pack . formatTime defaultTimeLocale format+	format = iso8601DateFormat $ Just "%H:%M:%S%Q%z"++datetime_local :: (FormatTime a) => Widget a+datetime_local v u n =+	Input . input_tag n (fmap fmt v <|> u) (T.pack "datetime-local") []+	where+	fmt = T.pack . formatTime defaultTimeLocale format+	format = iso8601DateFormat $ Just "%H:%M:%S%Q"++select :: GroupedCollection -> Widget Text+select collection v _ n (InputOptions {disabled = d, required = r, input_html = iattrs}) = Input $+	applyAttrs (+		maybeCons d (T.pack "disabled", T.pack "disabled") $+		maybeCons r (T.pack "required", T.pack "required")+		[]+	) iattrs (+		HTML.select ! HTML.name (toValue n) $+			formatCollection $ \subCollection ->+				forM_ subCollection $ \(value, label) ->+					mkSelected (Just value == v) $+					HTML.option ! HTML.value (toValue value) $+						HTML.toHtml label+	)+	where+	formatCollection f+		| length collection == 1 && fst (head collection) == mempty =+			f (snd $ head collection)+		| otherwise =+			forM_ collection $ \(group, subCollection) ->+				HTML.optgroup ! HTMLA.label (toValue group) $+					f subCollection++multi_select :: GroupedCollection -> Widget [Text]+multi_select collection v _ n (InputOptions {disabled = d, required = r, input_html = iattrs}) = Input $+	applyAttrs (+		maybeCons d (T.pack "disabled", T.pack "disabled") $+		maybeCons r (T.pack "required", T.pack "required")+		[]+	) iattrs (+		HTML.select ! HTML.name (toValue n) ! HTML.multiple (toValue "multiple") $+			formatCollection $ \subCollection ->+				forM_ subCollection $ \(value, label) ->+					mkSelected (value `elem` items) $+					HTML.option ! HTML.value (toValue value) $+						HTML.toHtml label+	)+	where+	items = fromMaybe [] v+	formatCollection f+		| length collection == 1 && fst (head collection) == mempty =+			f (snd $ head collection)+		| otherwise =+			forM_ collection $ \(group, subCollection) ->+				HTML.optgroup ! HTMLA.label (toValue group) $+					f subCollection++radio_buttons :: GroupedCollection -> Widget Text+radio_buttons collection v _ n opt =+	MultiInput $ formatCollection $ map radio+	where+	radio (value, label) = HTML.label $ do+		mkChecked (Just value == v) $+			input_tag n (Just value) (T.pack "radio") [] opt+		HTML.toHtml label+	formatCollection f+		| length collection == 1 && fst (head collection) == mempty =+			f (snd $ head collection)+		| otherwise =+			(`map` collection) $ \(group, subCollection) ->+				HTML.fieldset $ do+					HTML.legend $ HTML.toHtml group+					mconcat (f subCollection)++checkboxes :: GroupedCollection -> Widget [Text]+checkboxes collection v _ n opt =+	MultiInput $ formatCollection $ map check+	where+	items = fromMaybe [] v+	check (value, label) = HTML.label $ do+		mkChecked (value `elem` items) $+			input_tag n (Just value) (T.pack "checkbox") [] opt+		HTML.toHtml label+	formatCollection f+		| length collection == 1 && fst (head collection) == mempty =+			f (snd $ head collection)+		| otherwise =+			(`map` collection) $ \(group, subCollection) ->+				HTML.fieldset $ do+					HTML.legend $ HTML.toHtml group+					mconcat (f subCollection)++-- | \<input /\>+input_tag ::+	Text               -- ^ name+	-> Maybe Text      -- ^ textual value+	-> Text            -- ^ type+	-> [[(Text,Text)]] -- ^ Extra default attributes+	-> InputOptions    -- ^ Attributes from options override defaults+	-> Html+input_tag n v t dattr (InputOptions {disabled = d, required = r, input_html = iattrs}) =+	applyAttrs (+		maybeCons d (T.pack "disable", T.pack "disabled") $+		maybeCons r (T.pack "required", T.pack "required") $+		(T.pack "type", t) : concat dattr+	) iattrs $ maybe id (\v' h -> h ! HTML.value (toValue v')) v (+		HTML.input !+			HTML.name (toValue n)+	)++maybeCons :: Bool -> a -> [a] -> [a]+maybeCons True x = (x:)+maybeCons False _ = id++mkSelected :: Bool -> Html -> Html+mkSelected True = (! HTML.selected (toValue "selected"))+mkSelected False = id++mkChecked :: Bool -> Html -> Html+mkChecked True = (! HTML.checked (toValue "checked"))+mkChecked False = id++mkAttribute :: (Text,Text) -> HTML.Attribute+mkAttribute (k,v) = HTML.customAttribute (HTML.textTag k) (toValue v)++-- | Apply a list of default attributes and user overrides to some 'Html'+applyAttrs ::+	[(Text,Text)]  -- ^ Defaults+	-> [(Text,Text)] -- ^ User overrides+	-> Html          -- ^ Apply attributes to this 'Html'+	-> Html+applyAttrs dattr cattr html = foldl' (!) html (map mkAttribute attrs)+	where+	attrs = nubBy ((==) `on` fst) attrsWithClass+	attrsWithClass+		| null classes = attrs'+		| otherwise = (T.pack "class", T.unwords classes):attrs'+	classes = concatMap (T.words . snd) $ filter ((== T.pack "class") . fst) attrs'+	attrs' = cattr ++ dattr
+ SimpleForm/Combined.hs view
@@ -0,0 +1,164 @@+-- | Forms that configure themselves based on type+module SimpleForm.Combined (+	Widget,+	DefaultWidget(..),+	Validation(..),+	DefaultValidation(..),+	-- * Options+	InputOptions(..),+	Label(..),+	-- * Wrappers+	ShowRead(..),+	unShowRead,+	SelectEnum(..),+	unSelectEnum,+	-- * Widgets+	button,+	hidden,+	checkbox,+	file,+	-- ** Text-like+	text,+	textarea,+	password,+	search,+	email,+	uri,+	tel,+	-- ** Numbers+	number,+	integral,+	boundedNumber,+	boundedIntegral,+	-- ** Dates and times+	date,+	time,+	datetime,+	datetime_local,+	-- ** Collections+	GroupedCollection',+	Collection',+	select,+	multi_select,+	radio_buttons,+	checkboxes,+	-- * Helpers+	selectEnum,+	enum,+	group_,+	multiEnum,+	humanize+) where++import Data.Time (FormatTime, ParseTime)+import Text.Email.Validate (EmailAddress)+import Network.URI (URI)++import Data.Text (Text)+import qualified Data.Text as T++import SimpleForm (DefaultWidget, Widget, InputOptions(..), Label(..), ShowRead(..), unShowRead, SelectEnum(..), unSelectEnum, humanize)+import SimpleForm.Validation (DefaultValidation, Validation(..), selectEnum, GroupedCollection', Collection', group_)+import qualified SimpleForm+import qualified SimpleForm.Validation as Validation++-- Orphan instances, but for our own classes++instance DefaultWidget EmailAddress where+	wdef = SimpleForm.email . fmap (T.pack . show)++instance DefaultWidget URI where+	wdef = SimpleForm.email . fmap (T.pack . show)++-- | Feed a collection 'Widget' and 'Validation' from an enumerable type+enum :: (Show a, Read a, Bounded a, Enum a) => (GroupedCollection' a -> (Widget Text, Validation a)) -> (Widget a, Validation a)+enum f = (w . fmap (T.pack . show), v)+	where+	(w,v) = f (group_ selectEnum)++-- | Feed a multi-select collection 'Widget' and 'Validation' from an enumerable type+multiEnum :: (Show a, Read a, Bounded a, Enum a) => (GroupedCollection' a -> (Widget [Text], Validation [a])) -> (Widget [a], Validation [a])+multiEnum f = (w . fmap (fmap (T.pack . show)), v)+	where+	(w,v) = f (group_ selectEnum)++text :: (Widget Text, Validation Text)+text = (SimpleForm.text, Validation.text)++password :: (Widget Text, Validation Text)+password = (SimpleForm.password, Validation.text)++search :: (Widget Text, Validation Text)+search = (SimpleForm.search, Validation.text)++email :: (Widget EmailAddress, Validation EmailAddress)+email = (SimpleForm.email . fmap (T.pack . show), Validation.email)++uri :: (Widget URI, Validation URI)+uri = (SimpleForm.uri . fmap (T.pack . show), Validation.uri)++tel :: (Widget Text, Validation Text)+tel = (SimpleForm.tel, Validation.text)++number :: (Num a, Show a, Read a) => (Widget a, Validation a)+number = (SimpleForm.number, Validation.read)++integral :: (Integral a, Show a, Read a) => (Widget a, Validation a)+integral = (SimpleForm.integral, Validation.read)++boundedNumber :: (Bounded a, Num a, Show a, Read a) => (Widget a, Validation a)+boundedNumber = (SimpleForm.boundedNumber, Validation.read)++boundedIntegral :: (Bounded a, Integral a, Show a, Read a) => (Widget a, Validation a)+boundedIntegral = (SimpleForm.boundedIntegral, Validation.read)++textarea :: (Widget Text, Validation Text)+textarea = (SimpleForm.textarea, Validation.text)++button :: (Widget Text, Validation Text)+button = (SimpleForm.textarea, Validation.text)++hidden :: (Widget Text, Validation Text)+hidden = (SimpleForm.hidden, Validation.text)++file :: (Widget Text, Validation Text)+file = (SimpleForm.file, Validation.text)++checkbox :: (Widget Bool, Validation Bool)+checkbox = (SimpleForm.checkbox, Validation.bool)++date :: (FormatTime a, ParseTime a) => (Widget a, Validation a)+date = (SimpleForm.date, Validation.date)++time :: (FormatTime a, ParseTime a) => (Widget a, Validation a)+time = (SimpleForm.time, Validation.time)++datetime :: (FormatTime a, ParseTime a) => (Widget a, Validation a)+datetime = (SimpleForm.datetime, Validation.datetime)++datetime_local :: (FormatTime a, ParseTime a) => (Widget a, Validation a)+datetime_local = (SimpleForm.datetime_local, Validation.datetime_local)++select :: GroupedCollection' a -> (Widget Text, Validation a)+select collection = (+		SimpleForm.select (Validation.viewGroupedCollection collection),+		Validation.includes collection+	)++multi_select :: GroupedCollection' a -> (Widget [Text], Validation [a])+multi_select collection = (+		SimpleForm.multi_select (Validation.viewGroupedCollection collection),+		Validation.multi_includes collection+	)++radio_buttons :: GroupedCollection' a -> (Widget Text, Validation a)+radio_buttons collection = (+		SimpleForm.radio_buttons (Validation.viewGroupedCollection collection),+		Validation.includes collection+	)++checkboxes :: GroupedCollection' a -> (Widget [Text], Validation [a])+checkboxes collection = (+		SimpleForm.checkboxes (Validation.viewGroupedCollection collection),+		Validation.multi_includes collection+	)
+ SimpleForm/Digestive.hs view
@@ -0,0 +1,120 @@+-- | SimpleForm implementation that works along with digestive-functors+module SimpleForm.Digestive (+	SimpleForm,+	simpleForm,+	simpleForm',+	-- * Create forms+	input,+	input_,+	choiceInput,+	choiceInput_,+	toForm,+	-- * Subforms+	withFields,+	wrap,+	fieldset+) where++import Data.Monoid+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer+import Control.Monad.Trans.Class++import Data.Text (Text)+import qualified Data.Text.Lazy as TL++import Text.Blaze.Html (Html, ToMarkup, toHtml)+import Text.Blaze.Html.Renderer.Text (renderHtml)+import qualified Text.Blaze.XHtml5 as HTML++import Text.Digestive.View+import SimpleForm+import SimpleForm.Render+import SimpleForm.Digestive.Internal++-- | Render a 'SimpleForm' to 'Html'+--+-- This produces the contents of the form, but you must still wrap it in+-- the actual \<form\> element.+simpleForm :: (ToMarkup v) =>+	Renderer+	-> (View v, Maybe a)    -- ^ Results of running a digestive-functors 'Form'+	-> SimpleForm a ()      -- ^ The simple form to render+	-> Html+simpleForm render viewVal = snd . simpleForm' render viewVal++-- | Render a 'SimpleForm' to 'Html' and get the return value+--+-- This produces the contents of the form, but you must still wrap it in+-- the actual \<form\> element.+simpleForm' :: (ToMarkup v) =>+	Renderer+	-> (View v, Maybe a)    -- ^ Results of running a digestive-functors 'Form'+	-> SimpleForm a r      -- ^ The simple form to render+	-> (r, Html)+simpleForm' render (view, val) (SimpleForm form) =+	runWriter $ runReaderT form (val, fmap toHtml view, render)++-- | Add some raw markup to a 'SimpleForm'+toForm :: (ToMarkup h) => h -> SimpleForm a ()+toForm = SimpleForm . lift . tell . toHtml++-- | Like 'input', but grabs a collection out of the 'View'+choiceInput ::+	Text                               -- ^ Form element name+	-> (r -> Maybe a)                  -- ^ Get value from parsed data+	-> (GroupedCollection -> Widget a) -- ^ Widget to use+	-> InputOptions                    -- ^ Other options+	-> SimpleForm r ()+choiceInput n sel w opt = SimpleForm $ ReaderT $ \(env, view, render) ->+	let+		textView = fmap (TL.toStrict . renderHtml) view -- TODO: this is wrong+		collection = fieldInputChoiceGroup' [n] textView+	in+	tell $ input' n sel (w collection) opt (env, view, render)++-- | Like 'choiceInput', but chooses defaults for 'Widget' and 'InputOptions'+choiceInput_ ::+	Text                 -- ^ Form element name+	-> (r -> Maybe Text) -- ^ Get value from parsed data+	-> SimpleForm r ()+choiceInput_ n sel = choiceInput n sel select mempty++-- | Create an input element for a 'SimpleForm'+--+-- > input "username" (Just . username) wdef mempty+input ::+	Text                        -- ^ Form element name+	-> (r -> Maybe a)           -- ^ Get value from parsed data+	-> Widget a                 -- ^ Widget to use (such as 'SimpleForm.wdef')+	-> InputOptions             -- ^ Other options+	-> SimpleForm r ()+input n sel w opt = SimpleForm $ ReaderT $ tell . input' n sel w opt++-- | Same as 'input', but just use the default options+input_ :: (DefaultWidget a) =>+	Text                        -- ^ Form element name+	-> (r -> Maybe a)           -- ^ Get value from parsed data+	-> SimpleForm r ()+input_ n sel = input n sel wdef mempty++-- | Project out some part of the parsed data+withFields ::+	Maybe Text     -- ^ Optional subview name+	-> (r' -> r)   -- ^ Projection function+	-> SimpleForm r a+	-> SimpleForm r' a+withFields n f (SimpleForm reader) = SimpleForm $+	withReaderT (\(r, view, render) ->+		(fmap f r, maybe view (`subView'` view) (fmap (:[]) n), render)+	) reader++-- | Wrap a 'SimpleForm' in an 'Html' tag+wrap :: (Html -> Html) -> SimpleForm r a -> SimpleForm r a+wrap f (SimpleForm reader) = SimpleForm $ ReaderT $ \env ->+	let (a, w) = runWriter (runReaderT reader env) in+	tell (f w) >> return a++-- | Like 'withFields', but also wrap in fieldset tag+fieldset :: Maybe Text -> (r' -> r) -> SimpleForm r a -> SimpleForm r' a+fieldset n f = wrap HTML.fieldset . withFields n f
+ SimpleForm/Digestive/Combined.hs view
@@ -0,0 +1,91 @@+-- | SimpleForm implementation that works along with digestive-functors+module SimpleForm.Digestive.Combined (+	SimpleForm,+	getSimpleForm,+	postSimpleForm,+	simpleForm,+	simpleForm',+	-- * Create forms+	input,+	input_,+	toForm,+	-- * Subforms+	withFields,+	wrap,+	fieldset+) where++import Data.Monoid+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer++import Data.Text (Text)+import qualified Data.Text as T++import Text.Blaze.Html (Html)++import Text.Digestive.View+import Text.Digestive.Form+import Text.Digestive.Types (Env)+import SimpleForm.Digestive (toForm, withFields, wrap, fieldset, simpleForm, simpleForm')+import SimpleForm.Combined+import SimpleForm.Digestive.Internal+import SimpleForm.Digestive.Validation++import SimpleForm.Render++-- | Render a 'SimpleForm' to 'Html'+--+-- This produces the contents of the form, but you must still wrap it in+-- the actual \<form\> element.+getSimpleForm :: (Monad m) =>+	Renderer+	-> Maybe a                      -- ^ Default values for the form+	-> SimpleForm a (Form Html m a) -- ^ The simple form to render+	-> m Html+getSimpleForm render val form = do+		view <- getForm T.empty initialForm+		return $ snd $ simpleForm' render (view, val) form+	where+	(initialForm, _) = simpleForm' render (noView, val) form+	noView :: View Html+	noView = error "SimpleForm.Digestive.Combined: cannot use View in generating Form"++-- | Render a 'SimpleForm' to 'Html' in the presence of input+--+-- This produces the contents of the form, but you must still wrap it in+-- the actual \<form\> element.+postSimpleForm :: (Monad m) =>+	Renderer+	-> m (Env m)+	-> SimpleForm a (Form Html m a) -- ^ The simple form to render+	-> m (Html, Maybe a)+postSimpleForm render env form = do+		env' <- env+		(view, val) <- postForm T.empty initialForm env'+		let html = snd $ simpleForm' render (view, val) form+		return (html, val)+	where+	(initialForm, _) = simpleForm' render (noView, Nothing) form+	noView :: View Html+	noView = error "SimpleForm.Digestive.Combined: cannot use View in generating Form"++-- | Create an input element for a 'SimpleForm'+--+-- > input "username" (Just . username) (wdef,vdef) mempty+input :: (Eq a, Monad m) =>+	Text                        -- ^ Form element name+	-> (r -> Maybe a)           -- ^ Get value from parsed data+	-> (Widget a, Validation a) -- ^ Widget and validation to use+	-> InputOptions             -- ^ Other options+	-> SimpleForm r (Form Html m a)+input n sel (w,v) opt = SimpleForm $ ReaderT $ \env -> do+	tell $ input' n sel w opt env+	return $ validationToForm n v++-- | Same as 'input', but just use the default options+input_ :: (DefaultWidget a, DefaultValidation a, Eq a, Monad m) =>+	Text                        -- ^ Form element name+	-> (r -> Maybe a)           -- ^ Get value from parsed data+	-> SimpleForm r (Form Html m a)+input_ n sel = input n sel (wdef,vdef) mempty
+ SimpleForm/Digestive/Validation.hs view
@@ -0,0 +1,18 @@+module SimpleForm.Digestive.Validation where++import Data.Monoid+import Control.Arrow (second)+import Text.Blaze.Html (Html, toHtml)+import Text.Digestive.Form (Form, text, validate, groupedChoiceWith, (.:))+import Text.Digestive.Types (Result(..))+import Data.Text (Text)+import SimpleForm.Validation (Validation(..))++validationToForm :: (Eq a, Monad m) => Text -> Validation a -> Form Html m a+validationToForm n (Check chk) = n .: validate (maybeErr . chk . (:[])) (text Nothing)+	where+	maybeErr Nothing = Error (toHtml n `mappend` toHtml " is invalid")+	maybeErr (Just x) = Success x+validationToForm n (Includes xs) = n .: groupedChoiceWith xs' Nothing+	where+	xs' = map (second $ map (\(x, (v,l)) -> (v, (x, toHtml l)))) xs
+ SimpleForm/Render.hs view
@@ -0,0 +1,37 @@+module SimpleForm.Render (+	Renderer,+	Input(..),+	RenderOptions(..),+	renderOptions+) where++import Text.Blaze.Html (Html)+import Data.Text (Text)+import SimpleForm++-- | The type of a final form-renderer+type Renderer = (RenderOptions -> Html)++-- | 'InputOptions' that have been prepped for rendering+data RenderOptions = RenderOptions {+		name :: Text,+		widgetHtml :: Input,+		errors :: [Html],+		options :: InputOptions+	}++-- | Prep 'InputOptions' for rendering+renderOptions ::+	Maybe a          -- ^ The parsed value for this input (if available)+	-> Maybe Text    -- ^ The unparsed value for this input (if available)+	-> Text          -- ^ The name of this input+	-> Widget a      -- ^ Widget to render with+	-> [Html]        -- ^ Any error messages for this input+	-> InputOptions+	-> RenderOptions+renderOptions v u n w errors opt = RenderOptions {+		name = n,+		widgetHtml = w v u n opt,+		errors = errors,+		options = opt+	}
+ SimpleForm/Render/XHTML5.hs view
@@ -0,0 +1,97 @@+-- | Simple XHTML5 form renderer+module SimpleForm.Render.XHTML5 (render) where++import Data.Monoid+import Data.Foldable (forM_)+import Data.Text (Text)+import qualified Data.Text as T++import Text.Blaze.XHtml5 (Html, toHtml)+import qualified Text.Blaze.XHtml5 as HTML++import SimpleForm+import SimpleForm.Render++render :: Renderer+render opt@(RenderOptions {+		name = n,+		widgetHtml = Input whtml,+		options = InputOptions {+			label = lbl,+			disabled = d,+			required = r,+			wrapper_html = wattr,+			label_html = lattr+		}+	}) =+		applyAttrs (+			maybeCons d (T.pack "class", T.pack "disabled") $+			maybeCons r (T.pack "class", T.pack "required")+			[]+		) wattr $ HTML.label $ do+			forM_ lbl $ applyAttrs [] lattr . label_value (humanize n)+			whtml+			hintAndError opt++render opt@(RenderOptions {+		widgetHtml = SelfLabelInput whtml,+		errors = errors,+		options = InputOptions {+			hint = hint,+			disabled = d,+			required = r,+			wrapper_html = wattr+		}+	}) =+		applyAttrs (+			maybeCons d (T.pack "class", T.pack "disabled") $+			maybeCons r (T.pack "class", T.pack "required")+			[]+		) wattr $ (if errorsOrHint then HTML.div else id) $ do+			whtml+			hintAndError opt+	where+	errorsOrHint = not (null errors && hint == mempty)++render opt@(RenderOptions {+		name = n,+		widgetHtml = MultiInput whtml,+		options = InputOptions {+			label = lbl,+			disabled = d,+			required = r,+			wrapper_html = wattr,+			label_html = lattr+		}+	}) =+		applyAttrs (+			maybeCons d (T.pack "disabled", T.pack "disabled") $+			maybeCons d (T.pack "class", T.pack "disabled") $+			maybeCons r (T.pack "class", T.pack "required")+			[]+		) wattr $ HTML.fieldset $ do+			forM_ lbl $ applyAttrs [] lattr . legend_value (humanize n)+			HTML.ul $ mconcat $ map HTML.li whtml+			hintAndError opt++hintAndError :: RenderOptions -> Html+hintAndError (RenderOptions {+		errors = errors,+		options = InputOptions {+			hint = hint,+			hint_html = hattr,+			error_html = eattr+		}+	}) = do+		forM_ errors $ applyAttrs [(T.pack "class", T.pack "error")] eattr . HTML.span+		forM_ hint $ applyAttrs [(T.pack "class", T.pack "hint")] hattr . HTML.span . toHtml++label_value :: Text -> Label -> Html+label_value _ (Label s) = HTML.span (toHtml s) `mappend` toHtml " "+label_value _ (InlineLabel s) = toHtml s `mappend` toHtml " "+label_value d (DefaultLabel) = label_value d (Label d)++legend_value :: Text -> Label -> Html+legend_value _ (Label s) = HTML.legend $ toHtml s+legend_value d (InlineLabel s) = legend_value d (Label s)+legend_value d (DefaultLabel) = legend_value d (Label d)
+ SimpleForm/Validation.hs view
@@ -0,0 +1,251 @@+module SimpleForm.Validation (+	Validation(..),+	DefaultValidation(..),+	-- * Wrappers+	ShowRead(..),+	unShowRead,+	SelectEnum(..),+	unSelectEnum,+	-- * Validations+	bool,+	-- ** Text-like+	text,+	textLength,+	read,+	email,+	uri,+	absoluteUri,+	-- ** Dates and times+	dateFormat,+	date,+	time,+	datetime,+	datetime_local,+	-- ** Collections+	GroupedCollection',+	Collection',+	includes,+	multi_includes,+	-- * Helpers+	pmap,+	selectEnum,+	selectEnumIdx,+	enumIdx,+	multiEnum,+	multiEnumIdx,+	group_,+	viewGroupedCollection+) where++import Prelude hiding (read)+import Control.Arrow (first, second)+import Control.Monad+import Data.Monoid+import Data.Ratio (Ratio)+import Data.Time (UTCTime, LocalTime, ZonedTime, Day, TimeOfDay, parseTime, ParseTime)+import System.Locale (defaultTimeLocale, iso8601DateFormat)++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Text.Email.Validate (EmailAddress)+import qualified Text.Email.Validate as EmailAddress++import Network.URI (URI)+import qualified Network.URI as URI++import SimpleForm (GroupedCollection, humanize, SelectEnum(..), unSelectEnum, ShowRead(..), unShowRead)++-- | 'GroupedCollection' including the parsed value+type GroupedCollection' a = [(Text, [(a, (Text, Text))])]++-- | 'Collection' including the parsed value+type Collection' a = [(a, (Text, Text))]++-- | Either try to parse the submitted values, or have a list of allowed values+data Validation a = Check ([Text] -> Maybe a) | Includes (GroupedCollection' a)++instance Functor Validation where+	fmap f (Includes xs) = Includes $ map (second $ map (first f)) xs+	fmap f (Check chk) = Check (chk >=> Just . f)++-- | Map over a 'Validation' with a partial function+pmap :: (a -> Maybe b) -> Validation a -> Validation b+pmap f (Includes xs) = Includes $ (`map` xs) $ second $+	foldr (\(x,s) b -> maybe b (\x' -> (x',s):b) (f x)) []+pmap f (Check chk) = Check (chk >=> f)++-- | Convert a 'GroupedCollection'' to a 'GroupedCollection' for use in a view+viewGroupedCollection :: GroupedCollection' a -> GroupedCollection+viewGroupedCollection = map (second $ map snd)++shw :: (Show a) => a -> Text+shw = T.pack . show++-- Infer a 'Validation' based on type+class DefaultValidation a where+	vdef :: Validation a+	vdefList :: Validation [a]+	vdefList = case vdef of+		Check f -> Check (mapM f . return)+		Includes c -> multi_includes c++instance (DefaultValidation a) => DefaultValidation [a] where+	vdef = vdefList++instance DefaultValidation Bool where+	vdef = bool+	vdefList = fmap (map (\(SelectEnum x) -> x)) vdefList++instance DefaultValidation Text where+	vdef = text++instance DefaultValidation Char where+	vdef = pmap (fmap fst . T.uncons) text+	vdefList = fmap T.unpack text -- Heh, hack for 'String'++instance DefaultValidation Integer where+	vdef = read++instance DefaultValidation Int where+	vdef = read+	vdefList = fmap (map (\(SelectEnum x) -> x)) vdefList++instance DefaultValidation Float where+	vdef = read++instance DefaultValidation Double where+	vdef = read++instance DefaultValidation UTCTime where+	vdef = datetime++instance DefaultValidation ZonedTime where+	vdef = datetime++instance DefaultValidation LocalTime where+	vdef = datetime_local++instance DefaultValidation Day where+	vdef = date++instance DefaultValidation TimeOfDay where+	vdef = time++instance (Integral a) => DefaultValidation (Ratio a) where+	vdef = fmap realToFrac (read :: Validation Double)++instance (DefaultValidation a) => DefaultValidation (Maybe a) where+	vdef = optional vdef++instance DefaultValidation EmailAddress where+	vdef = email++instance DefaultValidation URI where+	vdef = uri++instance (Read a) => DefaultValidation (ShowRead a) where+	vdef = read++instance (Show a, Read a, Bounded a, Enum a) => DefaultValidation (SelectEnum a) where+	vdef = enum includes+	vdefList = multiEnum multi_includes++-- | Derive a collection from an enumerable type+selectEnum :: (Show a, Read a, Bounded a, Enum a) => Collection' a+selectEnum = map (\x -> let x' = shw x in (x, (x', humanize x'))) opts+	where+	opts = [minBound..maxBound]++-- | Derive an indexed collection from an enumerable type+selectEnumIdx :: (Show a, Bounded a, Enum a) => Collection' a+selectEnumIdx = map (\(i,x) -> (x, (shw i, humanize $ shw x))) opts+	where+	opts = zip [(0::Int)..] [minBound..maxBound]++-- | Feed a collection 'Validation' from an enumerable type+enum :: (Show a, Read a, Bounded a, Enum a) => (GroupedCollection' a -> Validation a) -> Validation a+enum w = w (group_ selectEnum)++-- | Feed a multi-select collection 'Validation' from an enumerable type+multiEnum :: (Show a, Read a, Bounded a, Enum a) => (GroupedCollection' a -> Validation [a]) -> Validation [a]+multiEnum w = w (group_ selectEnum)++-- | Feed a collection 'Validation' from an enumerable type+enumIdx :: (Show a, Bounded a, Enum a) => (GroupedCollection' a -> Validation a) -> Validation a+enumIdx w = w (group_ selectEnumIdx)++-- | Feed a multi-select collection 'Validation' from an enumerable type+multiEnumIdx :: (Show a, Bounded a, Enum a) => (GroupedCollection' a -> Validation [a]) -> Validation [a]+multiEnumIdx w = w (group_ selectEnumIdx)++-- | Push any 'Collection'' to a trivial 'GroupedCollection''+group_ :: Collection' a -> GroupedCollection' a+group_ c = [(mempty, c)]++optional :: Validation a -> Validation (Maybe a)+optional (Check chk) = Check go+	where+	go t | null t || T.null (head t)  = Just Nothing+	     | otherwise = fmap Just (chk t)+optional (Includes _) =+	error "You cannot both validate against a list and be optional."++text :: Validation Text+text = Check go+	where+	go [x] = Just x+	go _ = Nothing++textLength :: Int -> Validation Text+textLength len = pmap go text+	where+	go t | T.length t <= len = Just t+	go _ = Nothing++read :: (Read a) => Validation a+read = pmap (go . reads . T.unpack) text+	where+	go [(x, "")] = Just x+	go _ = Nothing++email :: Validation EmailAddress+email = pmap (go . EmailAddress.validate . T.encodeUtf8) text+	where+	go (Left _) = Nothing+	go (Right email) = Just email++uri :: Validation URI+uri = pmap (URI.parseURIReference . T.unpack) text++absoluteUri :: Validation URI+absoluteUri = pmap (URI.parseAbsoluteURI . T.unpack) text++bool :: Validation Bool+bool = Check (Just . go)+	where+	go [x] | x /= mempty = True+	go _ = False++dateFormat :: (ParseTime a) => String -> Validation a+dateFormat fmt = pmap (parseTime defaultTimeLocale fmt . T.unpack) text++date :: (ParseTime a) => Validation a+date = dateFormat $ iso8601DateFormat Nothing++time :: (ParseTime a) => Validation a+time = dateFormat "%H:%M:%S%Q"++datetime :: (ParseTime a) => Validation a+datetime = dateFormat $ iso8601DateFormat $ Just "%H:%M:%S%Q%z"++datetime_local :: (ParseTime a) => Validation a+datetime_local = dateFormat $ iso8601DateFormat $ Just "%H:%M:%S%Q"++includes :: GroupedCollection' a -> Validation a+includes = Includes++-- TODO: This needs work+multi_includes :: GroupedCollection' a -> Validation [a]+multi_includes = Includes . map (second $ map (first return))
+ simple-form.cabal view
@@ -0,0 +1,47 @@+name:            simple-form+version:         0.1+cabal-version:   >= 1.8+license:         OtherLicense+license-file:    COPYING+category:        Web+copyright:       © 2013 Stephen Paul Weber+author:          Stephen Paul Weber <singpolyma@singpolyma.net>+maintainer:      Stephen Paul Weber <singpolyma@singpolyma.net>+stability:       experimental+tested-with:     GHC == 7.6.2+synopsis:        Forms that configure themselves based on type+homepage:        https://github.com/singpolyma/simple-form+bug-reports:     https://github.com/singpolyma/simple-form/issues+build-type:      Simple+description:+        Inspired by the RubyGem of the same name, this package allows you to+        easily build validating forms that infer defaults based on type.++extra-source-files:+        README++library+        exposed-modules:+                SimpleForm,+                SimpleForm.Digestive,+                SimpleForm.Digestive.Combined,+                SimpleForm.Digestive.Validation,+                SimpleForm.Combined,+                SimpleForm.Validation,+                SimpleForm.Render,+                SimpleForm.Render.XHTML5++        build-depends:+                base == 4.*,+                blaze-html,+                old-locale,+                time,+                network,+                email-validate,+                transformers,+                text,+                digestive-functors++source-repository head+        type:     git+        location: git://github.com/singpolyma/simple-form.git