2 files changed, 57 insertions(+), 59 deletions(-)

M src/Text/HTML/Form/Validate.hs
M src/Text/HTML/Form/WebApp/Ginger.hs

@@ 4,7 4,8 @@
 module Text.HTML.Form.Validate(isInputValid, isInputValid', isFormValid, isFormValid',
         inputErrorMessage, inputErrorMessage', normalizeInput, normalizeForm) where
 
-import Text.HTML.Form
+import Text.HTML.Form hiding (lang)
+import Text.HTML.Form.I18n
 import qualified Data.Text as Txt
 import Text.Read (readMaybe)
 import Data.Hourglass


@@ 22,82 23,78 @@ isFormValid' = all isInputValid' . inputs
 
 -- | Is the given input valid?
 isInputValid :: Input -> Bool
-isInputValid = null . inputErrorMessage
+isInputValid = null . inputErrorMessage "en"
 
 -- | Is the given input once normalized valid?
 isInputValid' :: Input -> Bool
-isInputValid' = null . inputErrorMessage'
+isInputValid' = null . inputErrorMessage' "en"
 
 -- | Describe why a form input is invalid, or return the empty string.
-inputErrorMessage :: Input -> String
-inputErrorMessage Input { inputType = "hidden" } = "" -- Don't validate hiddens!
-inputErrorMessage self@Input { required = True }
-    | inputType self == "checkbox", not $ checked self = "Required!"
+inputErrorMessage :: String -> Input -> String
+inputErrorMessage _ Input { inputType = "hidden" } = "" -- Don't validate hiddens!
+inputErrorMessage lang self@Input { required = True }
+    | inputType self == "checkbox", not $ checked self = i18n lang "err required"
     -- Not validating "radio", needs different API...
-    | value self == "" = "Required!"
-inputErrorMessage Input { value = "" } = "" -- Skip further checks for empty!
-inputErrorMessage self@Input { pattern = Just re }
-    | not $ re `matchTest` value self = "Invalid format!"
-inputErrorMessage Input { lengthRange = (Just min', _), value = val }
-    | Txt.length val < min' = "Must be at least " ++ show min' ++ " characters!"
-inputErrorMessage Input { lengthRange = (_, Just max'), value = val }
-    | Txt.length val > max' = "Must be at most " ++ show max' ++ " characters!"
-inputErrorMessage Input { range = (Just min', _), value = val }
+    | value self == "" = i18n lang "err required"
+inputErrorMessage _ Input { value = "" } = "" -- Skip further checks for empty!
+inputErrorMessage lang self@Input { pattern = Just re }
+    | not $ re `matchTest` value self = i18n lang "err format"
+inputErrorMessage lang Input { lengthRange = (Just min', _), value = val }
+    | Txt.length val < min' = i18n' lang "err min chars" min'
+inputErrorMessage lang Input { lengthRange = (_, Just max'), value = val }
+    | Txt.length val > max' = i18n' lang "err max chars" max'
+inputErrorMessage lang Input { range = (Just min', _), value = val }
     | Just x <- readMaybe' val :: Maybe Float, Just y <- readMaybe' min', x < y =
-        "Must be at least " ++ Txt.unpack min' ++ "!"
-inputErrorMessage Input { range = (_, Just max'), value = val }
+        i18n' lang "err min" min'
+inputErrorMessage lang Input { range = (_, Just max'), value = val }
     | Just x <- readMaybe' val :: Maybe Float, Just y <- readMaybe' max', x > y =
-        "Must be at most " ++ Txt.unpack max' ++ "!"
-inputErrorMessage Input { range = (Just min', _), step = Just step', value = val }
+        i18n' lang "err max" max'
+inputErrorMessage lang Input { range = (Just min', _), step = Just step', value = val }
     | Just x <- readMaybe' val :: Maybe Integer, Just y <- readMaybe' min',
         Just z <- readMaybe' step', z /= 0, rem (x - y) z == 0 =
-            ("Must be in increments of " ++ Txt.unpack step' ++ " from "
-            ++ Txt.unpack min' ++ "!")
-inputErrorMessage Input { range = (Just min', _), value = val }
+            i18n2 lang "err increments" step' min'
+inputErrorMessage lang Input { range = (Just min', _), value = val }
     | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min',
-        x < y = "Must be at least " ++ Txt.unpack min' ++ "!"
-inputErrorMessage Input { range = (_, Just max'), value = val }
+        x < y = i18n' lang "err min" min'
+inputErrorMessage lang Input { range = (_, Just max'), value = val }
     | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack max',
-        x > y = "Must be at most " ++ Txt.unpack max' ++ "!"
-inputErrorMessage Input {
+        x > y = i18n' lang "err max" max'
+inputErrorMessage lang Input {
         range = (Just min', _), step = Just step',
         inputType = ty, value = val
       }
     | ty == "date", Just x <- parseTime $ Txt.unpack val,
         Just y <- parseTime $ Txt.unpack min', Just z <- readMaybe' step',
         timeDiff x y `rem` toSeconds mempty { durationSeconds = 24*z } == Seconds 0 =
-            ("Must be in increments of " ++ Txt.unpack step' ++ " days from " ++
-            Txt.unpack min' ++ "!")
+            i18n2 lang "err increments" step' min'
     | ty == "month" = "" -- Not prepared to properly validate this...
     | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min',
         Just z <- readMaybe' step', timeDiff x y `rem` Seconds z == Seconds 0 =
-            ("Must be in increments of " ++ Txt.unpack step' ++ "s from " ++
-            Txt.unpack min' ++ "!")
+            i18n2 lang "err increments" step' min'
 
 -- Validation specific to input types
-inputErrorMessage self@Input { inputType = "color" }
-    | ("#[0-9a-fA-F]{6}" :: String) =~ value self = "Invalid colour value!"
-inputErrorMessage self@Input { inputType = "date" } = isTime' self
-inputErrorMessage self@Input { inputType = "datetime" } = isTime' self
-inputErrorMessage self@Input { inputType = "datetime-local" } = isTime' self
+inputErrorMessage lang self@Input { inputType = "color" }
+    | ("#[0-9a-fA-F]{6}" :: String) =~ value self = i18n lang "err colour"
+inputErrorMessage lang self@Input { inputType = "date" } = isTime' lang self
+inputErrorMessage lang self@Input { inputType = "datetime" } = isTime' lang self
+inputErrorMessage l self@Input { inputType = "datetime-local" } = isTime' l self
 -- This validation is less strict than many sites expect, but don't over-validate...
-inputErrorMessage self@Input { inputType = "email" }
-    | '@' `Txt.elem` value self =
-        "Obviously invalid email address, needs an '@'!"
-inputErrorMessage self@Input { inputType = "month" } = isTime' self
-inputErrorMessage Input { inputType = "number", value = val }
-    | isNothing (readMaybe' val :: Maybe Float) = "Invalid number!"
-inputErrorMessage Input { inputType = "range", value = val }
-    | isNothing (readMaybe' val :: Maybe Float) = "Invalid number!"
-inputErrorMessage self@Input { inputType = "time" } = isTime' self
-inputErrorMessage self@Input { inputType = "url" }
-    | isURL $ value self = "Invalid web address!"
-inputErrorMessage self@Input { inputType = "week" } = isTime' self
-inputErrorMessage _ = ""
+inputErrorMessage lang self@Input { inputType = "email" }
+    | '@' `Txt.elem` value self = i18n lang "err email"
+inputErrorMessage lang self@Input { inputType = "month" } = isTime' lang self
+inputErrorMessage lang Input { inputType = "number", value = val }
+    | isNothing (readMaybe' val :: Maybe Float) = i18n lang "err number"
+inputErrorMessage lang Input { inputType = "range", value = val }
+    | isNothing (readMaybe' val :: Maybe Float) = i18n lang "err number"
+inputErrorMessage lang self@Input { inputType = "time" } = isTime' lang self
+inputErrorMessage lang self@Input { inputType = "url" }
+    | isURL $ value self = i18n lang "err URL"
+inputErrorMessage lang self@Input { inputType = "week" } = isTime' lang self
+inputErrorMessage _ _ = ""
 
 -- | Describe why an input, once normalized, is invalid? Or returns empty string.
-inputErrorMessage' :: Input -> [Char]
-inputErrorMessage' = inputErrorMessage . normalizeInput
+inputErrorMessage' :: String -> Input -> [Char]
+inputErrorMessage' lang = inputErrorMessage lang . normalizeInput
 
 -- | Helper to parse the time stored in an input.
 parseTime :: String -> Maybe DateTime


@@ 106,9 103,9 @@ parseTime = fmap localTimeUnwrap . localTimeParse ISO8601_DateAndTime
 isTime :: Input -> Bool
 isTime = isJust . parseTime . Txt.unpack . value
 -- | Emit an error message if an input doesn't store a valid time.
-isTime' :: Input -> String
-isTime' x | isTime x = ""
-    | otherwise = "Invalid time format!"
+isTime' :: String -> Input -> String
+isTime' lang x | isTime x = ""
+    | otherwise = i18n lang "err time"
 -- | Parse a Text into any type that can be parsed from strings.
 readMaybe' :: Read a => Txt.Text -> Maybe a
 readMaybe' = readMaybe . Txt.unpack

@@ 52,14 52,15 @@ template' name form ix input query ctxt'
     ctxt :: Text -> GVal (Run SourcePos (Writer Html) Html)
     ctxt "Q" = query2gval query
     ctxt "form" = form2gval form
-    ctxt "inputs" = list' $ Prelude.map (flip input2gval query) $
+    ctxt "inputs" = list' $ Prelude.map (\x -> input2gval language x query) $
         Prelude.zip [0..] $ inputs form
-    ctxt "input" = input2gval (ix, input) query
+    ctxt "input" = input2gval language (ix, input) query
     ctxt "xURI" = fromFunction xURI
     ctxt x = ctxt' x
     xURI [(_, uri)] = let uri' = Txt.unpack $ asText uri in
         return$toGVal$Txt.pack $ escapeURIString isUnescapedInURIComponent uri'
     xURI _ = return $ toGVal ()
+    language = lang form
 
 -- | Lookup the given template from a compiled-in directory.
 resolveSource :: FilePath -> Maybe (Maybe [Char])


@@ 97,11 98,11 @@ form2gval form = orderedDict [
   ]
 
 -- | Convert an input to Ginger's datamodel.
-input2gval :: (Int, Input) -> Query -> GVal m
-input2gval (ix, input) query = orderedDict [
+input2gval :: String -> (Int, Input) -> Query -> GVal m
+input2gval language (ix, input) query = orderedDict [
     "index"       ~> ix,
     "label"       ~> label input,
-    "error"       ~> inputErrorMessage' (applyQuery input
+    "error"       ~> inputErrorMessage' language (applyQuery input
             [(B8.unpack k, B8.unpack $ fromMaybe "" v) | (k, v) <- query]),
     "description" ~> html (description input),
     "inputType"   ~> inputType input,