Began porting forms to widgets

Yesod/Form.hs

@@ -29,7 +29,7 @@ module Yesod.Form
     , Formable (..)
     , deriveFormable
     , share2
-      -- * Pre-built formlets
+      -- * Pre-built form
     , optionalField
     , requiredField
     , notEmptyField
@@ -54,6 +54,7 @@ import Data.Maybe (isJust)
 import Web.Routes.Quasi (SinglePiece)
 import Data.Int (Int64)
 import qualified Data.ByteString.Lazy.UTF8
+import Yesod.Widget
 
 data FormResult a = FormMissing
                   | FormFailure [String]
@@ -71,7 +72,7 @@ instance Applicative FormResult where
     _ <*> _ = FormMissing
 
 newtype Form sub y a = Form
-    { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y))
+    { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Widget sub y ())
     }
 type Formlet sub y a = Maybe a -> Form sub y a
 
@@ -91,12 +92,12 @@ instance Applicative (Form sub url) where
 runFormGeneric :: Env
                -> FileEnv
                -> Form sub y a
-               -> GHandler sub y (FormResult a, Hamlet (Routes y))
+               -> GHandler sub y (FormResult a, Widget sub y ())
 runFormGeneric env fe f = evalStateT (deform f env fe) 1
 
 -- | Run a form against POST parameters.
 runFormPost :: Form sub y a
-            -> GHandler sub y (FormResult a, Hamlet (Routes y))
+            -> GHandler sub y (FormResult a, Widget sub y ())
 runFormPost f = do
     rr <- getRequest
     (pp, files) <- liftIO $ reqRequestBody rr
@@ -112,26 +113,26 @@ runFormPost' = helper <=< runFormPost
 runFormGet' :: Form sub y a -> GHandler sub y a
 runFormGet' = helper <=< runFormGet
 
-helper :: (FormResult a, Hamlet (Routes y)) -> GHandler sub y a
+helper :: (FormResult a, Widget sub y ()) -> GHandler sub y a
 helper (FormSuccess a, _) = return a
 helper (FormFailure e, _) = invalidArgs e
 helper (FormMissing, _) = invalidArgs ["No input found"]
 
 -- | Run a form against GET parameters.
 runFormGet :: Form sub y a
-           -> GHandler sub y (FormResult a, Hamlet (Routes y))
+           -> GHandler sub y (FormResult a, Widget sub y ())
 runFormGet f = do
     gs <- reqGetParams `fmap` getRequest
     runFormGeneric gs [] f
 
 type Incr = StateT Int
 
-incr :: Monad m => Incr m Int
+incr :: Monad m => Incr m String
 incr = do
     i <- get
     let i' = i + 1
     put i'
-    return i'
+    return $ "f" ++ show i'
 
 input :: (String -> String -> Hamlet (Routes y))
       -> Maybe String
@@ -141,7 +142,7 @@ input mkXml val = Form $ \env _ -> do
     let i' = show i
     let param = lookup i' env
     let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param
-    return (maybe FormMissing FormSuccess param, xml)
+    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)
@@ -171,11 +172,11 @@ sealRow label getVal val =
 
 sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
          -> Form sub y a -> Form sub y a
-sealForm wrapper (Form form) = Form $ \env fe -> liftM go (form env fe)
+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 _ = []
+    toList _ = []-}
 
 sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
             -> Formlet sub y a -> Formlet sub y a
@@ -303,12 +304,11 @@ instance Formable (Maybe Int64) where
 instance Formable Bool where
     formable x = Form $ \env _ -> do
         i <- incr
-        let i' = show i
+        let param = lookup i env
-        let param = lookup i' env
         let def = if null env then fromMaybe False x else isJust param
-        return (FormSuccess $ isJust param, go i' def)
+        return (FormSuccess $ isJust param, go i def)
       where
-        go name val = [$hamlet|
+        go name val = addBody [$hamlet|
 %input!type=checkbox!name=$string.name$!:val:checked
 |]
 

Yesod/Helpers/Crud.hs

@@ -11,6 +11,7 @@ module Yesod.Helpers.Crud
     ) where
 
 import Yesod.Yesod
+import Yesod.Widget
 import Yesod.Dispatch
 import Yesod.Content
 import Yesod.Handler
@@ -33,6 +34,7 @@ mkYesodSub "Crud master item"
     [ ("master", [''Yesod])
     , ("item", [''Item])
     , ("Key item", [''SinglePiece])
+    , ("Routes master", [''Eq])
     ] [$parseRoutes|
 /               CrudListR        GET
 /add            CrudAddR         GET POST
@@ -56,21 +58,24 @@ getCrudListR = do
     %a!href=@toMaster.CrudAddR@ Add new item
 |]
 
-getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item))
+getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
+                Eq (Routes master))
             => GHandler (Crud master item) master RepHtml
 getCrudAddR = crudHelper
                 "Add new"
                 (Nothing :: Maybe (Key item, item))
                 False
 
-postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item))
+postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
+                 Eq (Routes master))
              => GHandler (Crud master item) master RepHtml
 postCrudAddR = crudHelper
                 "Add new"
                 (Nothing :: Maybe (Key item, item))
                 True
 
-getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item))
+getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
+                 Eq (Routes master))
              => String -> GHandler (Crud master item) master RepHtml
 getCrudEditR s = do
     itemId <- maybe notFound return $ itemReadId s
@@ -81,7 +86,8 @@ getCrudEditR s = do
         (Just (itemId, item))
         False
 
-postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item))
+postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
+                  Eq (Routes master))
               => String -> GHandler (Crud master item) master RepHtml
 postCrudEditR s = do
     itemId <- maybe notFound return $ itemReadId s
@@ -105,7 +111,7 @@ getCrudDeleteR s = do
     %p Do you really want to delete $string.itemTitle.item$?
     %p
         %input!type=submit!value=Yes
-        \ 
+        \ $
         %a!href=@toMaster.CrudListR@ No
 |]
 
@@ -122,7 +128,7 @@ itemReadId :: SinglePiece x => String -> Maybe x
 itemReadId = either (const Nothing) Just . fromSinglePiece
 
 crudHelper
-    :: (Item a, Yesod master, SinglePiece (Key a))
+    :: (Item a, Yesod master, SinglePiece (Key a), Eq (Routes master))
     => String -> Maybe (Key a, a) -> Bool
     -> GHandler (Crud master a) master RepHtml
 crudHelper title me isPost = do
@@ -139,7 +145,11 @@ crudHelper title me isPost = do
             redirect RedirectTemporary $ toMaster $ CrudEditR
                                        $ toSinglePiece eid
         _ -> return ()
-    applyLayout title mempty [$hamlet|
+    applyLayoutW $ do
+        wrapWidget (wrapForm toMaster) form
+        setTitle $ string title
+  where
+    wrapForm toMaster form = [$hamlet|
 %p
     %a!href=@toMaster.CrudListR@ Return to list
 %h1 $string.title$

Yesod/Widget.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Yesod.Widget
     ( -- * Datatype
       Widget
@@ -74,6 +75,9 @@ newtype Widget sub master a = Widget (
     GHandler sub master
     ))))))) a)
     deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
+instance Monoid (Widget sub master ()) where
+    mempty = return ()
+    mappend x y = x >> y
 
 setTitle :: Html () -> Widget sub master ()
 setTitle = Widget . lift . tell . Last . Just . Title