haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

A bunch of minor additions for forms

Browse Source
This commit is contained in:
Michael Snoyman 2010-07-02 13:36:45 +03:00
parent c7f1669ac0
commit 56240984f3
4 changed files with 218 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

205
Yesod/Form.hs
View File

@ -10,8 +10,12 @@ module Yesod.Form
( -- * Data types ( -- * Data types
GForm (..) GForm (..)
, Form , Form
, Formlet
, FormField , FormField
, FormResult (..) , FormResult (..)
, Enctype (..)
, FieldInfo (..)
, FieldProfile (..)
-- * Unwrapping functions -- * Unwrapping functions
, runFormGet , runFormGet
, runFormPost , runFormPost
@ -22,16 +26,22 @@ module Yesod.Form
, IsFormField (..) , IsFormField (..)
-- * Field/form helpers -- * Field/form helpers
, requiredField , requiredField
, optionalField
, mapFormXml , mapFormXml
, newFormIdent , newFormIdent
-- * Pre-built fields
, fieldsToTable , fieldsToTable
-- * Pre-built fields
, stringField , stringField
, intField , intField
, dayField , dayField
, boolField , boolField
, htmlField , htmlField
, selectField
, maybeSelectField
-- * Pre-built inputs
, stringInput , stringInput
, maybeStringInput
, boolInput
-- * Template Haskell -- * Template Haskell
, share2 , share2
, mkIsForm , mkIsForm
@ -42,17 +52,14 @@ import Yesod.Request
import Yesod.Handler import Yesod.Handler
import Control.Applicative hiding (optional) import Control.Applicative hiding (optional)
import Data.Time (Day) import Data.Time (Day)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe, isJust)
import "transformers" Control.Monad.IO.Class import "transformers" Control.Monad.IO.Class
import Control.Monad ((<=<), liftM, join) import Control.Monad ((<=<), liftM, join)
import Data.Monoid (Monoid (..)) import Data.Monoid (Monoid (..))
import Control.Monad.Trans.State import Control.Monad.Trans.State
import Control.Arrow (first)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Database.Persist.Base (PersistField, EntityDef (..)) import Database.Persist.Base (EntityDef (..))
import Data.Char (isAlphaNum, toUpper, isUpper) import Data.Char (toUpper, isUpper)
import Data.Maybe (isJust)
import Web.Routes.Quasi (SinglePiece)
import Data.Int (Int64) import Data.Int (Int64)
import qualified Data.ByteString.Lazy.UTF8 as U import qualified Data.ByteString.Lazy.UTF8 as U
import Yesod.Widget import Yesod.Widget
@ -85,7 +92,8 @@ instance Monoid Enctype where
newtype GForm sub y xml a = GForm newtype GForm sub y xml a = GForm
{ deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype) { deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype)
} }
type Form sub y = GForm sub y (Widget sub y ()) type Form sub y = GForm sub y (GWidget sub y ())
type Formlet sub y a = Maybe a -> Form sub y a
type FormField sub y = GForm sub y [FieldInfo sub y] type FormField sub y = GForm sub y [FieldInfo sub y]
mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
@ -97,8 +105,8 @@ data FieldInfo sub y = FieldInfo
{ fiLabel :: Html () { fiLabel :: Html ()
, fiTooltip :: Html () , fiTooltip :: Html ()
, fiIdent :: String , fiIdent :: String
, fiInput :: Widget sub y () , fiInput :: GWidget sub y ()
, fiErrors :: Html () , fiErrors :: Maybe (Html ())
} }
type Env = [(String, String)] type Env = [(String, String)]
@ -108,7 +116,7 @@ instance Monoid xml => Functor (GForm sub url xml) where
fmap f (GForm g) = fmap f (GForm g) =
GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe) GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe)
where where
first3 f (x, y, z) = (f x, y, z) first3 f' (x, y, z) = (f' x, y, z)
instance Monoid xml => Applicative (GForm sub url xml) where instance Monoid xml => Applicative (GForm sub url xml) where
pure a = GForm $ const $ const $ return (pure a, mempty, mempty) pure a = GForm $ const $ const $ return (pure a, mempty, mempty)
@ -117,19 +125,19 @@ instance Monoid xml => Applicative (GForm sub url xml) where
(g1, g2, g3) <- g env fe (g1, g2, g3) <- g env fe
return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)
fieldsToTable :: [FieldInfo sub y] -> Widget sub y () fieldsToTable :: [FieldInfo sub y] -> GWidget sub y ()
fieldsToTable = mapM_ go fieldsToTable = mapM_ go
where where
go fi = do go fi = do
flip wrapWidget (fiInput fi) $ \w -> [$hamlet| wrapWidget (fiInput fi) $ \w -> [$hamlet|
%tr %tr
%td %td
%label!for=$string.fiIdent.fi$ $fiLabel.fi$ %label!for=$string.fiIdent.fi$ $fiLabel.fi$
.tooltip $fiTooltip.fi$ .tooltip $fiTooltip.fi$
%td %td
^w^ ^w^
%td.errors $maybe fiErrors.fi err
$fiErrors.fi$ %td.errors $err$
|] |]
class IsForm a where class IsForm a where
@ -158,8 +166,36 @@ requiredField (FieldProfile parse render mkXml w) label tooltip orig =
, fiIdent = name , fiIdent = name
, fiInput = w name >> addBody (mkXml (string name) (string val) True) , fiInput = w name >> addBody (mkXml (string name) (string val) True)
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> string x FormFailure [x] -> Just $ string x
_ -> string "" _ -> Nothing
}
return (res, [fi], UrlEncoded)
optionalField :: FieldProfile sub y a
-> Html () -> Html () -> Maybe (Maybe a)
-> FormField sub y (Maybe a)
optionalField (FieldProfile parse render mkXml w) label tooltip orig' =
GForm $ \env _ -> do
let orig = join orig'
name <- newFormIdent
let (res, val) =
if null env
then (FormMissing, maybe "" render orig)
else case lookup name env of
Nothing -> (FormSuccess Nothing, "")
Just "" -> (FormSuccess Nothing, "")
Just x ->
case parse x of
Left e -> (FormFailure [e], x)
Right y -> (FormSuccess $ Just y, x)
let fi = FieldInfo
{ fiLabel = label
, fiTooltip = tooltip
, fiIdent = name
, fiInput = w name >> addBody (mkXml (string name) (string val) False)
, fiErrors = case res of
FormFailure [x] -> Just $ string x
_ -> Nothing
} }
return (res, [fi], UrlEncoded) return (res, [fi], UrlEncoded)
@ -167,7 +203,7 @@ data FieldProfile sub y a = FieldProfile
{ fpParse :: String -> Either String a { fpParse :: String -> Either String a
, fpRender :: a -> String , fpRender :: a -> String
, fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Routes y) , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Routes y)
, fpWidget :: String -> Widget sub y () , fpWidget :: String -> GWidget sub y ()
} }
--------------------- Begin prebuilt forms --------------------- Begin prebuilt forms
@ -183,18 +219,45 @@ stringField = FieldProfile
} }
instance IsFormField String where instance IsFormField String where
toFormField = requiredField stringField toFormField = requiredField stringField
instance IsFormField (Maybe String) where
toFormField = optionalField stringField
intField :: FieldProfile sub y Int intField :: Integral i => FieldProfile sub y i
intField = FieldProfile intField = FieldProfile
{ fpParse = maybe (Left "Invalid integer") Right . readMay { fpParse = maybe (Left "Invalid integer") Right . readMayI
, fpRender = showI
, fpHamlet = \name val isReq -> [$hamlet|
%input#$name$!name=$name$!type=number!:isReq:required!value=$val$
|]
, fpWidget = \_name -> return ()
}
where
showI x = show (fromIntegral x :: Integer)
readMayI s = case reads s of
(x, _):_ -> Just $ fromInteger x
[] -> Nothing
instance IsFormField Int where
toFormField = requiredField intField
instance IsFormField (Maybe Int) where
toFormField = optionalField intField
instance IsFormField Int64 where
toFormField = requiredField intField
instance IsFormField (Maybe Int64) where
toFormField = optionalField intField
doubleField :: FieldProfile sub y Double
doubleField = FieldProfile
{ fpParse = maybe (Left "Invalid number") Right . readMay
, fpRender = show , fpRender = show
, fpHamlet = \name val isReq -> [$hamlet| , fpHamlet = \name val isReq -> [$hamlet|
%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ %input#$name$!name=$name$!type=number!:isReq:required!value=$val$
|] |]
, fpWidget = \_name -> return () , fpWidget = \_name -> return ()
} }
instance IsFormField Int where instance IsFormField Double where
toFormField = requiredField intField toFormField = requiredField doubleField
instance IsFormField (Maybe Double) where
toFormField = optionalField doubleField
dayField :: FieldProfile sub y Day dayField :: FieldProfile sub y Day
dayField = FieldProfile dayField = FieldProfile
@ -212,6 +275,8 @@ dayField = FieldProfile
} }
instance IsFormField Day where instance IsFormField Day where
toFormField = requiredField dayField toFormField = requiredField dayField
instance IsFormField (Maybe Day) where
toFormField = optionalField dayField
boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
boolField label tooltip orig = GForm $ \env _ -> do boolField label tooltip orig = GForm $ \env _ -> do
@ -230,8 +295,8 @@ boolField label tooltip orig = GForm $ \env _ -> do
%input#$string.name$!type=checkbox!name=$string.name$!:val:checked %input#$string.name$!type=checkbox!name=$string.name$!:val:checked
|] |]
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> string x FormFailure [x] -> Just $ string x
_ -> string "" _ -> Nothing
} }
return (res, [fi], UrlEncoded) return (res, [fi], UrlEncoded)
instance IsFormField Bool where instance IsFormField Bool where
@ -241,22 +306,97 @@ htmlField :: FieldProfile sub y (Html ())
htmlField = FieldProfile htmlField = FieldProfile
{ fpParse = Right . preEscapedString { fpParse = Right . preEscapedString
, fpRender = U.toString . renderHtml , fpRender = U.toString . renderHtml
, fpHamlet = \name val isReq -> [$hamlet| , fpHamlet = \name val _isReq -> [$hamlet|
%textarea#$name$!name=$name$ $val$ %textarea.html#$name$!name=$name$ $val$
|] |]
, fpWidget = \name -> do , fpWidget = \name -> do
addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" addScriptRemote "http://js.nicedit.com/nicEdit-latest.js"
addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$string.name$")})|] addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$string.name$")})|]
addStyle [$hamlet|\#$string.name${min-width:400px;min-height:300px}|]
} }
instance IsFormField (Html ()) where instance IsFormField (Html ()) where
toFormField = requiredField htmlField toFormField = requiredField htmlField
instance IsFormField (Maybe (Html ())) where
toFormField = optionalField htmlField
readMay :: Read a => String -> Maybe a readMay :: Read a => String -> Maybe a
readMay s = case reads s of readMay s = case reads s of
(x, _):_ -> Just x (x, _):_ -> Just x
[] -> Nothing [] -> Nothing
selectField :: Eq x => [(x, String)]
-> Html () -> Html ()
-> Maybe x -> FormField sub master x
selectField pairs label tooltip initial = GForm $ \env _ -> do
i <- newFormIdent
let pairs' = zip [1 :: Int ..] pairs
let res = case lookup i env of
Nothing -> FormMissing
Just "none" -> FormFailure ["Field is required"]
Just x ->
case reads x of
(x', _):_ ->
case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"]
Just (y, _) -> FormSuccess y
[] -> FormFailure ["Invalid entry"]
let isSelected x =
case res of
FormSuccess y -> x == y
_ -> Just x == initial
let input = [$hamlet|
%select#$string.i$!name=$string.i$
%option!value=none
$forall pairs' pair
%option!value=$string.show.fst.pair$!:isSelected.fst.snd.pair:selected $string.snd.snd.pair$
|]
let fi = FieldInfo
{ fiLabel = label
, fiTooltip = tooltip
, fiIdent = i
, fiInput = addBody input
, fiErrors = case res of
FormFailure [x] -> Just $ string x
_ -> Nothing
}
return (res, [fi], UrlEncoded)
maybeSelectField :: Eq x => [(x, String)]
-> Html () -> Html ()
-> Maybe x -> FormField sub master (Maybe x)
maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do
i <- newFormIdent
let pairs' = zip [1 :: Int ..] pairs
let res = case lookup i env of
Nothing -> FormMissing
Just "none" -> FormSuccess Nothing
Just x ->
case reads x of
(x', _):_ ->
case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"]
Just (y, _) -> FormSuccess $ Just y
[] -> FormFailure ["Invalid entry"]
let isSelected x =
case res of
FormSuccess y -> Just x == y
_ -> Just x == initial
let input = [$hamlet|
%select#$string.i$!name=$string.i$
%option!value=none
$forall pairs' pair
%option!value=$string.show.fst.pair$!:isSelected.fst.snd.pair:selected $string.snd.snd.pair$
|]
let fi = FieldInfo
{ fiLabel = label
, fiTooltip = tooltip
, fiIdent = i
, fiInput = addBody input
, fiErrors = case res of
FormFailure [x] -> Just $ string x
_ -> Nothing
}
return (res, [fi], UrlEncoded)
--------------------- End prebuilt forms --------------------- End prebuilt forms
--------------------- Begin prebuilt inputs --------------------- Begin prebuilt inputs
@ -268,6 +408,17 @@ stringInput n = GForm $ \env _ -> return
Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] Just "" -> FormFailure [n ++ ": You must provide a non-empty string"]
Just x -> FormSuccess x, mempty, UrlEncoded) Just x -> FormSuccess x, mempty, UrlEncoded)
maybeStringInput :: String -> Form sub master (Maybe String)
maybeStringInput n = GForm $ \env _ -> return
(case lookup n env of
Nothing -> FormSuccess Nothing
Just "" -> FormSuccess Nothing
Just x -> FormSuccess $ Just x, mempty, UrlEncoded)
boolInput :: String -> Form sub master Bool
boolInput n = GForm $ \env _ -> return
(FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded)
--------------------- End prebuilt inputs --------------------- End prebuilt inputs
newFormIdent :: Monad m => StateT Int m String newFormIdent :: Monad m => StateT Int m String

2
Yesod/Helpers/Crud.hs
View File

@ -141,7 +141,7 @@ crudHelper title me isPost = do
$ toSinglePiece eid $ toSinglePiece eid
_ -> return () _ -> return ()
applyLayoutW $ do applyLayoutW $ do
wrapWidget (wrapForm toMaster enctype) form wrapWidget form (wrapForm toMaster enctype)
setTitle $ string title setTitle $ string title
where where
wrapForm toMaster enctype form = [$hamlet| wrapForm toMaster enctype form = [$hamlet|

65
Yesod/Widget.hs
View File

@ -5,7 +5,8 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Yesod.Widget module Yesod.Widget
( -- * Datatype ( -- * Datatype
Widget GWidget
, Widget
-- * Unwrapping -- * Unwrapping
, widgetToPageContent , widgetToPageContent
, applyLayoutW , applyLayoutW
@ -64,7 +65,7 @@ newtype Head url = Head (Hamlet url)
newtype Body url = Body (Hamlet url) newtype Body url = Body (Hamlet url)
deriving Monoid deriving Monoid
newtype Widget sub master a = Widget ( newtype GWidget sub master a = GWidget (
WriterT (Body (Routes master)) ( WriterT (Body (Routes master)) (
WriterT (Last Title) ( WriterT (Last Title) (
WriterT (UniqueList (Script (Routes master))) ( WriterT (UniqueList (Script (Routes master))) (
@ -75,51 +76,52 @@ newtype Widget sub master a = Widget (
GHandler sub master GHandler sub master
))))))) a) ))))))) a)
deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
instance Monoid (Widget sub master ()) where instance Monoid (GWidget sub master ()) where
mempty = return () mempty = return ()
mappend x y = x >> y mappend x y = x >> y
type Widget y = GWidget y y
setTitle :: Html () -> Widget sub master () setTitle :: Html () -> GWidget sub master ()
setTitle = Widget . lift . tell . Last . Just . Title setTitle = GWidget . lift . tell . Last . Just . Title
addHead :: Hamlet (Routes master) -> Widget sub master () addHead :: Hamlet (Routes master) -> GWidget sub master ()
addHead = Widget . lift . lift . lift . lift . lift . tell . Head addHead = GWidget . lift . lift . lift . lift . lift . tell . Head
addBody :: Hamlet (Routes master) -> Widget sub master () addBody :: Hamlet (Routes master) -> GWidget sub master ()
addBody = Widget . tell . Body addBody = GWidget . tell . Body
newIdent :: Widget sub master String newIdent :: GWidget sub master String
newIdent = Widget $ lift $ lift $ lift $ lift $ lift $ lift $ do newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ do
i <- get i <- get
let i' = i + 1 let i' = i + 1
put i' put i'
return $ "w" ++ show i' return $ "w" ++ show i'
addStyle :: Hamlet (Routes master) -> Widget sub master () addStyle :: Hamlet (Routes master) -> GWidget sub master ()
addStyle = Widget . lift . lift . lift . lift . tell . Style addStyle = GWidget . lift . lift . lift . lift . tell . Style
addStylesheet :: Routes master -> Widget sub master () addStylesheet :: Routes master -> GWidget sub master ()
addStylesheet = Widget . lift . lift . lift . tell . toUnique . Stylesheet . Local addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local
addStylesheetRemote :: String -> Widget sub master () addStylesheetRemote :: String -> GWidget sub master ()
addStylesheetRemote = addStylesheetRemote =
Widget . lift . lift . lift . tell . toUnique . Stylesheet . Remote GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
addScript :: Routes master -> Widget sub master () addScript :: Routes master -> GWidget sub master ()
addScript = Widget . lift . lift . tell . toUnique . Script . Local addScript = GWidget . lift . lift . tell . toUnique . Script . Local
addScriptRemote :: String -> Widget sub master () addScriptRemote :: String -> GWidget sub master ()
addScriptRemote = addScriptRemote =
Widget . lift . lift . tell . toUnique . Script . Remote GWidget . lift . lift . tell . toUnique . Script . Remote
applyLayoutW :: (Eq (Routes m), Yesod m) applyLayoutW :: (Eq (Routes m), Yesod m)
=> Widget sub m () -> GHandler sub m RepHtml => GWidget sub m () -> GHandler sub m RepHtml
applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout
widgetToPageContent :: Eq (Routes master) widgetToPageContent :: Eq (Routes master)
=> Widget sub master () => GWidget sub master ()
-> GHandler sub master (PageContent (Routes master)) -> GHandler sub master (PageContent (Routes master))
widgetToPageContent (Widget w) = do widgetToPageContent (GWidget w) = do
w' <- flip evalStateT 0 w' <- flip evalStateT 0
$ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT
$ runWriterT $ runWriterT w $ runWriterT $ runWriterT w
@ -145,15 +147,16 @@ $forall stylesheets s
|] |]
return $ PageContent title head'' body return $ PageContent title head'' body
wrapWidget :: (Hamlet (Routes m) -> Hamlet (Routes m)) wrapWidget :: GWidget s m a
-> Widget s m a -> Widget s m a -> (Hamlet (Routes m) -> Hamlet (Routes m))
wrapWidget wrap (Widget w) = -> GWidget s m a
Widget $ mapWriterT (fmap go) w wrapWidget (GWidget w) wrap =
GWidget $ mapWriterT (fmap go) w
where where
go (a, Body h) = (a, Body $ wrap h) go (a, Body h) = (a, Body $ wrap h)
extractBody :: Widget s m () -> Widget s m (Hamlet (Routes m)) extractBody :: GWidget s m () -> GWidget s m (Hamlet (Routes m))
extractBody (Widget w) = extractBody (GWidget w) =
Widget $ mapWriterT (fmap go) w GWidget $ mapWriterT (fmap go) w
where where
go ((), Body h) = (h, Body mempty) go ((), Body h) = (h, Body mempty)

8
Yesod/Yesod.hs
View File

@ -113,13 +113,15 @@ class Eq (Routes a) => Yesod a where
class YesodBreadcrumbs y where class YesodBreadcrumbs y where
-- | Returns the title and the parent resource, if available. If you return -- | Returns the title and the parent resource, if available. If you return
-- a 'Nothing', then this is considered a top-level page. -- a 'Nothing', then this is considered a top-level page.
breadcrumb :: Routes y -> Handler y (String, Maybe (Routes y)) breadcrumb :: Routes y -> GHandler sub y (String, Maybe (Routes y))
-- | Gets the title of the current page and the hierarchy of parent pages, -- | Gets the title of the current page and the hierarchy of parent pages,
-- along with their respective titles. -- along with their respective titles.
breadcrumbs :: YesodBreadcrumbs y => Handler y (String, [(Routes y, String)]) breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Routes y, String)])
breadcrumbs = do breadcrumbs = do
x <- getRoute x' <- getRoute
tm <- getRouteToMaster
let x = fmap tm x'
case x of case x of
Nothing -> return ("Not found", []) Nothing -> return ("Not found", [])
Just y -> do Just y -> do