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
data Y = Y
mkMessage "Y" "test" "en"
mkYesod "Y" [$parseRoutes|
/ RootR GET
/foo/*Strings MultiR GET
@ -31,19 +34,19 @@ getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|]
getMultiR _ = return ()
data Msg = Hello | Goodbye
instance YesodMessage Y Y where
type Message Y Y = Msg
renderMessage _ _ ("en":_) Hello = "Hello"
renderMessage _ _ ("es":_) Hello = "Hola"
renderMessage _ _ ("en":_) Goodbye = "Goodbye"
renderMessage _ _ ("es":_) Goodbye = "Adios"
renderMessage a b (_:xs) y = renderMessage a b xs y
renderMessage a b [] y = renderMessage a b ["en"] y
instance RenderMessage Y Msg where
renderMessage _ ("en":_) Hello = "Hello"
renderMessage _ ("es":_) Hello = "Hola"
renderMessage _ ("en":_) Goodbye = "Goodbye"
renderMessage _ ("es":_) Goodbye = "Adios"
renderMessage a (_:xs) y = renderMessage a xs y
renderMessage a [] y = renderMessage a ["en"] y
getWhamletR = defaultLayout [$whamlet|
<h1>Test
<h2>@{WhamletR}
<h3>_{Goodbye}
<h3>_{MsgAnother}
^{embed}
|]
where
@ -72,4 +75,4 @@ case_whamlet = runner $ do
{ pathInfo = ["whamlet"]
, 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.Request
, module Yesod.Widget
, module Yesod.Message
) where
import Yesod.Internal.Core
@ -39,6 +40,7 @@ import Yesod.Dispatch
import Yesod.Handler
import Yesod.Request
import Yesod.Widget
import Yesod.Message
import Language.Haskell.TH.Syntax
import Data.Text (Text)

32
Yesod/Handler.hs
View File

@ -50,7 +50,9 @@ module Yesod.Handler
, notFound
, badMethod
, permissionDenied
, permissionDeniedI
, invalidArgs
, invalidArgsI
-- ** Short-circuit responses.
, sendFile
, sendFilePart
@ -81,6 +83,7 @@ module Yesod.Handler
, redirectUltDest
-- ** Messages
, setMessage
, setMessageI
, getMessage
-- * Helpers for specific content
-- ** Hamlet
@ -89,6 +92,8 @@ module Yesod.Handler
-- ** Misc
, newIdent
, liftIOHandler
-- * i18n
, getMessageRender
-- * Internal Yesod
, runHandler
, YesodApp (..)
@ -154,6 +159,7 @@ import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI)
import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text)
import Yesod.Message (RenderMessage (..))
-- | The type-safe URLs associated with a site argument.
type family Route a
@ -501,6 +507,14 @@ msgKey = "_MSG"
setMessage :: Monad mo => Html -> GGHandler sub master mo ()
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
-- variable.
--
@ -569,10 +583,22 @@ badMethod = do
permissionDenied :: Failure ErrorResponse m => Text -> m a
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.
invalidArgs :: Failure ErrorResponse m => [Text] -> m a
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
-- | Set the cookie on the client.
setCookie :: Monad mo
@ -848,3 +874,9 @@ hamletToRepHtml = liftM RepHtml . hamletToContent
-- | Get the request\'s 'W.Request' value.
waiRequest :: Monad mo => GGHandler sub master mo W.Request
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 (..)
, PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets
, YesodMessage (..)
, getMessageRender
, whamlet
, whamletFile
, ihamletToRepHtml
-- * Creating
-- ** Head of page
, setTitle
, setTitleI
, addHamletHead
, addHtmlHead
-- ** Body
@ -56,7 +55,10 @@ import Text.Cassius
import Text.Lucius (Lucius)
import Text.Julius
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 Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO)
@ -67,8 +69,7 @@ import Data.Text (Text)
import qualified Data.Map as Map
import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
import Yesod.Handler (getUrlRenderParams, getYesodSub)
import Yesod.Request (languages)
import Yesod.Handler (getUrlRenderParams)
import Control.Monad.IO.Control (MonadControlIO)
import qualified Text.Hamlet.NonPoly as NP
@ -117,6 +118,13 @@ addSubWidget sub (GWidget w) = do
setTitle :: Monad m => Html -> GGWidget master m ()
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.
addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m ()
addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head
@ -219,23 +227,6 @@ data PageContent url = PageContent
, 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 = NP.hamletWithSettings rules NP.defaultHamletSettings
@ -255,15 +246,15 @@ rules = do
let ur f = do
let env = NP.Env
(Just $ helper [|lift getUrlRenderParams|])
(Just $ helper [|lift getMessageRender|])
(Just $ helper [|fmap (toHtml .) $ lift getMessageRender|])
f env
return $ NP.HamletRules ah ur $ \_ b -> return b
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: (Monad mo, YesodMessage sub master)
=> NP.IHamlet (Message sub master) (Route master)
ihamletToRepHtml :: (Monad mo, RenderMessage master message)
=> NP.IHamlet message (Route master)
-> GGHandler sub master mo RepHtml
ihamletToRepHtml ih = do
urender <- getUrlRenderParams
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
, http-types >= 0.6 && < 0.7
, case-insensitive >= 0.2 && < 0.3
, parsec >= 2 && < 3.2
, directory >= 1 && < 1.2
exposed-modules: Yesod.Content
Yesod.Core
Yesod.Dispatch
Yesod.Handler
Yesod.Request
Yesod.Widget
Yesod.Message
other-modules: Yesod.Internal
Yesod.Internal.Core
Yesod.Internal.Session