2011-09-15

Yesod Cookbook: Internationalized Form

I posted the following example of an internationalized form to the Yesod Cookbook a few days ago. Yesod has a pretty awesome library for programming with forms and also a flexible but currently under-documented system for internationalization. However, how the two interact, while straightforward, might not be immediately obvious to the newcomer. Hence the motivation for the below example which shows how to internationalize both custom messages and Yesod's built-in FormMessages (mostly form error messages).

Familiarity with Yesod at the level of the Yesod Book is assumed.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
{-

INTERNATIONALIZED FORM

Below is an example of how to internationalize a Yesod application,
including internationalization (i18n) of a form and Yesod's built-in
form error messages.

In the example we create a simple site that will show messages in
Swedish or English depending on the browser's preferred language.
If neither Swedish or English are preferred languages the site will
default to Swedish.

Familiarity with Yesod at the level of the Yesod book is assumed,
comments are concentrated to the parts relevant to i18n.

-}

{-# LANGUAGE QuasiQuotes
           , TemplateHaskell
           , MultiParamTypeClasses
           , OverloadedStrings
           , TypeFamilies
  #-}

import Yesod
import Yesod.Form.I18n.Swedish
import Control.Applicative ((<$>), (<*>))
import Data.Text (Text)


-- Our foundation data type.
data MyApp = MyApp

mkYesod "MyApp" [parseRoutes|
/    RootR GET
|]

instance Yesod MyApp where
    approot _ = ""


-- Here we provide internationalization of Yesod's built in form
-- messages (mostly error messages). For brevity it is assumed that
-- Swedish translations are exported as 'swedishFormMessage' by the
-- module Yesod.Form.I18n.Swedish (an implementation can be copied
-- from https://gist.github.com/1209328).
instance RenderMessage MyApp FormMessage where
    renderMessage _ []        = swedishFormMessage -- Default to Swedish
    renderMessage _ ("sv":ls) = swedishFormMessage
    renderMessage _ ("en":ls) = defaultFormMessage -- English
    renderMessage m (_   :ls) = renderMessage m ls

-- Next we define the custom messages present on the site and their
-- rendering functions for different languages.
data Msg = Model
         | Year
         | Please

-- Rendering function for English.
renderEnglish Model  = "Model"
renderEnglish Year   = "Year"
renderEnglish Please = "Please fill in your car's details"

-- Rendering function for Swedish.
renderSwedish Model  = "Modell"
renderSwedish Year   = "Årgång"
renderSwedish Please = "Vänligen fyll i uppgifterna för din bil"

-- The instance used to select the appropriate rendering function.
-- This is almost identical to the instance for FormMessage above.
instance RenderMessage MyApp Msg where
    renderMessage _ []        = renderSwedish -- Default to Swedish
    renderMessage _ ("sv":ls) = renderSwedish
    renderMessage _ ("en":ls) = renderEnglish
    renderMessage m (_   :ls) = renderMessage m ls


-- The data model.
data Car = Car
    { carModel :: Text
    , carYear :: Int
    }
  deriving Show

-- In our form we use our messages Model and Year as field labels.
carAForm :: AForm MyApp MyApp Car
carAForm = Car
    <$> areq textField (fs Model) Nothing
    <*> areq intField  (fs Year)  Nothing
    where
        fs msg = FieldSettings msg Nothing Nothing Nothing

carForm :: Html -> Form MyApp MyApp (FormResult Car, Widget)
carForm = renderTable carAForm


-- Our handler just shows the form, with submitted values pre-filled.
-- Here we also use the Please message.
getRootR :: Handler RepHtml
getRootR = do
    ((_, widget), enctype) <- runFormGet carForm
    defaultLayout [whamlet|
        <p>_{Please}
        <form method=get action=@{RootR} enctype=#{enctype}>
            <table
                ^{widget}
            <p><input type=submit>
        |]


-- | Launch the app on port 3000.
main :: IO ()
main = warpDebug 3000 MyApp

Flattr this