Local formlet implementation with inline error messages

Yesod/Contrib.hs

@@ -4,6 +4,6 @@ module Yesod.Contrib
     , module Yesod.Contrib.Persist
     ) where
 
-import Yesod.Contrib.Formable
+import Yesod.Contrib.Formable hiding (runForm)
 import Yesod.Contrib.Crud
 import Yesod.Contrib.Persist

Yesod/Contrib/Crud.hs

@@ -6,20 +6,17 @@ module Yesod.Contrib.Crud where
 import Yesod hiding (Form)
 import Database.Persist
 import Control.Applicative.Error
-import Yesod.Contrib.Formable
+import Yesod.Contrib.Formable hiding (runForm)
 import Yesod.Contrib.Persist
-import Text.Formlets
 import Control.Arrow (second)
 import Data.Monoid (mempty)
 
-runForm :: Form xml (GHandler sub y) a -> GHandler sub y (Failing a, xml)
+runForm :: SealedForm (Routes y) a
+        -> GHandler sub y (Maybe a, Hamlet (Routes y))
 runForm f = do
     req <- getRequest
     (pp, _) <- liftIO $ reqRequestBody req
-    let env = map (second Left) pp
+    return $ fst $ runIncr (runSealedForm f pp) 1
-    let (a, b, _) = runFormState env f
-    a' <- a
-    return (a', b)
 
 class Formable a => Item a where
     itemTitle :: a -> String
@@ -100,7 +97,7 @@ getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
 getCrudDeleteR s = do
     itemId <- maybe notFound return $ itemReadId s
     crud <- getYesodSub
-    item <- crudGet crud itemId >>= maybe notFound return
+    item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists
     toMaster <- getRouteToMaster
     applyLayout "Confirm delete" mempty [$hamlet|
 %form!method=post!action=@toMaster.CrudDeleteR.s@
@@ -132,25 +129,20 @@ crudHelper title me isPost = do
     crud <- getYesodSub
     (errs, form) <- runForm $ formable $ fmap snd me
     toMaster <- getRouteToMaster
-    errs' <- case (isPost, errs) of
+    case (isPost, errs) of
-                (True, Success a) -> do
+        (True, Just a) -> do
-                    eid <- case me of
+            eid <- case me of
-                            Just (eid, _) -> do
+                    Just (eid, _) -> do
-                                crudReplace crud eid a
+                        crudReplace crud eid a
-                                return eid
+                        return eid
-                            Nothing -> crudInsert crud a
+                    Nothing -> crudInsert crud a
-                    redirect RedirectTemporary $ toMaster $ CrudEditR
+            redirect RedirectTemporary $ toMaster $ CrudEditR
-                                               $ toSinglePiece eid
+                                       $ toSinglePiece eid
-                (True, Failure e) -> return $ Just e
+        _ -> return ()
-                (False, _) -> return Nothing
     applyLayout title mempty [$hamlet|
 %p
     %a!href=@toMaster.CrudListR@ Return to list
 %h1 $cs.title$
-$maybe errs' es
-    %ul
-        $forall es e
-            %li $cs.e$
 %form!method=post
     %table
         ^form^

Yesod/Contrib/Formable.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 module Yesod.Contrib.Formable where
 
-import Text.Formlets
 import Text.Hamlet
 import Data.Time (Day)
 import Control.Applicative
@@ -17,23 +16,101 @@ import Language.Haskell.TH.Syntax
 import Database.Persist (Table (..))
 import Database.Persist.Helper (upperFirst)
 import Data.Convertible.Text (cs)
+import Control.Monad (liftM)
+import Control.Arrow (first)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (mempty, mappend)
+
+type Env = [(String, String)]
+
+newtype Incr a = Incr { runIncr :: Int -> (a, Int) }
+incr :: Incr Int
+incr = Incr $ \i -> (i + 1, i + 1)
+instance Monad Incr where
+    return a = Incr $ \i -> (a, i)
+    Incr x >>= f = Incr $ \i ->
+        let (x', i') = x i
+         in runIncr (f x') i'
+
+data FormResult a = FormMissing
+                  | FormFailure [String]
+                  | FormSuccess a
+instance Functor FormResult where
+    fmap _ FormMissing = FormMissing
+    fmap _ (FormFailure errs) = FormFailure errs
+    fmap f (FormSuccess a) = FormSuccess $ f a
+
+newtype Form url a = Form
+    { runForm :: Env -> Incr (FormResult a, [String] -> Hamlet url)
+    }
+type Formlet url a = Maybe a -> Form url a
+
+newtype SealedForm url a = SealedForm
+    { runSealedForm :: Env -> Incr (Maybe a, Hamlet url)
+    }
+type SealedFormlet url a = Maybe a -> SealedForm url a
+instance Functor (SealedForm url) where
+    fmap f (SealedForm g) = SealedForm
+                          $ \env -> liftM (first $ fmap f) (g env)
+instance Applicative (SealedForm url) where
+    pure a = SealedForm $ const $ return (Just a, mempty)
+    (SealedForm f) <*> (SealedForm g) = SealedForm $ \env -> do
+        (f1, f2) <- f env
+        (g1, g2) <- g env
+        return (f1 <*> g1, f2 `mappend` g2)
+
+sealForm :: Form url a -> SealedForm url a
+sealForm (Form form) = SealedForm $ \env -> liftM go (form env)
+  where
+    go (FormSuccess a, xml) = (Just a, xml [])
+    go (FormFailure errs, xml) = (Nothing, xml errs)
+    go (FormMissing, xml) = (Nothing, xml [])
+
+sealFormlet :: Formlet url a -> SealedFormlet url a
+sealFormlet formlet initVal = sealForm $ formlet initVal
+
+instance Functor (Form url) where
+    fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)
+
+input' :: (String -> String -> [String] -> Hamlet url)
+       -> Maybe String
+       -> Form url 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, xml)
+
+check :: Form url a -> (a -> Either [String] b) -> Form url b
+check (Form form) f = Form $ \env -> liftM (first go) (form env)
+  where
+    go FormMissing = FormMissing
+    go (FormFailure x) = FormFailure x
+    go (FormSuccess a) =
+        case f a of
+            Left errs -> FormFailure errs
+            Right b -> FormSuccess b
 
 class Formable a where
-    formable :: (Functor m, Applicative m, Monad m)
+    formable :: SealedFormlet url a
-             => Formlet (Hamlet url) m a
 
 class Fieldable a where
-    fieldable :: (Functor m, Applicative m, Monad m)
+    fieldable :: String -> Formlet url a
-              => String -> Formlet (Hamlet url) m a
 
 instance Fieldable [Char] where
     fieldable label = input' go
       where
-        go name val = [$hamlet|
+        go name val errs = [$hamlet|
 %tr
     %th $string.label$
     %td
         %input!type=text!name=$string.name$!value=$string.val$
+    $if not.null.errs
+        %td.errors
+            %ul
+                $forall errs err
+                    %li $string.err$
 |]
 
 instance Fieldable Html where
@@ -42,24 +119,36 @@ instance Fieldable Html where
       . input' go
       . fmap (cs . renderHtml)
       where
-        go name val = [$hamlet|
+        go name val errs = [$hamlet|
 %tr
     %th $string.label$
     %td
         %textarea!name=$string.name$
             $string.val$
+    $if not.null.errs
+        %td.errors
+            %ul
+                $forall errs err
+                    %li $string.err$
 |]
 
 instance Fieldable Day where
     fieldable label x = input' go (fmap show x) `check` asDay
       where
-        go name val = [$hamlet|
+        go name val errs = [$hamlet|
 %tr
     %th $string.label$
     %td
         %input!type=date!name=$string.name$!value=$string.val$
+    $if not.null.errs
+        %td.errors
+            %ul
+                $forall errs err
+                    %li $string.err$
 |]
-        asDay s = maybeRead' s "Invalid day"
+        asDay s = case reads s of
+                    (x, _):_ -> Right x
+                    [] -> Left ["Invalid day"]
 
 newtype Slug = Slug { unSlug :: String }
     deriving (Read, Eq, Show, SinglePiece, Persistable)
@@ -67,17 +156,22 @@ newtype Slug = Slug { unSlug :: String }
 instance Fieldable Slug where
     fieldable label x = input' go (fmap unSlug x) `check` asSlug
       where
-        go name val = [$hamlet|
+        go name val errs = [$hamlet|
 %tr
     %th $string.label$
     %td
         %input!type=text!name=$string.name$!value=$string.val$
+    $if not.null.errs
+        %td.errors
+            %ul
+                $forall errs err
+                    %li $string.err$
 |]
-        asSlug [] = Failure ["Slug must be non-empty"]
+        asSlug [] = Left ["Slug must be non-empty"]
         asSlug x'
             | all (\c -> c `elem` "-_" || isAlphaNum c) x' =
-                Success $ Slug x'
+                Right $ Slug x'
-            | otherwise = Failure ["Slug must be alphanumeric, - and _"]
+            | otherwise = Left ["Slug must be alphanumeric, - and _"]
 
 share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
 share2 f g a = do
@@ -107,5 +201,7 @@ deriveFormable = mapM derive
         return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t))
             [FunD (mkName "formable") [c1, c2]]
     go ap just' = foldl (ap' ap) just' . map go'
-    go' (label, ex) = VarE (mkName "fieldable") `AppE` LitE (StringL label) `AppE` ex
+    go' (label, ex) =  VarE (mkName "sealForm") `AppE`
+                      (VarE (mkName "fieldable")
+                `AppE` LitE (StringL label) `AppE` ex)
     ap' ap x y = InfixE (Just x) ap (Just y)