Semi-working forms based on widgets

Cool feature: automatically include a Javascript library for a
datepicker when you need a day field.

Yesod/Form.hs

@@ -9,13 +9,19 @@
 module Yesod.Form
     ( -- * Data types
       Form (..)
-    , Formlet
     , FormResult (..)
       -- * Unwrapping functions
     , runFormGet
     , runFormPost
     , runFormGet'
     , runFormPost'
+    , requiredField
+    , stringField
+    , intField
+    , dayField
+    , boolField
+    , fieldsToTable
+    {- FIXME
       -- * Create your own formlets
     , incr
     , input
@@ -34,6 +40,7 @@ module Yesod.Form
     , requiredField
     , notEmptyField
     , boolField
+    -}
     ) where
 
 import Text.Hamlet
@@ -44,7 +51,7 @@ import Data.Time (Day)
 import Data.Maybe (fromMaybe)
 import "transformers" Control.Monad.IO.Class
 import Control.Monad ((<=<), liftM, join)
-import Data.Monoid (mempty, mappend)
+import Data.Monoid (Monoid (..))
 import Control.Monad.Trans.State
 import Control.Arrow (first)
 import Language.Haskell.TH.Syntax
@@ -59,6 +66,7 @@ import Yesod.Widget
 data FormResult a = FormMissing
                   | FormFailure [String]
                   | FormSuccess a
+    deriving Show
 instance Functor FormResult where
     fmap _ FormMissing = FormMissing
     fmap _ (FormFailure errs) = FormFailure errs
@@ -71,33 +79,175 @@ instance Applicative FormResult where
     _ <*> (FormFailure y) = FormFailure y
     _ <*> _ = FormMissing
 
-newtype Form sub y a = Form
+data Enctype = UrlEncoded | Multipart
-    { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Widget sub y ())
+instance Show Enctype where
+    show UrlEncoded = "urlencoded"
+    show Multipart = "multipart/mimetype" -- FIXME
+instance Monoid Enctype where
+    mempty = UrlEncoded
+    mappend UrlEncoded UrlEncoded = UrlEncoded
+    mappend _ _ = Multipart
+
+newtype GForm sub y xml a = GForm
+    { deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype)
+    }
+type Form sub y = GForm sub y (Widget sub y ())
+type FormField sub y = GForm sub y [FieldInfo sub y]
+
+data FieldInfo sub y = FieldInfo
+    { fiLabel :: Html ()
+    , fiTooltip :: Html ()
+    , fiIdent :: String
+    , fiInput :: Widget sub y ()
+    , fiErrors :: Html ()
     }
-type Formlet sub y a = Maybe a -> Form sub y a
 
 type Env = [(String, String)]
 type FileEnv = [(String, FileInfo)]
 
-instance Functor (Form sub url) where
+instance Monoid xml => Functor (GForm sub url xml) where
-    fmap f (Form g) = Form $ \env fe -> liftM (first $ fmap f) (g env fe)
+    fmap f (GForm g) =
+        GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe)
+      where
+        first3 f (x, y, z) = (f x, y, z)
 
-instance Applicative (Form sub url) where
+instance Monoid xml => Applicative (GForm sub url xml) where
-    pure a = Form $ const $ const $ return (pure a, mempty)
+    pure a = GForm $ const $ const $ return (pure a, mempty, mempty)
-    (Form f) <*> (Form g) = Form $ \env fe -> do
+    (GForm f) <*> (GForm g) = GForm $ \env fe -> do
-        (f1, f2) <- f env fe
+        (f1, f2, f3) <- f env fe
-        (g1, g2) <- g env fe
+        (g1, g2, g3) <- g env fe
-        return (f1 <*> g1, f2 `mappend` g2)
+        return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)
+
+fieldsToTable :: [FieldInfo sub y] -> Widget sub y ()
+fieldsToTable = mapM_ go
+  where
+    go fi = do
+        flip wrapWidget (fiInput fi) $ \w -> [$hamlet|
+%tr
+    %td
+        %label!for=$string.fiIdent.fi$ $fiLabel.fi$
+        .tooltip $fiTooltip.fi$
+    %td
+        ^w^
+    %td.errors
+        $fiErrors.fi$
+|]
+
+requiredField :: FieldProfile sub y a
+              -> Html () -> Html () -> Maybe a -> FormField sub y a
+requiredField (FieldProfile parse render mkXml w) label tooltip orig =
+  GForm $ \env _ -> do
+    name <- incr
+    let (res, val) =
+            if null env
+                then (FormMissing, maybe "" render orig)
+                else case lookup name env of
+                        Nothing -> (FormMissing, "")
+                        Just "" -> (FormFailure ["Value is required"], "")
+                        Just x ->
+                            case parse x of
+                                Left e -> (FormFailure [e], x)
+                                Right y -> (FormSuccess y, x)
+    let fi = FieldInfo
+            { fiLabel = label
+            , fiTooltip = tooltip
+            , fiIdent = name
+            , fiInput = w name >> addBody (mkXml (string name) (string val) True)
+            , fiErrors = case res of
+                            FormFailure [x] -> string x
+                            _ -> string ""
+            }
+    return (res, [fi], UrlEncoded)
+
+data FieldProfile sub y a = FieldProfile
+    { fpParse :: String -> Either String a
+    , fpRender :: a -> String
+    , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Routes y)
+    , fpWidget :: String -> Widget sub y ()
+    }
+
+--------------------- Begin prebuilt forms
+
+stringField :: FieldProfile sub y String
+stringField = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpHamlet = \name val isReq -> [$hamlet|
+%input#$name$!name=$name$!type=text!:isReq:required!value=$val$
+|]
+    , fpWidget = \_name -> return ()
+    }
+
+intField :: FieldProfile sub y Int
+intField = FieldProfile
+    { fpParse = maybe (Left "Invalid integer") Right . readMay
+    , fpRender = show
+    , fpHamlet = \name val isReq -> [$hamlet|
+%input#$name$!name=$name$!type=number!:isReq:required!value=$val$
+|]
+    , fpWidget = \_name -> return ()
+    }
+
+dayField :: FieldProfile sub y Day
+dayField = FieldProfile
+    { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
+              . readMay
+    , fpRender = show
+    , fpHamlet = \name val isReq -> [$hamlet|
+%input#$name$!name=$name$!type=date!:isReq:required!value=$val$
+|]
+    , fpWidget = \name -> do
+        addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
+        addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js"
+        addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"
+        addHead [$hamlet|%script $$(function(){$$("#$string.name$").datepicker({dateFormat:'yy-mm-dd'})})|]
+    }
+
+boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
+boolField label tooltip orig = GForm $ \env _ -> do
+    name <- incr
+    let (res, val) =
+            if null env
+                then (FormMissing, fromMaybe False orig)
+                else case lookup name env of
+                        Nothing -> (FormSuccess False, False)
+                        Just _ -> (FormSuccess True, True)
+    let fi = FieldInfo
+            { fiLabel = label
+            , fiTooltip = tooltip
+            , fiIdent = name
+            , fiInput = addBody [$hamlet|
+%input#$string.name$!type=checkbox!name=$string.name$!:val:checked
+|]
+            , fiErrors = case res of
+                            FormFailure [x] -> string x
+                            _ -> string ""
+            }
+    return (res, [fi], UrlEncoded)
+
+readMay :: Read a => String -> Maybe a
+readMay s = case reads s of
+                (x, _):_ -> Just x
+                [] -> Nothing
+
+--------------------- End prebuilt forms
+
+incr :: Monad m => StateT Int m String
+incr = do
+    i <- get
+    let i' = i + 1
+    put i'
+    return $ "f" ++ show i'
 
 runFormGeneric :: Env
                -> FileEnv
-               -> Form sub y a
+               -> GForm sub y xml a
-               -> GHandler sub y (FormResult a, Widget sub y ())
+               -> GHandler sub y (FormResult a, xml, Enctype)
 runFormGeneric env fe f = evalStateT (deform f env fe) 1
 
 -- | Run a form against POST parameters.
-runFormPost :: Form sub y a
+runFormPost :: GForm sub y xml a
-            -> GHandler sub y (FormResult a, Widget sub y ())
+            -> GHandler sub y (FormResult a, xml, Enctype)
 runFormPost f = do
     rr <- getRequest
     (pp, files) <- liftIO $ reqRequestBody rr
@@ -105,7 +255,7 @@ runFormPost f = do
 
 -- | Run a form against POST parameters, disregarding the resulting HTML and
 -- returning an error response on invalid input.
-runFormPost' :: Form sub y a -> GHandler sub y a
+runFormPost' :: GForm sub y xml a -> GHandler sub y a
 runFormPost' = helper <=< runFormPost
 
 -- | Run a form against GET parameters, disregarding the resulting HTML and
@@ -113,74 +263,19 @@ runFormPost' = helper <=< runFormPost
 runFormGet' :: Form sub y a -> GHandler sub y a
 runFormGet' = helper <=< runFormGet
 
-helper :: (FormResult a, Widget sub y ()) -> GHandler sub y a
+helper :: (FormResult a, b, c) -> GHandler sub y a
-helper (FormSuccess a, _) = return a
+helper (FormSuccess a, _, _) = return a
-helper (FormFailure e, _) = invalidArgs e
+helper (FormFailure e, _, _) = invalidArgs e
-helper (FormMissing, _) = invalidArgs ["No input found"]
+helper (FormMissing, _, _) = invalidArgs ["No input found"]
 
 -- | Run a form against GET parameters.
-runFormGet :: Form sub y a
+runFormGet :: GForm sub y xml a
-           -> GHandler sub y (FormResult a, Widget sub y ())
+           -> GHandler sub y (FormResult a, xml, Enctype)
 runFormGet f = do
     gs <- reqGetParams `fmap` getRequest
     runFormGeneric gs [] f
 
-type Incr = StateT Int
+{-
-
-incr :: Monad m => Incr m String
-incr = do
-    i <- get
-    let i' = i + 1
-    put i'
-    return $ "f" ++ show i'
-
-input :: (String -> String -> Hamlet (Routes y))
-      -> Maybe String
-      -> Form sub y String
-input mkXml val = Form $ \env _ -> do
-    i <- incr
-    let i' = show i
-    let param = lookup i' env
-    let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param
-    return (maybe FormMissing FormSuccess param, addBody xml) -- FIXME
-
-check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b
-check (Form form) f = Form $ \env fe -> liftM (first go) (form env fe)
-  where
-    go FormMissing = FormMissing
-    go (FormFailure x) = FormFailure x
-    go (FormSuccess a) =
-        case f a of
-            Left errs -> FormFailure errs
-            Right b -> FormSuccess b
-
-wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url
-wrapperRow label errs control = [$hamlet|
-%tr
-    %th $string.label$
-    %td ^control^
-    $if not.null.errs
-        %td.errors
-            %ul
-                $forall errs err
-                    %li $string.err$
-|]
-
-sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b
-sealRow label getVal val =
-    sealForm (wrapperRow label) $ formable $ fmap getVal val
-
-sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
-         -> Form sub y a -> Form sub y a
-sealForm wrapper (Form form) = error "FIXME" {-Form $ \env fe -> liftM go (form env fe)
-  where
-    go (res, xml) = (res, wrapper (toList res) xml)
-    toList (FormFailure errs) = errs
-    toList _ = []-}
-
-sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
-            -> Formlet sub y a -> Formlet sub y a
-sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal
 
 -------- Prebuilt
 optionalField :: String -> Form sub master (Maybe String)
@@ -382,3 +477,4 @@ toLabel (x:rest) = toUpper x : go rest
     go (c:cs)
         | isUpper c = ' ' : c : go cs
         | otherwise = c : go cs
+-}

hellowidget.hs

@@ -2,10 +2,12 @@
 import Yesod
 import Yesod.Widget
 import Yesod.Helpers.Static
+import Control.Applicative
 
 data HW = HW { hwStatic :: Static }
 mkYesod "HW" [$parseRoutes|
 / RootR GET
+/form FormR
 /static StaticR Static hwStatic
 |]
 instance Yesod HW where approot _ = ""
@@ -25,7 +27,31 @@ getRootR = applyLayoutW $ wrapWidget wrapper $ do
 %h1#$string.i$ Welcome to my first widget!!!
 %p
     %a!href=@RootR@ Recursive link.
+%p
+    %a!href=@FormR@ Check out the form.
 %p.noscript Your script did not load. :(
 |]
     addHead [$hamlet|%meta!keywords=haskell|]
+
+handleFormR = do
+    (res, form, enctype) <- runFormPost $ (,,,,)
+        <$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing
+        <*> requiredField stringField (string "Another field") (string "") (Just "some default text")
+        <*> requiredField intField (string "A number field") (string "some nums") (Just 5)
+        <*> requiredField dayField (string "A day field") (string "") Nothing
+        <*> boolField (string "A checkbox") (string "") (Just False)
+    applyLayoutW $ do
+        addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|]
+        flip wrapWidget (fieldsToTable form) $ \h -> [$hamlet|
+%form!method=post!enctype=$string.show.enctype$
+    %table
+        ^h^
+        %tr
+            %td!colspan=2
+                %input!type=submit
+    %h3
+        Result: $string.show.res$
+|]
+        setTitle $ string "Form"
+
 main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= basicHandler 3000