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

Much improved i18n support

Browse Source
This commit is contained in:
Michael Snoyman 2011-05-15 15:16:43 +03:00
parent 4168d13616
commit 32863deb85
5 changed files with 66 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Test/Widget.hs
View File

@ -18,6 +18,9 @@ import Network.Wai.Test
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
data Y = Y data Y = Y
mkMessage "Y" "test" "en"
mkYesod "Y" [$parseRoutes| mkYesod "Y" [$parseRoutes|
/ RootR GET / RootR GET
/foo/*Strings MultiR GET /foo/*Strings MultiR GET
@ -31,19 +34,19 @@ getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|]
getMultiR _ = return () getMultiR _ = return ()
data Msg = Hello | Goodbye data Msg = Hello | Goodbye
instance YesodMessage Y Y where instance RenderMessage Y Msg where
type Message Y Y = Msg renderMessage _ ("en":_) Hello = "Hello"
renderMessage _ _ ("en":_) Hello = "Hello" renderMessage _ ("es":_) Hello = "Hola"
renderMessage _ _ ("es":_) Hello = "Hola" renderMessage _ ("en":_) Goodbye = "Goodbye"
renderMessage _ _ ("en":_) Goodbye = "Goodbye" renderMessage _ ("es":_) Goodbye = "Adios"
renderMessage _ _ ("es":_) Goodbye = "Adios" renderMessage a (_:xs) y = renderMessage a xs y
renderMessage a b (_:xs) y = renderMessage a b xs y renderMessage a [] y = renderMessage a ["en"] y
renderMessage a b [] y = renderMessage a b ["en"] y
getWhamletR = defaultLayout [$whamlet| getWhamletR = defaultLayout [$whamlet|
<h1>Test <h1>Test
<h2>@{WhamletR} <h2>@{WhamletR}
<h3>_{Goodbye} <h3>_{Goodbye}
<h3>_{MsgAnother}
^{embed} ^{embed}
|] |]
where where
@ -72,4 +75,4 @@ case_whamlet = runner $ do
{ pathInfo = ["whamlet"] { pathInfo = ["whamlet"]
, requestHeaders = [("Accept-Language", "es")] , requestHeaders = [("Accept-Language", "es")]
} }
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h4>Embed</h4></body></html>" res assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res

2
Yesod/Core.hs
View File

@ -31,6 +31,7 @@ module Yesod.Core
, module Yesod.Handler , module Yesod.Handler
, module Yesod.Request , module Yesod.Request
, module Yesod.Widget , module Yesod.Widget
, module Yesod.Message
) where ) where
import Yesod.Internal.Core import Yesod.Internal.Core
@ -39,6 +40,7 @@ import Yesod.Dispatch
import Yesod.Handler import Yesod.Handler
import Yesod.Request import Yesod.Request
import Yesod.Widget import Yesod.Widget
import Yesod.Message
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Data.Text (Text) import Data.Text (Text)

32
Yesod/Handler.hs
View File

@ -50,7 +50,9 @@ module Yesod.Handler
, notFound , notFound
, badMethod , badMethod
, permissionDenied , permissionDenied
, permissionDeniedI
, invalidArgs , invalidArgs
, invalidArgsI
-- ** Short-circuit responses. -- ** Short-circuit responses.
, sendFile , sendFile
, sendFilePart , sendFilePart
@ -81,6 +83,7 @@ module Yesod.Handler
, redirectUltDest , redirectUltDest
-- ** Messages -- ** Messages
, setMessage , setMessage
, setMessageI
, getMessage , getMessage
-- * Helpers for specific content -- * Helpers for specific content
-- ** Hamlet -- ** Hamlet
@ -89,6 +92,8 @@ module Yesod.Handler
-- ** Misc -- ** Misc
, newIdent , newIdent
, liftIOHandler , liftIOHandler
-- * i18n
, getMessageRender
-- * Internal Yesod -- * Internal Yesod
, runHandler , runHandler
, YesodApp (..) , YesodApp (..)
@ -154,6 +159,7 @@ import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text) import Data.Text (Text)
import Yesod.Message (RenderMessage (..))
-- | The type-safe URLs associated with a site argument. -- | The type-safe URLs associated with a site argument.
type family Route a type family Route a
@ -501,6 +507,14 @@ msgKey = "_MSG"
setMessage :: Monad mo => Html -> GGHandler sub master mo () setMessage :: Monad mo => Html -> GGHandler sub master mo ()
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
setMessageI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler sub y mo ()
setMessageI msg = do
mr <- getMessageRender
setMessage $ toHtml $ mr msg
-- | Gets the message in the user's session, if available, and then clears the -- | Gets the message in the user's session, if available, and then clears the
-- variable. -- variable.
-- --
@ -569,10 +583,22 @@ badMethod = do
permissionDenied :: Failure ErrorResponse m => Text -> m a permissionDenied :: Failure ErrorResponse m => Text -> m a
permissionDenied = failure . PermissionDenied permissionDenied = failure . PermissionDenied
-- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler s y mo a
permissionDeniedI msg = do
mr <- getMessageRender
permissionDenied $ mr msg
-- | Return a 400 invalid arguments page. -- | Return a 400 invalid arguments page.
invalidArgs :: Failure ErrorResponse m => [Text] -> m a invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs invalidArgs = failure . InvalidArgs
-- | Return a 400 invalid arguments page.
invalidArgsI :: (RenderMessage y msg, Monad mo) => [msg] -> GGHandler s y mo a
invalidArgsI msg = do
mr <- getMessageRender
invalidArgs $ map mr msg
------- Headers ------- Headers
-- | Set the cookie on the client. -- | Set the cookie on the client.
setCookie :: Monad mo setCookie :: Monad mo
@ -848,3 +874,9 @@ hamletToRepHtml = liftM RepHtml . hamletToContent
-- | Get the request\'s 'W.Request' value. -- | Get the request\'s 'W.Request' value.
waiRequest :: Monad mo => GGHandler sub master mo W.Request waiRequest :: Monad mo => GGHandler sub master mo W.Request
waiRequest = reqWaiRequest `liftM` getRequest waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (Monad mo, RenderMessage master message) => GGHandler s master mo (message -> Text)
getMessageRender = do
m <- getYesod
l <- reqLangs `liftM` getRequest
return $ renderMessage m l

43
Yesod/Widget.hs
View File

@ -11,14 +11,13 @@ module Yesod.Widget
, GGWidget (..) , GGWidget (..)
, PageContent (..) , PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets -- * Special Hamlet quasiquoter/TH for Widgets
, YesodMessage (..)
, getMessageRender
, whamlet , whamlet
, whamletFile , whamletFile
, ihamletToRepHtml , ihamletToRepHtml
-- * Creating -- * Creating
-- ** Head of page -- ** Head of page
, setTitle , setTitle
, setTitleI
, addHamletHead , addHamletHead
, addHtmlHead , addHtmlHead
-- ** Body -- ** Body
@ -56,7 +55,10 @@ import Text.Cassius
import Text.Lucius (Lucius) import Text.Lucius (Lucius)
import Text.Julius import Text.Julius
import Yesod.Handler import Yesod.Handler
(Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) (Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender
)
import Yesod.Message (RenderMessage)
import Yesod.Content (RepHtml (..), toContent) import Yesod.Content (RepHtml (..), toContent)
import Control.Applicative (Applicative) import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
@ -67,8 +69,7 @@ import Data.Text (Text)
import qualified Data.Map as Map import qualified Data.Map as Map
import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
import Yesod.Handler (getUrlRenderParams, getYesodSub) import Yesod.Handler (getUrlRenderParams)
import Yesod.Request (languages)
import Control.Monad.IO.Control (MonadControlIO) import Control.Monad.IO.Control (MonadControlIO)
import qualified Text.Hamlet.NonPoly as NP import qualified Text.Hamlet.NonPoly as NP
@ -117,6 +118,13 @@ addSubWidget sub (GWidget w) = do
setTitle :: Monad m => Html -> GGWidget master m () setTitle :: Monad m => Html -> GGWidget master m ()
setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values.
setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GGHandler sub master m) ()
setTitleI msg = do
mr <- lift getMessageRender
setTitle $ toHtml $ mr msg
-- | Add a 'Hamlet' to the head tag. -- | Add a 'Hamlet' to the head tag.
addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m () addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m ()
addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head
@ -219,23 +227,6 @@ data PageContent url = PageContent
, pageBody :: Hamlet url , pageBody :: Hamlet url
} }
-- see if it's possible to get rid of sub here. Problem was yesod-auth, but maybe we can do something like:
-- instance YesodAuth m => YesodMessage m ...
class YesodMessage sub master where
type Message sub master
renderMessage :: sub
-> master
-> [Text] -- ^ languages
-> Message sub master
-> Html
getMessageRender :: (Monad mo, YesodMessage s m) => GGHandler s m mo (Message s m -> Html)
getMessageRender = do
s <- getYesodSub
m <- getYesod
l <- languages
return $ renderMessage s m l
whamlet :: QuasiQuoter whamlet :: QuasiQuoter
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
@ -255,15 +246,15 @@ rules = do
let ur f = do let ur f = do
let env = NP.Env let env = NP.Env
(Just $ helper [|lift getUrlRenderParams|]) (Just $ helper [|lift getUrlRenderParams|])
(Just $ helper [|lift getMessageRender|]) (Just $ helper [|fmap (toHtml .) $ lift getMessageRender|])
f env f env
return $ NP.HamletRules ah ur $ \_ b -> return b return $ NP.HamletRules ah ur $ \_ b -> return b
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: (Monad mo, YesodMessage sub master) ihamletToRepHtml :: (Monad mo, RenderMessage master message)
=> NP.IHamlet (Message sub master) (Route master) => NP.IHamlet message (Route master)
-> GGHandler sub master mo RepHtml -> GGHandler sub master mo RepHtml
ihamletToRepHtml ih = do ihamletToRepHtml ih = do
urender <- getUrlRenderParams urender <- getUrlRenderParams
mrender <- getMessageRender mrender <- getMessageRender
return $ RepHtml $ toContent $ ih mrender urender return $ RepHtml $ toContent $ ih (toHtml . mrender) urender

3
yesod-core.cabal
View File

@ -49,12 +49,15 @@ library
, blaze-html >= 0.4 && < 0.5 , blaze-html >= 0.4 && < 0.5
, http-types >= 0.6 && < 0.7 , http-types >= 0.6 && < 0.7
, case-insensitive >= 0.2 && < 0.3 , case-insensitive >= 0.2 && < 0.3
, parsec >= 2 && < 3.2
, directory >= 1 && < 1.2
exposed-modules: Yesod.Content exposed-modules: Yesod.Content
Yesod.Core Yesod.Core
Yesod.Dispatch Yesod.Dispatch
Yesod.Handler Yesod.Handler
Yesod.Request Yesod.Request
Yesod.Widget Yesod.Widget
Yesod.Message
other-modules: Yesod.Internal other-modules: Yesod.Internal
Yesod.Internal.Core Yesod.Internal.Core
Yesod.Internal.Session Yesod.Internal.Session