yesod-form compiles again
This commit is contained in:
parent
9ea93589e3
commit
384965dcef
@ -17,7 +17,6 @@ import Data.Time (Day, TimeOfDay)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Yesod.Handler (GGHandler)
|
import Yesod.Handler (GGHandler)
|
||||||
import Yesod.Message (RenderMessage)
|
import Yesod.Message (RenderMessage)
|
||||||
import Control.Monad.IO.Class (MonadIO) -- FIXME
|
|
||||||
|
|
||||||
{-
|
{-
|
||||||
class ToForm a where
|
class ToForm a where
|
||||||
|
|||||||
@ -35,7 +35,7 @@ instance Applicative (FormInput sub master) where
|
|||||||
(_, Left b) -> Left b
|
(_, Left b) -> Left b
|
||||||
(Right a, Right b) -> Right $ a b
|
(Right a, Right b) -> Right $ a b
|
||||||
|
|
||||||
ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a
|
ireq :: (RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a
|
||||||
ireq field name = FormInput $ \m l env -> do
|
ireq field name = FormInput $ \m l env -> do
|
||||||
let filteredEnv = fromMaybe [] $ Map.lookup name env
|
let filteredEnv = fromMaybe [] $ Map.lookup name env
|
||||||
emx <- fieldParse field $ filteredEnv
|
emx <- fieldParse field $ filteredEnv
|
||||||
@ -44,7 +44,7 @@ ireq field name = FormInput $ \m l env -> do
|
|||||||
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
|
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
|
||||||
Right (Just a) -> Right a
|
Right (Just a) -> Right a
|
||||||
|
|
||||||
iopt :: RenderMessage master msg => Field sub master a -> Text -> FormInput sub master (Maybe a)
|
iopt :: Field sub master a -> Text -> FormInput sub master (Maybe a)
|
||||||
iopt field name = FormInput $ \m l env -> do
|
iopt field name = FormInput $ \m l env -> do
|
||||||
let filteredEnv = fromMaybe [] $ Map.lookup name env
|
let filteredEnv = fromMaybe [] $ Map.lookup name env
|
||||||
emx <- fieldParse field $ filteredEnv
|
emx <- fieldParse field $ filteredEnv
|
||||||
|
|||||||
@ -27,6 +27,7 @@ import Text.Julius (julius)
|
|||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Monad.Trans.Class (lift)
|
||||||
import Data.Text (Text, pack, unpack)
|
import Data.Text (Text, pack, unpack)
|
||||||
import Data.Monoid (mconcat)
|
import Data.Monoid (mconcat)
|
||||||
|
import Yesod.Core (RenderMessage)
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ >= 700
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
#define HTML html
|
#define HTML html
|
||||||
@ -65,12 +66,12 @@ class YesodJquery a where
|
|||||||
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
|
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
|
||||||
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
|
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
|
||||||
|
|
||||||
blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
|
blank :: (RenderMessage master FormMessage, Monad m) => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))
|
||||||
blank _ [] = Right Nothing
|
blank _ [] = return $ Right Nothing
|
||||||
blank _ ("":_) = Right Nothing
|
blank _ ("":_) = return $ Right Nothing
|
||||||
blank f (x:_) = either Left (Right . Just) $ f x
|
blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x
|
||||||
|
|
||||||
jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
|
jqueryDayField :: (RenderMessage master FormMessage, YesodJquery master) => JqueryDaySettings -> Field sub master Day
|
||||||
jqueryDayField jds = Field
|
jqueryDayField jds = Field
|
||||||
{ fieldParse = blank $ maybe
|
{ fieldParse = blank $ maybe
|
||||||
(Left MsgInvalidDay)
|
(Left MsgInvalidDay)
|
||||||
@ -125,7 +126,7 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
|
|||||||
let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")
|
let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")
|
||||||
in (showLeadingZero h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
|
in (showLeadingZero h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
|
||||||
|
|
||||||
jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime
|
jqueryDayTimeField :: (RenderMessage master FormMessage, YesodJquery master) => Field sub master UTCTime
|
||||||
jqueryDayTimeField = Field
|
jqueryDayTimeField = Field
|
||||||
{ fieldParse = blank $ parseUTCTime . unpack
|
{ fieldParse = blank $ parseUTCTime . unpack
|
||||||
, fieldView = \theId name val isReq -> do
|
, fieldView = \theId name val isReq -> do
|
||||||
@ -154,7 +155,8 @@ parseUTCTime s =
|
|||||||
ifRight (parseTime timeS)
|
ifRight (parseTime timeS)
|
||||||
(UTCTime date . timeOfDayToTime)
|
(UTCTime date . timeOfDayToTime)
|
||||||
|
|
||||||
jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text
|
jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master)
|
||||||
|
=> Route master -> Field sub master Text
|
||||||
jqueryAutocompleteField src = Field
|
jqueryAutocompleteField src = Field
|
||||||
{ fieldParse = blank $ Right
|
{ fieldParse = blank $ Right
|
||||||
, fieldView = \theId name val isReq -> do
|
, fieldView = \theId name val isReq -> do
|
||||||
|
|||||||
@ -20,22 +20,16 @@ import Text.Blaze.Renderer.String (renderHtml)
|
|||||||
import Text.Blaze (preEscapedString)
|
import Text.Blaze (preEscapedString)
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Monad.Trans.Class (lift)
|
||||||
import Data.Text (Text, pack, unpack)
|
import Data.Text (Text, pack, unpack)
|
||||||
|
import Data.Maybe (listToMaybe)
|
||||||
|
|
||||||
class YesodNic a where
|
class YesodNic a where
|
||||||
-- | NIC Editor Javascript file.
|
-- | NIC Editor Javascript file.
|
||||||
urlNicEdit :: a -> Either (Route a) Text
|
urlNicEdit :: a -> Either (Route a) Text
|
||||||
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
|
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
|
||||||
|
|
||||||
blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
|
nicHtmlField :: YesodNic master => Field sub master Html
|
||||||
blank _ [] = Right Nothing
|
|
||||||
blank _ ("":_) = Right Nothing
|
|
||||||
blank f (x:_) = either Left (Right . Just) $ f x
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
|
|
||||||
nicHtmlField = Field
|
nicHtmlField = Field
|
||||||
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME
|
{ fieldParse = return . Right . fmap (preEscapedString . sanitizeBalance . unpack) . listToMaybe -- FIXME
|
||||||
, fieldView = \theId name val _isReq -> do
|
, fieldView = \theId name val _isReq -> do
|
||||||
addHtml
|
addHtml
|
||||||
#if __GLASGOW_HASKELL__ >= 700
|
#if __GLASGOW_HASKELL__ >= 700
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user