419 lines
16 KiB
Haskell
419 lines
16 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Foundation.I18n
|
|
( appLanguages, appLanguagesOpts
|
|
, UniWorXMessage(..)
|
|
, ShortTermIdentifier(..)
|
|
, MsgLanguage(..)
|
|
, ShortSex(..)
|
|
, ShortWeekDay(..)
|
|
, SheetTypeHeader(..)
|
|
, SheetArchiveFileTypeDirectory(..)
|
|
, ShortStudyDegree(..)
|
|
, ShortStudyTerms(..)
|
|
, StudyDegreeTerm(..)
|
|
, ShortStudyFieldType(..)
|
|
, StudyDegreeTermType(..)
|
|
, ErrorResponseTitle(..)
|
|
, UniWorXMessages(..)
|
|
, uniworxMessages
|
|
, unRenderMessage, unRenderMessage', unRenderMessageLenient
|
|
) where
|
|
|
|
import Foundation.Type
|
|
|
|
|
|
import Import.NoFoundation
|
|
|
|
import Auth.LDAP
|
|
import Auth.PWHash
|
|
import Auth.Dummy
|
|
|
|
import Data.CaseInsensitive (original, mk)
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import Utils.Form
|
|
|
|
import qualified GHC.Exts (IsList(..))
|
|
|
|
import Yesod.Form.I18n.German
|
|
import Yesod.Form.I18n.English
|
|
|
|
import qualified Data.Char as Char
|
|
import Text.Unidecode (unidecode)
|
|
import Data.Text.Lens (packed)
|
|
|
|
import Data.List ((!!))
|
|
|
|
|
|
appLanguages :: NonEmpty Lang
|
|
appLanguages = "de-de-formal" :| ["en-eu"]
|
|
|
|
|
|
pluralDE :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ Singular
|
|
-> Text -- ^ Plural
|
|
-> Text
|
|
pluralDE num singularForm pluralForm
|
|
| num == 1 = singularForm
|
|
| otherwise = pluralForm
|
|
|
|
noneOneMoreDE :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ None
|
|
-> Text -- ^ Singular
|
|
-> Text -- ^ Plural
|
|
-> Text
|
|
noneOneMoreDE num noneText singularForm pluralForm
|
|
| num == 0 = noneText
|
|
| num == 1 = singularForm
|
|
| otherwise = pluralForm
|
|
|
|
-- noneMoreDE :: (Eq a, Num a)
|
|
-- => a -- ^ Count
|
|
-- -> Text -- ^ None
|
|
-- -> Text -- ^ Some
|
|
-- -> Text
|
|
-- noneMoreDE num noneText someText
|
|
-- | num == 0 = noneText
|
|
-- | otherwise = someText
|
|
|
|
pluralEN :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ Singular
|
|
-> Text -- ^ Plural
|
|
-> Text
|
|
pluralEN num singularForm pluralForm
|
|
| num == 1 = singularForm
|
|
| otherwise = pluralForm
|
|
|
|
noneOneMoreEN :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ None
|
|
-> Text -- ^ Singular
|
|
-> Text -- ^ Plural
|
|
-> Text
|
|
noneOneMoreEN num noneText singularForm pluralForm
|
|
| num == 0 = noneText
|
|
| num == 1 = singularForm
|
|
| otherwise = pluralForm
|
|
|
|
-- noneMoreEN :: (Eq a, Num a)
|
|
-- => a -- ^ Count
|
|
-- -> Text -- ^ None
|
|
-- -> Text -- ^ Some
|
|
-- -> Text
|
|
-- noneMoreEN num noneText someText
|
|
-- | num == 0 = noneText
|
|
-- | otherwise = someText
|
|
|
|
ordinalEN :: ToMessage a
|
|
=> a
|
|
-> Text
|
|
ordinalEN (toMessage -> numStr) = case lastChar of
|
|
Just '1' -> [st|#{numStr}st|]
|
|
Just '2' -> [st|#{numStr}nd|]
|
|
Just '3' -> [st|#{numStr}rd|]
|
|
_other -> [st|#{numStr}th|]
|
|
where
|
|
lastChar = last <$> fromNullable numStr
|
|
|
|
|
|
-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
|
|
type IntMaybe = Maybe Int
|
|
|
|
-- | Convenience function for i18n messages definitions
|
|
maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
|
|
maybeToMessage _ Nothing _ = mempty
|
|
maybeToMessage before (Just x) after = before <> toMessage x <> after
|
|
|
|
-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
|
|
mkMessage "UniWorX" "messages/uniworx" "de-de-formal"
|
|
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
|
|
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
|
|
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
|
|
mkMessageVariant "UniWorX" "Button" "messages/button" "de"
|
|
mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de-de-formal"
|
|
|
|
instance RenderMessage UniWorX TermIdentifier where
|
|
renderMessage foundation ls TermIdentifier{..} = case season of
|
|
Summer -> renderMessage' $ MsgSummerTerm year
|
|
Winter -> renderMessage' $ MsgWinterTerm year
|
|
where renderMessage' = renderMessage foundation ls
|
|
|
|
newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
|
|
deriving stock (Eq, Ord, Read, Show)
|
|
instance RenderMessage UniWorX ShortTermIdentifier where
|
|
renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
|
|
Summer -> renderMessage' $ MsgSummerTermShort year
|
|
Winter -> renderMessage' $ MsgWinterTermShort year
|
|
where renderMessage' = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX String where
|
|
renderMessage f ls str = renderMessage f ls $ Text.pack str
|
|
|
|
-- TODO: raw number representation; instead, display e.g. 1000 as 1.000 or 1,000 or ... (language-dependent!)
|
|
instance RenderMessage UniWorX Int where
|
|
renderMessage f ls = renderMessage f ls . tshow
|
|
instance RenderMessage UniWorX Int64 where
|
|
renderMessage f ls = renderMessage f ls . tshow
|
|
instance RenderMessage UniWorX Integer where
|
|
renderMessage f ls = renderMessage f ls . tshow
|
|
instance RenderMessage UniWorX Natural where
|
|
renderMessage f ls = renderMessage f ls . tshow
|
|
|
|
instance HasResolution a => RenderMessage UniWorX (Fixed a) where
|
|
renderMessage f ls = renderMessage f ls . showFixed True
|
|
|
|
instance RenderMessage UniWorX Load where
|
|
renderMessage foundation ls = renderMessage foundation ls . \case
|
|
Load { byTutorial = Nothing , byProportion = p } -> MsgCorByProportionOnly p
|
|
Load { byTutorial = Just True , byProportion = p } -> MsgCorByProportionIncludingTutorial p
|
|
Load { byTutorial = Just False, byProportion = p } -> MsgCorByProportionExcludingTutorial p
|
|
|
|
newtype MsgLanguage = MsgLanguage Lang
|
|
deriving stock (Eq, Ord, Show, Read)
|
|
instance RenderMessage UniWorX MsgLanguage where
|
|
renderMessage foundation ls (MsgLanguage lang@(map mk . Text.splitOn "-" -> lang'))
|
|
| ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
|
|
| ("de" : _) <- lang' = mr MsgGerman
|
|
| ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
|
|
| ("en" : _) <- lang' = mr MsgEnglish
|
|
| otherwise = lang
|
|
where
|
|
mr = renderMessage foundation $ lang : filter (/= lang) ls
|
|
|
|
appLanguagesOpts :: ( MonadHandler m
|
|
, RenderMessage (HandlerSite m) MsgLanguage
|
|
) => m (OptionList Lang)
|
|
-- ^ Authoritive list of supported Languages
|
|
appLanguagesOpts = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let mkOption l = Option
|
|
{ optionDisplay = mr $ MsgLanguage l
|
|
, optionInternalValue = l
|
|
, optionExternalValue = l
|
|
}
|
|
langOptions = map mkOption $ toList appLanguages
|
|
return $ mkOptionList langOptions
|
|
|
|
embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
|
|
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
|
|
embedRenderMessage ''UniWorX ''StudyFieldType id
|
|
embedRenderMessage ''UniWorX ''SheetFileType id
|
|
embedRenderMessage ''UniWorX ''SubmissionFileType id
|
|
embedRenderMessage ''UniWorX ''CorrectorState id
|
|
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
|
|
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
|
|
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
|
|
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
|
|
embedRenderMessage ''UniWorX ''LecturerType id
|
|
embedRenderMessage ''UniWorX ''SubmissionModeDescr
|
|
$ let verbMap [_, _, "None"] = "NoSubmissions"
|
|
verbMap [_, _, v] = v <> "Submissions"
|
|
verbMap _ = error "Invalid number of verbs"
|
|
in verbMap . splitCamel
|
|
embedRenderMessage ''UniWorX ''UploadModeDescr id
|
|
embedRenderMessage ''UniWorX ''SecretJSONFieldException id
|
|
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
|
|
embedRenderMessage ''UniWorX ''SchoolFunction id
|
|
embedRenderMessage ''UniWorX ''CsvPreset id
|
|
embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
|
|
embedRenderMessage ''UniWorX ''FavouriteReason id
|
|
embedRenderMessage ''UniWorX ''Sex id
|
|
embedRenderMessage ''UniWorX ''ExamGradingMode id
|
|
|
|
embedRenderMessage ''UniWorX ''AuthenticationMode id
|
|
|
|
embedRenderMessage ''UniWorX ''RatingValidityException id
|
|
|
|
newtype ShortSex = ShortSex Sex
|
|
embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
|
|
|
|
newtype SheetTypeHeader = SheetTypeHeader SheetType
|
|
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
|
|
|
|
newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving newtype (Enum, Bounded, Universe, Finite)
|
|
embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel
|
|
|
|
instance RenderMessage UniWorX SheetType where
|
|
renderMessage foundation ls sheetType = case sheetType of
|
|
NotGraded -> mr $ SheetTypeHeader NotGraded
|
|
other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX StudyDegree where
|
|
renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
|
|
|
|
newtype ShortStudyDegree = ShortStudyDegree StudyDegree
|
|
|
|
instance RenderMessage UniWorX ShortStudyDegree where
|
|
renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
|
|
|
|
instance RenderMessage UniWorX StudyTerms where
|
|
renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
|
|
|
|
newtype ShortStudyTerms = ShortStudyTerms StudyTerms
|
|
|
|
instance RenderMessage UniWorX ShortStudyTerms where
|
|
renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand
|
|
|
|
data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms
|
|
|
|
instance RenderMessage UniWorX StudyDegreeTerm where
|
|
renderMessage foundation ls (StudyDegreeTerm deg trm) = mr trm <> " (" <> mr (ShortStudyDegree deg) <> ")"
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType
|
|
embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>)
|
|
|
|
data StudyDegreeTermType = StudyDegreeTermType StudyDegree StudyTerms StudyFieldType
|
|
|
|
instance RenderMessage UniWorX StudyDegreeTermType where
|
|
renderMessage foundation ls (StudyDegreeTermType deg trm typ) = mr trm <> " (" <> mr (ShortStudyDegree deg) <> ", " <> mr (ShortStudyFieldType typ) <> ")"
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX ExamGrade where
|
|
renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade
|
|
|
|
instance RenderMessage UniWorX ExamPassed where
|
|
renderMessage foundation ls = \case
|
|
ExamPassed True -> mr MsgExamPassed
|
|
ExamPassed False -> mr MsgExamNotPassed
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
|
|
renderMessage foundation ls = \case
|
|
ExamAttended{..} -> mr examResult
|
|
ExamNoShow -> mr MsgExamResultNoShow
|
|
ExamVoided -> mr MsgExamResultVoided
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where
|
|
renderMessage foundation ls = either mr mr
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX CourseParticipantState where
|
|
renderMessage foundation ls = \case
|
|
CourseParticipantActive -> mr MsgCourseParticipantActive
|
|
CourseParticipantInactive False -> mr MsgCourseParticipantInactive
|
|
CourseParticipantInactive True -> mr MsgCourseParticipantNoShow
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
-- ToMessage instances for converting raw numbers to Text (no internationalization)
|
|
|
|
instance ToMessage Int where
|
|
toMessage = tshow
|
|
instance ToMessage Int64 where
|
|
toMessage = tshow
|
|
instance ToMessage Integer where
|
|
toMessage = tshow
|
|
instance ToMessage Natural where
|
|
toMessage = tshow
|
|
|
|
instance HasResolution a => ToMessage (Fixed a) where
|
|
toMessage = toMessage . showFixed True
|
|
|
|
-- Do not use toMessage on Rationals and round them automatically. Instead, use rationalToFixed3 (declared in src/Utils.hs) to convert a Rational to Fixed E3!
|
|
-- instance ToMessage Rational where
|
|
-- toMessage = toMessage . fromRational'
|
|
-- where fromRational' = fromRational :: Rational -> Fixed E3
|
|
|
|
|
|
newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
|
|
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
|
|
|
|
newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
|
|
deriving stock (Generic, Typeable)
|
|
deriving newtype (Semigroup, Monoid)
|
|
|
|
instance IsList UniWorXMessages where
|
|
type Item UniWorXMessages = SomeMessage UniWorX
|
|
fromList = UniWorXMessages
|
|
toList (UniWorXMessages msgs) = msgs
|
|
|
|
instance RenderMessage UniWorX UniWorXMessages where
|
|
renderMessage foundation ls (UniWorXMessages msgs) =
|
|
Text.unwords $ map (renderMessage foundation ls) msgs
|
|
|
|
uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
|
|
uniworxMessages = UniWorXMessages . map SomeMessage
|
|
|
|
|
|
-- This instance is required to use forms. You can modify renderMessage to
|
|
-- achieve customized and internationalized form validation messages.
|
|
instance RenderMessage UniWorX FormMessage where
|
|
renderMessage _ ls | lang == "en" = englishFormMessage
|
|
| otherwise = germanFormMessage
|
|
where lang = selectLanguage' ("de" :| ["en"]) ls
|
|
|
|
instance RenderMessage UniWorX (ValueRequired UniWorX) where
|
|
renderMessage foundation ls (ValueRequired label')
|
|
| [w] <- Text.words label
|
|
, let w' = Text.strip w
|
|
, not $ Text.null w'
|
|
= mr $ MsgValueRequiredLabeledSimple w'
|
|
| Text.null $ Text.strip label
|
|
= mr MsgValueRequired
|
|
| otherwise
|
|
= mr . MsgValueRequiredLabeledMultiWord $ Text.strip label
|
|
where
|
|
label = mr label'
|
|
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderRoute UniWorX => RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
|
|
renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
|
|
where
|
|
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage f ls
|
|
(pieces, _) = renderRoute route
|
|
|
|
instance RenderMessage UniWorX WeekDay where
|
|
renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
|
|
|
|
newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }
|
|
|
|
instance RenderMessage UniWorX ShortWeekDay where
|
|
renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonSubmit id
|
|
|
|
|
|
unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
|
|
unRenderMessage' cmp foundation inp = nub $ do
|
|
l <- appLanguages'
|
|
x <- universeF
|
|
guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp
|
|
return x
|
|
where appLanguages' = toList appLanguages
|
|
|
|
unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
|
|
unRenderMessage = unRenderMessage' (==)
|
|
|
|
unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
|
|
unRenderMessageLenient = unRenderMessage' cmp
|
|
where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)
|
|
|
|
|
|
instance Default DateTimeFormatter where
|
|
def = mkDateTimeFormatter (getTimeLocale' []) def appTZ
|