{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} module Main where import Control.Applicative ((<$>)) import Control.Monad (msum) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans (MonadIO(liftIO)) import Data.Map (Map, fromList) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as Text import Happstack.Server ( ServerPart, ServerPartT, dir, lookTexts', mapServerPartT , nullConf, nullDir, queryString, simpleHTTP , acceptLanguage, bestLanguage ) import Happstack.Server.HSP.HTML import Text.Shakespeare.I18N ( RenderMessage(..), Lang, mkMessage, mkMessageFor , mkMessageVariant) import System.Random (randomRIO) data Message = Hello | Goodbye translation_en :: Message -> Text translation_en Hello = Text.pack "hello" translation_en Goodbye = "goodbye" translation_lojban :: Message -> Text translation_lojban Hello = "coi" translation_lojban Goodbye = "co'o" translations :: Map Text (Message -> Text) translations = fromList [ ("en" , translation_en) , ("lojban", translation_lojban) ] translate :: Text -> Message -> Text translate lang msg = case Map.lookup lang translations of Nothing -> "missing translation" (Just translator) -> translator msg helloPage :: (XMLGenerator m, EmbedAsChild m Text) => Text -> XMLGenT m (XMLType m) helloPage lang = <% translate lang Hello %>

<% translate lang Hello %>

plural_en :: (Integral i) => i -> String -> String -> String plural_en 1 x _ = x plural_en _ _ y = y data Thing = TypeError | SegFault deriving (Enum, Bounded, Show) mkMessageFor "DemoApp" "Thing" "messages/thing" ("en") thing_tr :: Lang -> Thing -> Text thing_tr lang thing = renderMessage DemoApp [lang] thing data DemoApp = DemoApp mkMessage "DemoApp" "messages/standard" ("en") type I18N = ServerPartT (ReaderT [Lang] IO) instance EmbedAsChild I18N DemoAppMessage where asChild msg = do lang <- ask asChild $ renderMessage DemoApp lang msg pageTemplate :: (EmbedAsChild I18N body) => String -> body -> I18N XML pageTemplate title body = defaultTemplate title ()
<% body %>
homePage :: I18N XML homePage = pageTemplate "home"

<% MsgHello %>

goodbyePage :: I18N XML goodbyePage = pageTemplate "goodbye"

<% MsgGoodbye %>

problemsPage :: Int -> Thing -> I18N XML problemsPage n thing = pageTemplate "problems"

<% MsgProblems n thing %>

withI18N :: I18N a -> ServerPart a withI18N part = do langsOverride <- queryString $ lookTexts' "_LANG" langs <- bestLanguage <$> acceptLanguage mapServerPartT (flip runReaderT (langsOverride ++ langs)) part routes :: I18N XML routes = msum [ do nullDir homePage , dir "goodbye" $ goodbyePage , dir "problems" $ do n <- liftIO $ randomRIO (1, 99) let things = [TypeError .. SegFault] index <- liftIO $ randomRIO (0, length things - 1) let thing = things !! index problemsPage n thing ] main :: IO () main = simpleHTTP nullConf $ withI18N routes