Removed SealedForm(let)

Yesod/Formable.hs

@@ -6,12 +6,10 @@
 module Yesod.Formable
     ( Form (..)
     , Formlet
-    , SealedForm (..)
-    , SealedFormlet
+    , FormResult (..)
     , runForm
     , runIncr
     , Formable (..)
-    , Fieldable (..)
     , deriveFormable
     , share2
     , wrapperRow
@@ -36,12 +34,12 @@ import Yesod.Handler
 import Control.Monad.IO.Class (liftIO)
 import Web.Routes.Quasi
 
-runForm :: SealedForm (Routes y) a
-        -> GHandler sub y (Either [String] a, Hamlet (Routes y))
+runForm :: Form (Routes y) a
+        -> GHandler sub y (FormResult a, Hamlet (Routes y))
 runForm f = do
     req <- getRequest
     (pp, _) <- liftIO $ reqRequestBody req
-    return $ fst $ runIncr (runSealedForm f pp) 1
+    return $ fst $ runIncr (deform f pp) 1
 
 type Env = [(String, String)]
 
@@ -61,44 +59,41 @@ instance Functor FormResult where
     fmap _ FormMissing = FormMissing
     fmap _ (FormFailure errs) = FormFailure errs
     fmap f (FormSuccess a) = FormSuccess $ f a
+instance Applicative FormResult where
+    pure = FormSuccess
+    (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
+    (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
+    (FormFailure x) <*> _ = FormFailure x
+    _ <*> (FormFailure y) = FormFailure y
+    _ <*> _ = FormMissing
 
-newtype Form url a = Form (Env -> Incr (FormResult a, Hamlet url))
-type Formlet url a = Maybe a -> Form url a
-
-newtype SealedForm url a = SealedForm
-    { runSealedForm :: Env -> Incr (Either [String] a, Hamlet url)
+newtype Form url a = Form
+    { deform :: Env -> Incr (FormResult 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 (Right a, mempty)
-    (SealedForm f) <*> (SealedForm g) = SealedForm $ \env -> do
-        (f1, f2) <- f env
-        (g1, g2) <- g env
-        return (f1 `apE` g1, f2 `mappend` g2)
-      where
-        apE (Left x) (Left y) = Left $ x ++ y
-        apE (Left x) _ = Left x
-        apE _ (Left y) = Left y
-        apE (Right x) (Right y) = Right $ x y
-
-sealForm :: ([String] -> Hamlet url -> Hamlet url)
-         -> Form url a -> SealedForm url a
-sealForm wrapper (Form form) = SealedForm $ \env -> liftM go (form env)
-  where
-    go (FormSuccess a, xml) = (Right a, wrapper [] xml)
-    go (FormFailure errs, xml) = (Left errs, wrapper errs xml)
-    go (FormMissing, xml) = (Left [], wrapper [] xml)
-
-sealFormlet :: ([String] -> Hamlet url -> Hamlet url)
-            -> Formlet url a -> SealedFormlet url a
-sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal
+type Formlet url a = Maybe a -> Form url a
 
 instance Functor (Form url) where
     fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)
 
+instance Applicative (Form url) where
+    pure a = Form $ const $ return (pure a, mempty)
+    (Form f) <*> (Form g) = Form $ \env -> do
+        (f1, f2) <- f env
+        (g1, g2) <- g env
+        return (f1 <*> g1, f2 `mappend` g2)
+
+sealForm :: ([String] -> Hamlet url -> Hamlet url)
+         -> Form url a -> Form url a
+sealForm wrapper (Form form) = Form $ \env -> liftM go (form env)
+  where
+    go (res, xml) = (res, wrapper (toList res) xml)
+    toList (FormFailure errs) = errs
+    toList _ = []
+
+sealFormlet :: ([String] -> Hamlet url -> Hamlet url)
+            -> Formlet url a -> Formlet url a
+sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal
+
 input' :: (String -> String -> Hamlet url)
        -> Maybe String
        -> Form url String
@@ -120,10 +115,7 @@ check (Form form) f = Form $ \env -> liftM (first go) (form env)
             Right b -> FormSuccess b
 
 class Formable a where
-    formable :: SealedFormlet url a
-
-class Fieldable a where
-    fieldable :: Formlet url a
+    formable :: Formlet url a
 
 wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url
 wrapperRow label errs control = [$hamlet|
@@ -137,22 +129,22 @@ wrapperRow label errs control = [$hamlet|
                     %li $string.err$
 |]
 
-instance Fieldable [Char] where
-    fieldable = input' go
+instance Formable [Char] where
+    formable = input' go
       where
         go name val = [$hamlet|
 %input!type=text!name=$string.name$!value=$string.val$
 |]
 
-instance Fieldable Html where
-    fieldable = fmap preEscapedString
+instance Formable Html where
+    formable = fmap preEscapedString
               . input' go
               . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
       where
         go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]
 
-instance Fieldable Day where
-    fieldable x = input' go (fmap show x) `check` asDay
+instance Formable Day where
+    formable x = input' go (fmap show x) `check` asDay
       where
         go name val = [$hamlet|
 %input!type=date!name=$string.name$!value=$string.val$
@@ -164,8 +156,8 @@ instance Fieldable Day where
 newtype Slug = Slug { unSlug :: String }
     deriving (Read, Eq, Show, SinglePiece, Persistable)
 
-instance Fieldable Slug where
-    fieldable x = input' go (fmap unSlug x) `check` asSlug
+instance Formable Slug where
+    formable x = input' go (fmap unSlug x) `check` asSlug
       where
         go name val = [$hamlet|
 %input!type=text!name=$string.name$!value=$string.val$
@@ -178,8 +170,8 @@ instance Fieldable Slug where
 
 newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String }
     deriving (Read, Eq, Show, SinglePiece, Persistable)
-instance Fieldable NonEmptyString where
-    fieldable x = input' go (fmap unNonEmptyString x) `check` notEmpty
+instance Formable NonEmptyString where
+    formable x = input' go (fmap unNonEmptyString x) `check` notEmpty
       where
         go name val = [$hamlet|
 %input!type=text!name=$string.name$!value=$string.val$
@@ -218,5 +210,5 @@ deriveFormable = mapM derive
     go' (label, ex) =
         VarE (mkName "sealForm") `AppE`
         (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`
-        (VarE (mkName "fieldable") `AppE` ex)
+        (VarE (mkName "formable") `AppE` ex)
     ap' ap x y = InfixE (Just x) ap (Just y)

Yesod/Helpers/Crud.hs

@@ -128,7 +128,7 @@ crudHelper title me isPost = do
     (errs, form) <- runForm $ formable $ fmap snd me
     toMaster <- getRouteToMaster
     case (isPost, errs) of
-        (True, Right a) -> do
+        (True, FormSuccess a) -> do
             eid <- case me of
                     Just (eid, _) -> do
                         crudReplace crud eid a