More power Forms (getting ugly...)

Yesod/Formable.hs

@@ -3,54 +3,59 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 module Yesod.Formable
     ( Form (..)
     , Formlet
     , FormResult (..)
     , runForm
-    , runIncr
+    , incr
     , Formable (..)
     , deriveFormable
     , share2
     , wrapperRow
     , sealFormlet
+    , sealForm
+    , NonEmptyString (..)
+    , Slug (..)
     ) where
 
 import Text.Hamlet
 import Data.Time (Day)
 import Control.Applicative
 import Database.Persist (Persistable)
-import Data.Char (isAlphaNum)
+import Data.Char (isAlphaNum, toUpper, isUpper)
 import Language.Haskell.TH.Syntax
 import Database.Persist (Table (..))
-import Database.Persist.Helper (upperFirst)
 import Control.Monad (liftM)
 import Control.Arrow (first)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Monoid (mempty, mappend)
 import qualified Data.ByteString.Lazy.UTF8
 import Yesod.Request
 import Yesod.Handler
 import Control.Monad.IO.Class (liftIO)
-import Web.Routes.Quasi
+import Control.Monad.Trans.State
+import Web.Routes.Quasi (Routes, SinglePiece)
 
-runForm :: Form (Routes y) a
+runForm :: Form sub y a
         -> GHandler sub y (FormResult a, Hamlet (Routes y))
 runForm f = do
     req <- getRequest
     (pp, _) <- liftIO $ reqRequestBody req
-    return $ fst $ runIncr (deform f pp) 1
+    evalStateT (deform f pp) 1
 
 type Env = [(String, String)]
 
-newtype Incr a = Incr { runIncr :: Int -> (a, Int) }
+type Incr = StateT Int
-incr :: Incr Int
+
-incr = Incr $ \i -> (i + 1, i + 1)
+incr :: Monad m => Incr m Int
-instance Monad Incr where
+incr = do
-    return a = Incr $ \i -> (a, i)
+    i <- get
-    Incr x >>= f = Incr $ \i ->
+    let i' = i + 1
-        let (x', i') = x i
+    put i'
-         in runIncr (f x') i'
+    return i'
 
 data FormResult a = FormMissing
                   | FormFailure [String]
@@ -67,36 +72,36 @@ instance Applicative FormResult where
     _ <*> (FormFailure y) = FormFailure y
     _ <*> _ = FormMissing
 
-newtype Form url a = Form
+newtype Form sub y a = Form
-    { deform :: Env -> Incr (FormResult a, Hamlet url)
+    { deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y))
     }
-type Formlet url a = Maybe a -> Form url a
+type Formlet sub y a = Maybe a -> Form sub y a
 
-instance Functor (Form url) where
+instance Functor (Form sub url) where
     fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)
 
-instance Applicative (Form url) where
+instance Applicative (Form sub 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)
+sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
-         -> Form url a -> Form url a
+         -> Form sub y a -> Form sub y 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)
+sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
-            -> Formlet url a -> Formlet url a
+            -> Formlet sub y a -> Formlet sub y a
 sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal
 
-input' :: (String -> String -> Hamlet url)
+input' :: (String -> String -> Hamlet (Routes y))
        -> Maybe String
-       -> Form url String
+       -> Form sub y String
 input' mkXml val = Form $ \env -> do
     i <- incr
     let i' = show i
@@ -104,7 +109,7 @@ input' mkXml val = Form $ \env -> do
     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 sub url a -> (a -> Either [String] b) -> Form sub url b
 check (Form form) f = Form $ \env -> liftM (first go) (form env)
   where
     go FormMissing = FormMissing
@@ -114,8 +119,8 @@ check (Form form) f = Form $ \env -> liftM (first go) (form env)
             Left errs -> FormFailure errs
             Right b -> FormSuccess b
 
-class Formable a where
+class Formable y param a where
-    formable :: Formlet url a
+    formable :: param -> Formlet y y a
 
 wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url
 wrapperRow label errs control = [$hamlet|
@@ -129,22 +134,22 @@ wrapperRow label errs control = [$hamlet|
                     %li $string.err$
 |]
 
-instance Formable [Char] where
+instance Formable y param [Char] where
-    formable = input' go
+    formable _ = input' go
       where
         go name val = [$hamlet|
 %input!type=text!name=$string.name$!value=$string.val$
 |]
 
-instance Formable Html where
+instance Formable y param Html where
-    formable = fmap preEscapedString
+    formable _ = fmap preEscapedString
               . input' go
               . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
       where
         go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]
 
-instance Formable Day where
+instance Formable y param Day where
-    formable x = input' go (fmap show x) `check` asDay
+    formable _ x = input' go (fmap show x) `check` asDay
       where
         go name val = [$hamlet|
 %input!type=date!name=$string.name$!value=$string.val$
@@ -153,11 +158,33 @@ instance Formable Day where
                     (y, _):_ -> Right y
                     [] -> Left ["Invalid day"]
 
+instance Formable y param Bool where
+    formable _ x = Form $ \env -> do
+        i <- incr
+        let i' = show i
+        let param = lookup i' env
+        let def = if null env then fromMaybe False x else isJust param
+        return (FormSuccess $ isJust param, go i' def)
+      where
+        go name val = [$hamlet|
+%input!type=checkbox!name=$string.name$!:val:checked
+|]
+
+instance Formable y param Int where
+    formable _ x = input' go (fmap show x) `check` asInt
+      where
+        go name val = [$hamlet|
+%input!type=number!name=$string.name$!value=$string.val$
+|]
+        asInt s = case reads s of
+                    (y, _):_ -> Right y
+                    [] -> Left ["Invalid integer"]
+
 newtype Slug = Slug { unSlug :: String }
     deriving (Read, Eq, Show, SinglePiece, Persistable)
 
-instance Formable Slug where
+instance Formable y param Slug where
-    formable x = input' go (fmap unSlug x) `check` asSlug
+    formable _ x = input' go (fmap unSlug x) `check` asSlug
       where
         go name val = [$hamlet|
 %input!type=text!name=$string.name$!value=$string.val$
@@ -170,8 +197,8 @@ instance Formable Slug where
 
 newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String }
     deriving (Read, Eq, Show, SinglePiece, Persistable)
-instance Formable NonEmptyString where
+instance Formable y param NonEmptyString where
-    formable x = input' go (fmap unNonEmptyString x) `check` notEmpty
+    formable _ x = input' go (fmap unNonEmptyString x) `check` notEmpty
       where
         go name val = [$hamlet|
 %input!type=text!name=$string.name$!value=$string.val$
@@ -185,30 +212,46 @@ share2 f g a = do
     g' <- g a
     return $ f' ++ g'
 
-deriveFormable :: [Table] -> Q [Dec]
+deriveFormable :: String -> String -> [Table] -> Q [Dec]
-deriveFormable = mapM derive
+deriveFormable yesod param = mapM derive
   where
     derive :: Table -> Q Dec
     derive t = do
-        let cols = map (upperFirst . fst) $ tableColumns t
+        let cols = map (toLabel . fst) $ tableColumns t
         ap <- [|(<*>)|]
         just <- [|pure|]
         nothing <- [|Nothing|]
         let just' = just `AppE` ConE (mkName $ tableName t)
-        let c1 = Clause [ConP (mkName "Nothing") []]
+        param' <- newName "param"
-                        (NormalB $ go ap just' $ zip cols $ map (const nothing) cols)
+        let c1 = Clause [ VarP param'
+                        , ConP (mkName "Nothing") []
+                        ]
+                        (NormalB $ go param' ap just' $ zip cols $ map (const nothing) cols)
                         []
         xs <- mapM (const $ newName "x") cols
         let xs' = map (AppE just . VarE) xs
-        let c2 = Clause [ConP (mkName "Just") [ConP (mkName $ tableName t)
+        let c2 = Clause [ VarP param'
+                        , ConP (mkName "Just") [ConP (mkName $ tableName t)
                             $ map VarP xs]]
-                        (NormalB $ go ap just' $ zip cols xs')
+                        (NormalB $ go param' ap just' $ zip cols xs')
                         []
-        return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t))
+        return $ InstanceD [] (ConT ''Formable
+                              `AppT` ConT (mkName yesod)
+                              `AppT` ConT (mkName param)
+                              `AppT` ConT (mkName $ tableName t))
             [FunD (mkName "formable") [c1, c2]]
-    go ap just' = foldl (ap' ap) just' . map go'
+    go param' ap just' = foldl (ap' ap) just' . map (go' param')
-    go' (label, ex) =
+    go' param' (label, ex) =
         VarE (mkName "sealForm") `AppE`
         (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`
-        (VarE (mkName "formable") `AppE` ex)
+        (VarE (mkName "formable") `AppE` VarE param' `AppE` ex)
     ap' ap x y = InfixE (Just x) ap (Just y)
+
+toLabel :: String -> String
+toLabel "" = ""
+toLabel (x:rest) = toUpper x : go rest
+  where
+    go "" = ""
+    go (c:cs)
+        | isUpper c = ' ' : c : go cs
+        | otherwise = c : go cs

Yesod/Helpers/Crud.hs

@@ -4,6 +4,7 @@
 module Yesod.Helpers.Crud
     ( Item (..)
     , Crud (..)
+    , CrudRoutes (..)
     , defaultCrud
     , siteCrud
     ) where