595 lines
25 KiB
Haskell
595 lines
25 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
-- To add new language files:
|
|
-- 1. include new statement, e.g. mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal"
|
|
-- 2. create appropriate translation files in the specified folder
|
|
-- 3. add constructor to list of module exports
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Foundation.I18n
|
|
( appLanguages, appLanguagesOpts
|
|
, UniWorXMessage(..), UniWorXTestMessage(..), UniWorXSettingsMessage(..)
|
|
, UniWorXHelpMessage(..), UniWorXNavigationMessage(..)
|
|
, UniWorXCourseMessage(..), UniWorXExamMessage(..)
|
|
, UniWorXSheetMessage(..), UniWorXAdminMessage(..), UniWorXSubmissionMessage(..)
|
|
, UniWorXTutorialMessage(..), UniWorXUserMessage(..), UniWorXButtonMessage(..)
|
|
, UniWorXFormMessage(..), UniWorXRatingMessage(..), UniWorXTableColumnMessage(..)
|
|
, UniWorXTablePaginationMessage(..),UniWorXUtilMessage(..), UniWorXAuthorizationMessage(..)
|
|
, UniWorXMaterialMessage(..), UniWorXParticipantsMessage(..), UniWorXHealthMessage(..), UniWorXInfoMessage(..)
|
|
, UniWorXMetricsMessage(..), UniWorXNewsMessage(..), UniWorXSchoolMessage(..), UniWorXSystemMessageMessage(..)
|
|
, UniWorXTermMessage(..), UniWorXSendMessage(..), UniWorXSiteLayoutMessage(..), UniWorXErrorMessage(..)
|
|
, UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..)
|
|
, UniWorXQualificationMessage(..)
|
|
, UniWorXPrintMessage(..)
|
|
, UniWorXFirmMessage(..)
|
|
, UniWorXAvsMessage(..)
|
|
, UniWorXAuthorshipStatementMessage(..)
|
|
, ShortTermIdentifier(..)
|
|
, MsgLanguage(..)
|
|
, ShortSex(..)
|
|
, ShortWeekDay(..)
|
|
, SheetType'(..), classifySheetType
|
|
, SheetArchiveFileTypeDirectory(..)
|
|
, ShortStudyDegree(..)
|
|
, ShortStudyTerms(..)
|
|
, StudyDegreeTerm(..)
|
|
, ShortStudyFieldType(..)
|
|
, StudyDegreeTermType(..)
|
|
, ErrorResponseTitle(..)
|
|
, UniWorXMessages(..)
|
|
, uniworxMessages
|
|
, unRenderMessage, unRenderMessage', unRenderMessageLenient
|
|
, module Foundation.I18n.TH
|
|
) 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 ((!!))
|
|
|
|
-- import qualified Data.Scientific as Scientific
|
|
|
|
import Foundation.I18n.TH
|
|
|
|
|
|
pluralDE :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ Singular
|
|
-> Text -- ^ Plural
|
|
-> Text
|
|
pluralDE num singularForm pluralForm
|
|
| num == 1 = singularForm
|
|
| otherwise = pluralForm
|
|
|
|
-- pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
|
|
-- -- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
|
|
-- pluralDEx c n t = pluralDE n t $ t `snoc` c
|
|
|
|
-- -- | like `pluralDEe` but also prefixes with the number
|
|
-- pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
|
|
-- pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
|
|
|
|
pluralDEe :: (Eq a, Num a) => a -> Text -> Text
|
|
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
|
|
pluralDEe n t = pluralDE n t $ t `snoc` 'e'
|
|
|
|
-- | like `pluralDEe` but also prefixes with the number
|
|
pluralDEeN :: (Eq a, Num a, Show a) => a -> Text -> Text
|
|
pluralDEeN n t = tshow n <> cons ' ' (pluralDEe n t)
|
|
|
|
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
|
|
|
|
pluralENs :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ Singular
|
|
-> Text
|
|
-- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@
|
|
pluralENs n t = pluralEN n t $ t `snoc` 's'
|
|
|
|
-- | like `pluralENs` but also prefixes with the number
|
|
pluralENsN :: (Eq a, Num a, Show a) => a -> Text -> Text
|
|
pluralENsN n t = tshow n <> cons ' ' (pluralENs n t)
|
|
|
|
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
|
|
|
|
notDE :: Bool -> Text
|
|
notDE = bool "nicht" ""
|
|
|
|
notEN :: Bool -> Text
|
|
notEN = bool "not" ""
|
|
|
|
{- -- TODO: use this is message eventually
|
|
-- Commonly used plurals
|
|
data Thing = Person | Examinee
|
|
deriving (Eq)
|
|
|
|
thingDE :: Int -> Thing -> Text
|
|
thingDE num = (tshow num <>) . Text.cons ' ' . thing
|
|
where
|
|
thing :: Thing -> Text
|
|
thing Person = pluralDE num "Person" "Personen"
|
|
thing Examinee = pluralDE num "Prüfling" "Prüflinge"
|
|
|
|
thingEN :: Int -> Thing -> Text
|
|
thingEN num t = tshow num <> Text.cons ' ' (thing t)
|
|
where
|
|
thing :: Thing -> Text
|
|
thing Person = pluralENs num "person"
|
|
thing Examinee = pluralENs num "examinee"
|
|
-}
|
|
|
|
-- | 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
|
|
|
|
|
|
newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
|
|
deriving stock (Eq, Ord, Read, Show)
|
|
|
|
|
|
|
|
-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
|
|
mkMessage ''UniWorX "messages/uniworx/misc" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Test" "messages/uniworx/test" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Settings" "messages/uniworx/categories/settings" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Help" "messages/uniworx/categories/help" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Navigation" "messages/uniworx/utils/navigation" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Course" "messages/uniworx/categories/courses/courses" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Exam" "messages/uniworx/categories/courses/exam" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Sheet" "messages/uniworx/categories/courses/sheet" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Admin" "messages/uniworx/categories/admin" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Submission" "messages/uniworx/categories/courses/submission" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Tutorial" "messages/uniworx/categories/courses/tutorial" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Material" "messages/uniworx/categories/courses/material" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Authorization" "messages/uniworx/categories/authorization" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Health" "messages/uniworx/categories/health" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Info" "messages/uniworx/categories/info" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Metrics" "messages/uniworx/categories/metrics" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "News" "messages/uniworx/categories/news" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "School" "messages/uniworx/categories/school" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "SystemMessage" "messages/uniworx/categories/system_message" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Participants" "messages/uniworx/categories/courses/participants" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Term" "messages/uniworx/categories/term" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Error" "messages/uniworx/categories/error" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "I18n" "messages/uniworx/categories/I18n" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "JobsHandler" "messages/uniworx/categories/jobs_handler" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "ModelTypes" "messages/uniworx/categories/model_types" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Firm" "messages/uniworx/categories/firm" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "TablePagination" "messages/uniworx/utils/table_pagination" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Util" "messages/uniworx/utils/utils" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Rating" "messages/uniworx/utils/rating" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "SiteLayout" "messages/uniworx/utils/site_layout" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "AuthorshipStatement" "messages/uniworx/utils/authorship_statement" "de-de-formal"
|
|
mkMessageVariant ''UniWorX ''CampusMessage "messages/auth/campus" "de"
|
|
mkMessageVariant ''UniWorX ''DummyMessage "messages/auth/dummy" "de"
|
|
mkMessageVariant ''UniWorX ''PWHashMessage "messages/auth/pw-hash" "de"
|
|
mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de"
|
|
mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal"
|
|
|
|
embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages
|
|
|
|
mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal"
|
|
|
|
embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
|
|
|
|
instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite
|
|
renderMessage f ls (Just s) = renderMessage f ls s
|
|
renderMessage f ls Nothing = renderMessage f ls MsgLmsStateOpen
|
|
|
|
instance RenderMessage UniWorX AvsDataCardColor where
|
|
renderMessage _foundation _ls (AvsCardColorMisc t) = Text.cons '*' t
|
|
renderMessage f ls AvsCardColorGrün = renderMessage f ls MsgAvsCardColorGreen
|
|
renderMessage f ls AvsCardColorBlau = renderMessage f ls MsgAvsCardColorBlue
|
|
renderMessage f ls AvsCardColorRot = renderMessage f ls MsgAvsCardColorRed
|
|
renderMessage f ls AvsCardColorGelb = renderMessage f ls MsgAvsCardColorYellow
|
|
|
|
instance RenderMessage UniWorX TermIdentifier where
|
|
renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format
|
|
|
|
instance RenderMessage UniWorX ShortTermIdentifier where
|
|
renderMessage _foundation _ls (ShortTermIdentifier tid) = termToText tid -- TODO: implement shorttermidentifier properly
|
|
|
|
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 RenderMessage UniWorX Word64 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
|
|
|
|
data MsgLanguage = MsgLanguage { unMsgLanguage :: Lang } | MsgLanguageEndonym { unMsgLanguage :: Lang }
|
|
deriving stock (Eq, Ord, Show, Read)
|
|
instance RenderMessage UniWorX MsgLanguage where
|
|
renderMessage foundation ls msg@(unMsgLanguage -> 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 $ case msg of
|
|
MsgLanguageEndonym _ -> lang : filter (/= lang) ls
|
|
MsgLanguage _ -> 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 ''HealthCheck id
|
|
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 ("Sheet" <>)
|
|
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 ''SystemFunction id
|
|
embedRenderMessage ''UniWorX ''CsvPreset id
|
|
embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
|
|
embedRenderMessage ''UniWorX ''CsvFormat ("Csv" <>)
|
|
embedRenderMessage ''UniWorX ''FavouriteReason id
|
|
embedRenderMessage ''UniWorX ''Sex id
|
|
embedRenderMessage ''UniWorX ''ExamGradingMode id
|
|
embedRenderMessage ''UniWorX ''ExamAidsPreset id
|
|
embedRenderMessage ''UniWorX ''ExamOnlinePreset id
|
|
embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id
|
|
embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
|
|
embedRenderMessage ''UniWorX ''ChangelogItemKind id
|
|
embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'"
|
|
|
|
embedRenderMessage ''UniWorX ''AuthenticationMode id
|
|
|
|
embedRenderMessage ''UniWorX ''RatingValidityException id
|
|
|
|
embedRenderMessage ''UniWorX ''UrlFieldMessage id
|
|
|
|
embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" <>)
|
|
|
|
embedRenderMessage ''UniWorX ''SchoolAuthorshipStatementMode id
|
|
embedRenderMessage ''UniWorX ''SheetAuthorshipStatementMode id
|
|
|
|
embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel
|
|
|
|
newtype ShortSex = ShortSex Sex
|
|
embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
|
|
|
|
data SheetType'
|
|
= NotGraded' | Normal' | Bonus' | Informational' | ExamPartPoints'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving (Universe, Finite)
|
|
|
|
classifySheetType :: SheetType a -> SheetType'
|
|
classifySheetType = \case
|
|
NotGraded -> NotGraded'
|
|
Normal{} -> Normal'
|
|
Bonus{} -> Bonus'
|
|
Informational{} -> Informational'
|
|
ExamPartPoints{} -> ExamPartPoints'
|
|
|
|
nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
|
|
embedRenderMessage ''UniWorX ''SheetType' $ ("SheetType" <>) . fromMaybe (error "Expected SheetType' to have '") . stripSuffix "'"
|
|
|
|
newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriving newtype (Enum, Bounded, Universe, Finite)
|
|
embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel
|
|
|
|
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
|
|
|
|
instance RenderMessage UniWorX ExamCloseMode where
|
|
renderMessage foundation ls = \case
|
|
ExamCloseSeparate -> mr MsgExamCloseModeSeparate
|
|
ExamCloseOnFinished False -> mr MsgExamCloseModeOnFinished
|
|
ExamCloseOnFinished True -> mr MsgExamCloseModeOnFinishedHidden
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
-- ToMessage instances for converting raw numbers to Text (no internationalization)
|
|
-- FIXME: Use RenderMessage always
|
|
|
|
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 ToMessage Word64 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)
|
|
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
|
|
|
|
instance RenderMessage UniWorX VolatileClusterSettingsKey where
|
|
renderMessage foundation ls = \case
|
|
ClusterVolatileQuickActionsEnabled -> mr MsgClusterVolatileQuickActionsEnabled
|
|
where
|
|
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
unRenderMessage' :: (Ord a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
|
|
unRenderMessage' cmp foundation inp = nubOrd $ do
|
|
l <- appLanguages'
|
|
x <- universeF
|
|
guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp
|
|
return x
|
|
where appLanguages' = toList appLanguages
|
|
|
|
unRenderMessage :: (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a]
|
|
unRenderMessage = unRenderMessage' (==)
|
|
|
|
unRenderMessageLenient :: forall a master. (Ord 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
|
|
|
|
instance RenderMessage UniWorX Address where
|
|
renderMessage s l a@Address{addressName = Just aname} = aname <> cons ' ' (renderMessage s l a{addressName=Nothing})
|
|
renderMessage _ _ Address{addressEmail = mail} = "<" <> mail <> ">"
|