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
else
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
, yesod-core >= 0.10 && < 0.11
, 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.Request (FileInfo)
import Yesod.Core (toSinglePiece, GGHandler, SinglePiece)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend)
import Yesod.Core (toPathPiece, GHandler, GHandlerT, PathPiece)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)
import Control.Arrow ((&&&))
#if __GLASGOW_HASKELL__ >= 700
@ -305,7 +305,7 @@ urlField = Field
selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
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
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside
(\_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 = 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
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
(\theId name isSel -> [WHAMLET|
@ -399,26 +399,27 @@ data Option a = Option
, 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
{ optionDisplay = display
, optionInternalValue = internal
, optionExternalValue = pack $ show external
}) [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]
optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO)
, SinglePiece (Key (YesodPersistBackend master) a)
optionsPersist :: ( YesodPersist master, PersistEntity 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
pairs <- runDB $ selectList filts ords
return $ map (\(key, value) -> Option
{ optionDisplay = toDisplay value
, optionInternalValue = (key, value)
, optionExternalValue = toSinglePiece key
, optionExternalValue = toPathPiece key
}) pairs
selectFieldHelper
@ -426,7 +427,7 @@ selectFieldHelper
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Bool -> 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
{ fieldParse = \x -> do
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 (liftM, join)
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.Widget (GWidget, whamlet)
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..))
@ -157,7 +157,7 @@ aopt :: RenderMessage master msg
-> AForm sub master (Maybe a)
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)
-- | 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
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
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 Data.Text (Text)
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 Control.Monad (liftM)
import Yesod.Message (RenderMessage (..), SomeMessage (..))
@ -19,7 +19,7 @@ import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
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
fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e
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
y <- lift getYesod
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.Widget (GWidget, whamlet)
import Yesod.Message (RenderMessage)
import Yesod.Handler (newIdent, GGHandler)
import Yesod.Handler (newIdent, GHandler)
import Text.Blaze (Html)
import Control.Monad.Trans.Class (lift)
import Data.Text (pack)
@ -53,7 +53,7 @@ up i = do
IntCons _ is' -> put is' >> newFormIdent >> return ()
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
-> ([[FieldView sub master]] -> xml)
-> (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.Monad (liftM)
import Data.String (IsString (..))
import Yesod.Core (GGHandler, GWidget, SomeMessage)
import Yesod.Core (GHandlerT, GWidget, SomeMessage)
import qualified Data.Map as Map
-- | 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 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" #-}
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
{ 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
fmap f (AForm a) =
@ -117,7 +117,7 @@ data FieldView sub master = FieldView
}
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?
, fieldView :: Text
-> Text

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

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

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

@ -6,25 +6,26 @@ module Yesod.Persist
, get404
, getBy404
, module Database.Persist
, module Database.Persist.Query
, module Database.Persist.TH
) where
import Database.Persist
import Database.Persist.Query
import Database.Persist.TH
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO)
import Control.Failure (Failure)
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
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.
get404 :: (PersistBackend t m, PersistEntity val, Monad (t m),
get404 :: (PersistStore t m, PersistEntity val, Monad (t m),
Failure ErrorResponse m, MonadTrans t)
=> Key t val -> t m val
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
-- exist.
getBy404 :: (PersistBackend t m, PersistEntity val, Monad (t m),
getBy404 :: (PersistUnique t m, PersistEntity val, Monad (t m),
Failure ErrorResponse m, MonadTrans t)
=> Unique val t -> t m (Key t val, val)
getBy404 key = do