Renamings in Form

Yesod/Form.hs

@@ -12,10 +12,10 @@ module Yesod.Form
     , Form
     , Formlet
     , FormField
+    , FormletField
     , FormResult (..)
     , Enctype (..)
     , FieldInfo (..)
-    , FieldProfile (..)
       -- * Newtype wrappers
     , JqueryDay (..)
     , NicHtml (..)
@@ -25,30 +25,46 @@ module Yesod.Form
     , runFormGet'
     , runFormPost'
       -- * Type classes
-    , IsForm (..)
+    , ToForm (..)
-    , IsFormField (..)
+    , ToFormField (..)
       -- * Field/form helpers
-    , requiredField
+    , requiredFieldHelper
-    , optionalField
+    , optionalFieldHelper
     , mapFormXml
     , newFormIdent
     , fieldsToTable
+      -- * Field profiles
+    , FieldProfile (..)
+    , stringFieldProfile
+    , intFieldProfile
+    , dayFieldProfile
+    , timeFieldProfile
+    , htmlFieldProfile
       -- * Pre-built fields
     , stringField
+    , maybeStringField
     , intField
+    , maybeIntField
+    , doubleField
+    , maybeDoubleField
     , dayField
+    , maybeDayField
     , timeField
-    , boolField
+    , maybeTimeField
     , htmlField
+    , maybeHtmlField
     , selectField
     , maybeSelectField
+    , boolField
       -- * Pre-built inputs
     , stringInput
     , maybeStringInput
     , boolInput
+    , dayInput
+    , maybeDayInput
       -- * Template Haskell
     , share2
-    , mkIsForm
+    , mkToForm
     ) where
 
 import Text.Hamlet
@@ -100,6 +116,7 @@ newtype GForm sub y xml a = GForm
 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 FormletField sub y a = Maybe a -> FormField sub y a
 
 mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
 mapFormXml f (GForm g) = GForm $ \e fe -> do
@@ -145,14 +162,14 @@ fieldsToTable = mapM_ go
         %td.errors $err$
 |]
 
-class IsForm a where
+class ToForm a where
     toForm :: Maybe a -> Form sub y a
-class IsFormField a where
+class ToFormField a where
     toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a
 
-requiredField :: FieldProfile sub y a
+requiredFieldHelper :: FieldProfile sub y a
               -> Html () -> Html () -> Maybe a -> FormField sub y a
-requiredField (FieldProfile parse render mkXml w) label tooltip orig =
+requiredFieldHelper (FieldProfile parse render mkXml w) label tooltip orig =
   GForm $ \env _ -> do
     name <- newFormIdent
     let (res, val) =
@@ -176,10 +193,10 @@ requiredField (FieldProfile parse render mkXml w) label tooltip orig =
             }
     return (res, [fi], UrlEncoded)
 
-optionalField :: FieldProfile sub y a
+optionalFieldHelper :: FieldProfile sub y a
               -> Html () -> Html () -> Maybe (Maybe a)
               -> FormField sub y (Maybe a)
-optionalField (FieldProfile parse render mkXml w) label tooltip orig' =
+optionalFieldHelper (FieldProfile parse render mkXml w) label tooltip orig' =
   GForm $ \env _ -> do
     let orig = join orig'
     name <- newFormIdent
@@ -213,8 +230,14 @@ data FieldProfile sub y a = FieldProfile
 
 --------------------- Begin prebuilt forms
 
-stringField :: FieldProfile sub y String
+stringField :: Html () -> Html () -> FormletField sub y String
-stringField = FieldProfile
+stringField = requiredFieldHelper stringFieldProfile
+
+maybeStringField :: Html () -> Html () -> FormletField sub y (Maybe String)
+maybeStringField = optionalFieldHelper stringFieldProfile
+
+stringFieldProfile :: FieldProfile sub y String
+stringFieldProfile = FieldProfile
     { fpParse = Right
     , fpRender = id
     , fpHamlet = \name val isReq -> [$hamlet|
@@ -222,13 +245,19 @@ stringField = FieldProfile
 |]
     , fpWidget = \_name -> return ()
     }
-instance IsFormField String where
+instance ToFormField String where
-    toFormField = requiredField stringField
+    toFormField = requiredFieldHelper stringFieldProfile
-instance IsFormField (Maybe String) where
+instance ToFormField (Maybe String) where
-    toFormField = optionalField stringField
+    toFormField = optionalFieldHelper stringFieldProfile
 
-intField :: Integral i => FieldProfile sub y i
+intField :: Html () -> Html () -> FormletField sub y Int
-intField = FieldProfile
+intField = requiredFieldHelper intFieldProfile
+
+maybeIntField :: Html () -> Html () -> FormletField sub y (Maybe Int)
+maybeIntField = optionalFieldHelper intFieldProfile
+
+intFieldProfile :: Integral i => FieldProfile sub y i
+intFieldProfile = FieldProfile
     { fpParse = maybe (Left "Invalid integer") Right . readMayI
     , fpRender = showI
     , fpHamlet = \name val isReq -> [$hamlet|
@@ -241,17 +270,23 @@ intField = FieldProfile
     readMayI s = case reads s of
                     (x, _):_ -> Just $ fromInteger x
                     [] -> Nothing
-instance IsFormField Int where
+instance ToFormField Int where
-    toFormField = requiredField intField
+    toFormField = requiredFieldHelper intFieldProfile
-instance IsFormField (Maybe Int) where
+instance ToFormField (Maybe Int) where
-    toFormField = optionalField intField
+    toFormField = optionalFieldHelper intFieldProfile
-instance IsFormField Int64 where
+instance ToFormField Int64 where
-    toFormField = requiredField intField
+    toFormField = requiredFieldHelper intFieldProfile
-instance IsFormField (Maybe Int64) where
+instance ToFormField (Maybe Int64) where
-    toFormField = optionalField intField
+    toFormField = optionalFieldHelper intFieldProfile
 
-doubleField :: FieldProfile sub y Double
+doubleField :: Html () -> Html () -> FormletField sub y Double
-doubleField = FieldProfile
+doubleField = requiredFieldHelper doubleFieldProfile
+
+maybeDoubleField :: Html () -> Html () -> FormletField sub y (Maybe Double)
+maybeDoubleField = optionalFieldHelper doubleFieldProfile
+
+doubleFieldProfile :: FieldProfile sub y Double
+doubleFieldProfile = FieldProfile
     { fpParse = maybe (Left "Invalid number") Right . readMay
     , fpRender = show
     , fpHamlet = \name val isReq -> [$hamlet|
@@ -259,13 +294,19 @@ doubleField = FieldProfile
 |]
     , fpWidget = \_name -> return ()
     }
-instance IsFormField Double where
+instance ToFormField Double where
-    toFormField = requiredField doubleField
+    toFormField = requiredFieldHelper doubleFieldProfile
-instance IsFormField (Maybe Double) where
+instance ToFormField (Maybe Double) where
-    toFormField = optionalField doubleField
+    toFormField = optionalFieldHelper doubleFieldProfile
 
-dayField :: FieldProfile sub y Day
+dayField :: Html () -> Html () -> FormletField sub y Day
-dayField = FieldProfile
+dayField = requiredFieldHelper dayFieldProfile
+
+maybeDayField :: Html () -> Html () -> FormletField sub y (Maybe Day)
+maybeDayField = optionalFieldHelper dayFieldProfile
+
+dayFieldProfile :: FieldProfile sub y Day
+dayFieldProfile = FieldProfile
     { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
               . readMay
     , fpRender = show
@@ -274,13 +315,13 @@ dayField = FieldProfile
 |]
     , fpWidget = const $ return ()
     }
-instance IsFormField Day where
+instance ToFormField Day where
-    toFormField = requiredField dayField
+    toFormField = requiredFieldHelper dayFieldProfile
-instance IsFormField (Maybe Day) where
+instance ToFormField (Maybe Day) where
-    toFormField = optionalField dayField
+    toFormField = optionalFieldHelper dayFieldProfile
 
-jqueryDayField :: FieldProfile sub y JqueryDay
+jqueryDayFieldProfile :: FieldProfile sub y JqueryDay
-jqueryDayField = dayField
+jqueryDayFieldProfile = FieldProfile
     { fpParse = maybe
                   (Left "Invalid day, must be in YYYY-MM-DD format")
                   (Right . JqueryDay)
@@ -297,23 +338,24 @@ jqueryDayField = dayField
     }
 
 -- | A newtype wrapper around 'Day', using jQuery UI date picker for the
--- 'IsFormField' instance.
+-- 'ToFormField' instance.
 newtype JqueryDay = JqueryDay { unJqueryDay :: Day }
     deriving PersistField
-instance IsFormField JqueryDay where
+instance ToFormField JqueryDay where
-    toFormField = requiredField jqueryDayField
+    toFormField = requiredFieldHelper jqueryDayFieldProfile
-instance IsFormField (Maybe JqueryDay) where
+instance ToFormField (Maybe JqueryDay) where
-    toFormField = optionalField jqueryDayField
+    toFormField = optionalFieldHelper jqueryDayFieldProfile
 
 parseTime :: String -> Either String TimeOfDay
-parseTime (h2:':':m1:m2:[]) = parseTimeHelper ['0', h2, m1, m2, '0', '0']
+parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
-parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper [h1, h2, m1, m2, '0', '0']
+parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
 parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
-    parseTimeHelper [h1, h2, m1, m2, s1, s2]
+    parseTimeHelper (h1, h2, m1, m2, s1, s2)
 parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"
 
-parseTimeHelper :: String -> Either String TimeOfDay
+parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
-parseTimeHelper (h1:h2:m1:m2:s1:s2:[])
+                -> Either [Char] TimeOfDay
+parseTimeHelper (h1, h2, m1, m2, s1, s2)
     | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h
     | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m
     | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s
@@ -323,26 +365,25 @@ parseTimeHelper (h1:h2:m1:m2:s1:s2:[])
     m = read [m1, m2]
     s = fromInteger $ read [s1, s2]
 
-timeField :: FieldProfile sub y TimeOfDay
+timeField :: Html () -> Html () -> FormletField sub y TimeOfDay
-timeField = FieldProfile
+timeField = requiredFieldHelper timeFieldProfile
+
+maybeTimeField :: Html () -> Html () -> FormletField sub y (Maybe TimeOfDay)
+maybeTimeField = optionalFieldHelper timeFieldProfile
+
+timeFieldProfile :: FieldProfile sub y TimeOfDay
+timeFieldProfile = FieldProfile
     { fpParse = parseTime
     , fpRender = show
     , fpHamlet = \name val isReq -> [$hamlet|
 %input#$name$!name=$name$!:isReq:required!value=$val$
 |]
-    , fpWidget = \name -> do
+    , fpWidget = const $ return ()
-        return ()
-    {-
-        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(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|]
-    -}
     }
-instance IsFormField TimeOfDay where
+instance ToFormField TimeOfDay where
-    toFormField = requiredField timeField
+    toFormField = requiredFieldHelper timeFieldProfile
-instance IsFormField (Maybe TimeOfDay) where
+instance ToFormField (Maybe TimeOfDay) where
-    toFormField = optionalField timeField
+    toFormField = optionalFieldHelper timeFieldProfile
 
 boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
 boolField label tooltip orig = GForm $ \env _ -> do
@@ -365,11 +406,17 @@ boolField label tooltip orig = GForm $ \env _ -> do
                             _ -> Nothing
             }
     return (res, [fi], UrlEncoded)
-instance IsFormField Bool where
+instance ToFormField Bool where
     toFormField = boolField
 
-htmlField :: FieldProfile sub y (Html ())
+htmlField :: Html () -> Html () -> FormletField sub y (Html ())
-htmlField = FieldProfile
+htmlField = requiredFieldHelper htmlFieldProfile
+
+maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ()))
+maybeHtmlField = optionalFieldHelper htmlFieldProfile
+
+htmlFieldProfile :: FieldProfile sub y (Html ())
+htmlFieldProfile = FieldProfile
     { fpParse = Right . preEscapedString
     , fpRender = U.toString . renderHtml
     , fpHamlet = \name val _isReq -> [$hamlet|
@@ -377,16 +424,16 @@ htmlField = FieldProfile
 |]
     , fpWidget = const $ return ()
     }
-instance IsFormField (Html ()) where
+instance ToFormField (Html ()) where
-    toFormField = requiredField htmlField
+    toFormField = requiredFieldHelper htmlFieldProfile
-instance IsFormField (Maybe (Html ())) where
+instance ToFormField (Maybe (Html ())) where
-    toFormField = optionalField htmlField
+    toFormField = optionalFieldHelper htmlFieldProfile
 
 newtype NicHtml = NicHtml { unNicHtml :: Html () }
     deriving PersistField
 
-nicHtmlField :: FieldProfile sub y NicHtml
+nicHtmlFieldProfile :: FieldProfile sub y NicHtml
-nicHtmlField = FieldProfile
+nicHtmlFieldProfile = FieldProfile
     { fpParse = Right . NicHtml . preEscapedString
     , fpRender = U.toString . renderHtml . unNicHtml
     , fpHamlet = \name val _isReq -> [$hamlet|
@@ -396,10 +443,10 @@ nicHtmlField = FieldProfile
         addScriptRemote "http://js.nicedit.com/nicEdit-latest.js"
         addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|]
     }
-instance IsFormField NicHtml where
+instance ToFormField NicHtml where
-    toFormField = requiredField nicHtmlField
+    toFormField = requiredFieldHelper nicHtmlFieldProfile
-instance IsFormField (Maybe NicHtml) where
+instance ToFormField (Maybe NicHtml) where
-    toFormField = optionalField nicHtmlField
+    toFormField = optionalFieldHelper nicHtmlFieldProfile
 
 readMay :: Read a => String -> Maybe a
 readMay s = case reads s of
@@ -502,6 +549,28 @@ boolInput :: String -> Form sub master Bool
 boolInput n = GForm $ \env _ -> return
     (FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded)
 
+dayInput :: String -> Form sub master Day
+dayInput n = GForm $ \env _ -> return
+    (case lookup n env of
+        Nothing -> FormMissing
+        Just "" -> FormFailure [n ++ ": You must provide a non-empty string"]
+        Just x ->
+            case readMay x of
+                Just y -> FormSuccess y
+                Nothing -> FormFailure [n ++ ": Invalid date"]
+        , mempty, UrlEncoded)
+
+maybeDayInput :: String -> Form sub master (Maybe Day)
+maybeDayInput n = GForm $ \env _ -> return
+    (case lookup n env of
+        Nothing -> FormSuccess Nothing
+        Just "" -> FormSuccess Nothing
+        Just x ->
+            case readMay x of
+                Just y -> FormSuccess $ Just y
+                Nothing -> FormFailure [n ++ ": Invalid date"]
+        , mempty, UrlEncoded)
+
 --------------------- End prebuilt inputs
 
 newFormIdent :: Monad m => StateT Int m String
@@ -553,8 +622,8 @@ share2 f g a = do
     g' <- g a
     return $ f' ++ g'
 
-mkIsForm :: [EntityDef] -> Q [Dec]
+mkToForm :: [EntityDef] -> Q [Dec]
-mkIsForm = mapM derive
+mkToForm = mapM derive
   where
     getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z
     getLabel' [] = Nothing
@@ -566,17 +635,15 @@ mkIsForm = mapM derive
     getTooltip' [] = Nothing
     derive :: EntityDef -> Q Dec
     derive t = do
-        let fst3 (x, _, _) = x
         let cols = map (getLabel &&& getTooltip) $ entityColumns t
         ap <- [|(<*>)|]
         just <- [|pure|]
         nothing <- [|Nothing|]
         let just' = just `AppE` ConE (mkName $ entityName t)
         string' <- [|string|]
-        mempty' <- [|mempty|]
         mfx <- [|mapFormXml|]
         ftt <- [|fieldsToTable|]
-        let go_ = go ap just' string' mempty' mfx ftt
+        let go_ = go ap just' string' mfx ftt
         let c1 = Clause [ ConP (mkName "Nothing") []
                         ]
                         (NormalB $ go_ $ zip cols $ map (const nothing) cols)
@@ -587,13 +654,13 @@ mkIsForm = mapM derive
                             $ map VarP xs]]
                         (NormalB $ go_ $ zip cols xs')
                         []
-        return $ InstanceD [] (ConT ''IsForm
+        return $ InstanceD [] (ConT ''ToForm
                               `AppT` ConT (mkName $ entityName t))
             [FunD (mkName "toForm") [c1, c2]]
-    go ap just' string' mem mfx ftt a =
+    go ap just' string' mfx ftt a =
-        let x = foldl (ap' ap) just' $ map (go' string' mem) a
+        let x = foldl (ap' ap) just' $ map (go' string') a
          in mfx `AppE` ftt `AppE` x
-    go' string' mempty' ((label, tooltip), ex) =
+    go' string' ((label, tooltip), ex) =
         let label' = string' `AppE` LitE (StringL label)
             tooltip' = string' `AppE` LitE (StringL tooltip)
          in VarE (mkName "toFormField") `AppE` label'

Yesod/Helpers/Crud.hs

@@ -19,7 +19,7 @@ import Text.Hamlet
 import Yesod.Form
 import Data.Monoid (mempty)
 
-class IsForm a => Item a where
+class ToForm a => Item a where
     itemTitle :: a -> String
 
 data Crud master item = Crud