haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

yesod-form fixes

Browse Source
This commit is contained in:
Michael Snoyman 2011-12-28 00:07:06 +02:00
parent 1be90d2950
commit ae79c4db39
9 changed files with 33 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
yesod-auth/yesod-auth.cabal
View File

@ -21,7 +21,7 @@ library
cpp-options: -DGHC7 cpp-options: -DGHC7
else else
build-depends: base >= 4 && < 4.3 build-depends: base >= 4 && < 4.3
build-depends: authenticate >= 0.10.4 && < 0.11 build-depends: authenticate >= 0.11 && < 0.12
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
, yesod-core >= 0.10 && < 0.11 , yesod-core >= 0.10 && < 0.11
, wai >= 1.0 && < 1.1 , wai >= 1.0 && < 1.1

23
yesod-form/Yesod/Form/Fields.hs
View File

@ -75,8 +75,8 @@ import qualified Data.Map as Map
import Yesod.Handler (newIdent, liftIOHandler) import Yesod.Handler (newIdent, liftIOHandler)
import Yesod.Request (FileInfo) import Yesod.Request (FileInfo)
import Yesod.Core (toSinglePiece, GGHandler, SinglePiece) import Yesod.Core (toPathPiece, GHandler, GHandlerT, PathPiece)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend) import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
@ -305,7 +305,7 @@ urlField = Field
selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
selectField = selectField' . optionsPairs selectField = selectField' . optionsPairs
selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a selectField' :: (Eq a, RenderMessage master FormMessage) => GHandlerT sub master IO (OptionList a) -> Field sub master a
selectField' = selectFieldHelper selectField' = selectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
@ -319,7 +319,7 @@ multiSelectField = multiSelectFieldHelper
radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
radioField = radioField' . optionsPairs radioField = radioField' . optionsPairs
radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a radioField' :: (Eq a, RenderMessage master FormMessage) => GHandlerT sub master IO (OptionList a) -> Field sub master a
radioField' = selectFieldHelper radioField' = selectFieldHelper
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|]) (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
(\theId name isSel -> [WHAMLET| (\theId name isSel -> [WHAMLET|
@ -399,26 +399,27 @@ data Option a = Option
, optionExternalValue :: Text , optionExternalValue :: Text
} }
optionsPairs :: [(Text, a)] -> GGHandler sub master IO (OptionList a) optionsPairs :: [(Text, a)] -> GHandlerT sub master IO (OptionList a)
optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option
{ optionDisplay = display { optionDisplay = display
, optionInternalValue = internal , optionInternalValue = internal
, optionExternalValue = pack $ show external , optionExternalValue = pack $ show external
}) [1 :: Int ..] }) [1 :: Int ..]
optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO (OptionList a) optionsEnum :: (Show a, Enum a, Bounded a) => GHandlerT sub master IO (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO) optionsPersist :: ( YesodPersist master, PersistEntity a
, SinglePiece (Key (YesodPersistBackend master) a) , PersistQuery (YesodPersistBackend master) (GHandler sub master)
, PathPiece (Key (YesodPersistBackend master) a)
) )
=> [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO (OptionList (Key (YesodPersistBackend master) a, a)) => [Filter a] -> [SelectOpt a] -> (a -> Text) -> GHandler sub master (OptionList (Key (YesodPersistBackend master) a, a))
optionsPersist filts ords toDisplay = fmap mkOptionList $ do optionsPersist filts ords toDisplay = fmap mkOptionList $ do
pairs <- runDB $ selectList filts ords pairs <- runDB $ selectList filts ords
return $ map (\(key, value) -> Option return $ map (\(key, value) -> Option
{ optionDisplay = toDisplay value { optionDisplay = toDisplay value
, optionInternalValue = (key, value) , optionInternalValue = (key, value)
, optionExternalValue = toSinglePiece key , optionExternalValue = toPathPiece key
}) pairs }) pairs
selectFieldHelper selectFieldHelper
@ -426,7 +427,7 @@ selectFieldHelper
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ()) => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Bool -> GWidget sub master ()) -> (Text -> Text -> Bool -> GWidget sub master ())
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ()) -> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-> GGHandler sub master IO (OptionList a) -> Field sub master a -> GHandlerT sub master IO (OptionList a) -> Field sub master a
selectFieldHelper outside onOpt inside opts' = Field selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x -> do { fieldParse = \x -> do
opts <- opts' opts <- opts'

6
yesod-form/Yesod/Form/Functions.hs
View File

@ -40,7 +40,7 @@ import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM, join) import Control.Monad (liftM, join)
import Text.Blaze (Html, toHtml) import Text.Blaze (Html, toHtml)
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod) import Yesod.Handler (GHandler, GHandlerT, getRequest, runRequestBody, newIdent, getYesod)
import Yesod.Core (RenderMessage, liftIOHandler, SomeMessage (..)) import Yesod.Core (RenderMessage, liftIOHandler, SomeMessage (..))
import Yesod.Widget (GWidget, whamlet) import Yesod.Widget (GWidget, whamlet)
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..)) import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..))
@ -157,7 +157,7 @@ aopt :: RenderMessage master msg
-> AForm sub master (Maybe a) -> AForm sub master (Maybe a)
aopt a b = formToAForm . mopt a b aopt a b = formToAForm . mopt a b
runFormGeneric :: MonadIO m => MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype) runFormGeneric :: MonadIO m => MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GHandlerT sub master m (a, Enctype)
runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, master, langs) (IntSingle 1) runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, master, langs) (IntSingle 1)
-- | This function is used to both initially render a form and to later extract -- | This function is used to both initially render a form and to later extract
@ -299,7 +299,7 @@ checkBool :: RenderMessage master msg
checkBool b s = check $ \x -> if b x then Right x else Left s checkBool b s = check $ \x -> if b x then Right x else Left s
checkM :: RenderMessage master msg checkM :: RenderMessage master msg
=> (a -> GGHandler sub master IO (Either msg a)) => (a -> GHandlerT sub master IO (Either msg a))
-> Field sub master a -> Field sub master a
-> Field sub master a -> Field sub master a
checkM f field = field checkM f field = field

4
yesod-form/Yesod/Form/Input.hs
View File

@ -11,7 +11,7 @@ module Yesod.Form.Input
import Yesod.Form.Types import Yesod.Form.Types
import Data.Text (Text) import Data.Text (Text)
import Control.Applicative (Applicative (..)) import Control.Applicative (Applicative (..))
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod, liftIOHandler) import Yesod.Handler (GHandler, GHandlerT, invalidArgs, runRequestBody, getRequest, getYesod, liftIOHandler)
import Yesod.Request (reqGetParams, languages) import Yesod.Request (reqGetParams, languages)
import Control.Monad (liftM) import Control.Monad (liftM)
import Yesod.Message (RenderMessage (..), SomeMessage (..)) import Yesod.Message (RenderMessage (..), SomeMessage (..))
@ -19,7 +19,7 @@ import qualified Data.Map as Map
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
type DText = [Text] -> [Text] type DText = [Text] -> [Text]
newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GGHandler sub master IO (Either DText a) } newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GHandlerT sub master IO (Either DText a) }
instance Functor (FormInput sub master) where instance Functor (FormInput sub master) where
fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e
instance Applicative (FormInput sub master) where instance Applicative (FormInput sub master) where

2
yesod-form/Yesod/Form/Jquery.hs
View File

@ -171,7 +171,7 @@ $(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
|] |]
} }
addScript' :: Monad m => (t -> Either (Route master) Text) -> GGWidget master (GGHandler sub t m) () addScript' :: (master -> Either (Route master) Text) -> GWidget sub master ()
addScript' f = do addScript' f = do
y <- lift getYesod y <- lift getYesod
addScriptEither $ f y addScriptEither $ f y

4
yesod-form/Yesod/Form/MassInput.hs
View File

@ -14,7 +14,7 @@ import Yesod.Form.Functions
import Yesod.Form.Fields (boolField) import Yesod.Form.Fields (boolField)
import Yesod.Widget (GWidget, whamlet) import Yesod.Widget (GWidget, whamlet)
import Yesod.Message (RenderMessage) import Yesod.Message (RenderMessage)
import Yesod.Handler (newIdent, GGHandler) import Yesod.Handler (newIdent, GHandler)
import Text.Blaze (Html) import Text.Blaze (Html)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Text (pack) import Data.Text (pack)
@ -53,7 +53,7 @@ up i = do
IntCons _ is' -> put is' >> newFormIdent >> return () IntCons _ is' -> put is' >> newFormIdent >> return ()
up $ i - 1 up $ i - 1
inputList :: (m ~ GGHandler sub master IO, xml ~ GWidget sub master (), RenderMessage master FormMessage) inputList :: (m ~ GHandler sub master, xml ~ GWidget sub master (), RenderMessage master FormMessage)
=> Html => Html
-> ([[FieldView sub master]] -> xml) -> ([[FieldView sub master]] -> xml)
-> (Maybe a -> AForm sub master a) -> (Maybe a -> AForm sub master a)

10
yesod-form/Yesod/Form/Types.hs
View File

@ -27,7 +27,7 @@ import Text.Blaze (Html, ToHtml (toHtml))
import Control.Applicative ((<$>), Applicative (..)) import Control.Applicative ((<$>), Applicative (..))
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.String (IsString (..)) import Data.String (IsString (..))
import Yesod.Core (GGHandler, GWidget, SomeMessage) import Yesod.Core (GHandlerT, GWidget, SomeMessage)
import qualified Data.Map as Map import qualified Data.Map as Map
-- | A form can produce three different results: there was no data available, -- | A form can produce three different results: there was no data available,
@ -75,12 +75,12 @@ type Env = Map.Map Text [Text]
type FileEnv = Map.Map Text FileInfo type FileEnv = Map.Map Text FileInfo
type Lang = Text type Lang = Text
type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GHandlerT sub master IO) a
{-# DEPRECATED Form "Use MForm instead" #-} {-# DEPRECATED Form "Use MForm instead" #-}
type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GHandlerT sub master IO) a
newtype AForm sub master a = AForm newtype AForm sub master a = AForm
{ unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GGHandler sub master IO (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype) { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GHandlerT sub master IO (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype)
} }
instance Functor (AForm sub master) where instance Functor (AForm sub master) where
fmap f (AForm a) = fmap f (AForm a) =
@ -117,7 +117,7 @@ data FieldView sub master = FieldView
} }
data Field sub master a = Field data Field sub master a = Field
{ fieldParse :: [Text] -> GGHandler sub master IO (Either (SomeMessage master) (Maybe a)) { fieldParse :: [Text] -> GHandlerT sub master IO (Either (SomeMessage master) (Maybe a))
-- | ID, name, (invalid text OR legimiate result), required? -- | ID, name, (invalid text OR legimiate result), required?
, fieldView :: Text , fieldView :: Text
-> Text -> Text

2
yesod-form/yesod-form.cabal
View File

@ -20,7 +20,7 @@ library
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
, shakespeare-css >= 0.10 && < 0.11 , shakespeare-css >= 0.10 && < 0.11
, shakespeare-js >= 0.10 && < 0.11 , shakespeare-js >= 0.10 && < 0.11
, persistent >= 0.6 && < 0.7 , persistent >= 0.7 && < 0.8
, template-haskell , template-haskell
, transformers >= 0.2.2 && < 0.3 , transformers >= 0.2.2 && < 0.3
, data-default >= 0.3 && < 0.4 , data-default >= 0.3 && < 0.4

11
yesod-persistent/Yesod/Persist.hs
View File

@ -6,25 +6,26 @@ module Yesod.Persist
, get404 , get404
, getBy404 , getBy404
, module Database.Persist , module Database.Persist
, module Database.Persist.Query
, module Database.Persist.TH , module Database.Persist.TH
) where ) where
import Database.Persist import Database.Persist
import Database.Persist.Query
import Database.Persist.TH import Database.Persist.TH
import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO)
import Control.Failure (Failure) import Control.Failure (Failure)
import Yesod.Handler import Yesod.Handler
type YesodDB sub master = YesodPersistBackend master (GGHandler sub master IO) type YesodDB sub master = YesodPersistBackend master (GHandler sub master)
class YesodPersist master where class YesodPersist master where
type YesodPersistBackend master :: (* -> *) -> * -> * type YesodPersistBackend master :: (* -> *) -> * -> *
runDB :: MonadIO monad => YesodDB sub master a -> GGHandler sub master monad a runDB :: YesodDB sub master a -> GHandler sub master a
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist. -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
get404 :: (PersistBackend t m, PersistEntity val, Monad (t m), get404 :: (PersistStore t m, PersistEntity val, Monad (t m),
Failure ErrorResponse m, MonadTrans t) Failure ErrorResponse m, MonadTrans t)
=> Key t val -> t m val => Key t val -> t m val
get404 key = do get404 key = do
@ -35,7 +36,7 @@ get404 key = do
-- | Get the given entity by unique key, or return a 404 not found if it doesn't -- | Get the given entity by unique key, or return a 404 not found if it doesn't
-- exist. -- exist.
getBy404 :: (PersistBackend t m, PersistEntity val, Monad (t m), getBy404 :: (PersistUnique t m, PersistEntity val, Monad (t m),
Failure ErrorResponse m, MonadTrans t) Failure ErrorResponse m, MonadTrans t)
=> Unique val t -> t m (Key t val, val) => Unique val t -> t m (Key t val, val)
getBy404 key = do getBy404 key = do