Initial I18N suport
This commit is contained in:
Michael Snoyman
parent
0d77804d0f
commit
ef74164f5f
@ -21,6 +21,7 @@ data Y = Y
|
||||
mkYesod "Y" [$parseRoutes|
|
||||
/ RootR GET
|
||||
/foo/*Strings MultiR GET
|
||||
/whamlet WhamletR GET
|
||||
|]
|
||||
|
||||
instance Yesod Y where
|
||||
@ -29,9 +30,26 @@ instance Yesod Y where
|
||||
getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|]
|
||||
getMultiR _ = return ()
|
||||
|
||||
data Msg = Hello | Goodbye
|
||||
instance YesodMessage Y where
|
||||
type Message Y = Msg
|
||||
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}
|
||||
|]
|
||||
|
||||
widgetTest :: Test
|
||||
widgetTest = testGroup "Test.Widget"
|
||||
[ testCase "addJuliusBody" case_addJuliusBody
|
||||
, testCase "whamlet" case_whamlet
|
||||
]
|
||||
|
||||
runner f = toWaiApp Y >>= runSession f
|
||||
@ -45,3 +63,10 @@ defaultRequest = Request
|
||||
case_addJuliusBody = runner $ do
|
||||
res <- request defaultRequest
|
||||
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script><not escaped></script></body></html>" res
|
||||
|
||||
case_whamlet = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ 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></body></html>" res
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
|
||||
-- generator, allowing you to create truly modular HTML components.
|
||||
module Yesod.Widget
|
||||
@ -8,6 +9,11 @@ module Yesod.Widget
|
||||
GWidget
|
||||
, GGWidget (..)
|
||||
, PageContent (..)
|
||||
-- * Special Hamlet quasiquoter/TH for Widgets
|
||||
, YesodMessage (..)
|
||||
, getMessageRender
|
||||
, whamlet
|
||||
, whamletFile
|
||||
-- * Creating
|
||||
-- ** Head of page
|
||||
, setTitle
|
||||
@ -49,7 +55,7 @@ import Text.Cassius
|
||||
import Text.Lucius (Lucius)
|
||||
import Text.Julius
|
||||
import Yesod.Handler
|
||||
(Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
|
||||
(Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
|
||||
import Control.Applicative (Applicative)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Trans.Class (MonadTrans (lift))
|
||||
@ -57,8 +63,13 @@ import Yesod.Internal
|
||||
import Control.Monad (liftM)
|
||||
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 Control.Monad.IO.Control (MonadControlIO)
|
||||
import qualified Text.Hamlet.NonPoly as NP
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
-- site datatypes. This is basically a large 'WriterT' stack keeping track of
|
||||
@ -205,3 +216,39 @@ data PageContent url = PageContent
|
||||
, pageHead :: Hamlet url
|
||||
, pageBody :: Hamlet url
|
||||
}
|
||||
|
||||
class YesodMessage a where
|
||||
type Message a
|
||||
renderMessage :: a
|
||||
-> [Text] -- ^ languages
|
||||
-> Message a
|
||||
-> Html
|
||||
|
||||
getMessageRender :: (Monad mo, YesodMessage s) => GGHandler s m mo (Message s -> Html)
|
||||
getMessageRender = do
|
||||
s <- getYesodSub
|
||||
l <- languages
|
||||
return $ renderMessage s l
|
||||
|
||||
whamlet :: QuasiQuoter
|
||||
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
whamletFile :: FilePath -> Q Exp
|
||||
whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
rules :: Q NP.HamletRules
|
||||
rules = do
|
||||
ah <- [|addHtml|]
|
||||
let helper qg f = do
|
||||
x <- newName "urender"
|
||||
e <- f $ VarE x
|
||||
let e' = LamE [VarP x] e
|
||||
g <- qg
|
||||
bind <- [|(>>=)|]
|
||||
return $ InfixE (Just g) bind (Just e')
|
||||
let ur f = do
|
||||
let env = NP.Env
|
||||
(Just $ helper [|lift getUrlRenderParams|])
|
||||
(Just $ helper [|lift getMessageRender|])
|
||||
f env
|
||||
return $ NP.HamletRules ah ur
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-core
|
||||
version: 0.8.0.1
|
||||
version: 0.8.1
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -34,7 +34,7 @@ library
|
||||
, text >= 0.5 && < 0.12
|
||||
, template-haskell
|
||||
, web-routes-quasi >= 0.7.0.1 && < 0.8
|
||||
, hamlet >= 0.8 && < 0.9
|
||||
, hamlet >= 0.8.1 && < 0.9
|
||||
, blaze-builder >= 0.2.1 && < 0.4
|
||||
, transformers >= 0.2 && < 0.3
|
||||
, clientsession >= 0.6 && < 0.7
|
||||
|
||||
Loading…
Reference in New Issue
Block a user