522 lines
22 KiB
Haskell
522 lines
22 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Foundation.I18n
|
|
( appLanguages, appLanguagesOpts
|
|
, UniWorXMessage(..), UniWorXTestMessage(..), UniWorXSettingsMessage(..)
|
|
, UniWorXHelpMessage(..), UniWorXNavigationMessage(..), UniWorXWorkflowMessage(..)
|
|
, UniWorXCourseMessage(..), UniWorXAllocationMessage(..), 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(..)
|
|
, ShortTermIdentifier(..)
|
|
, MsgLanguage(..)
|
|
, ShortSex(..)
|
|
, ShortWeekDay(..)
|
|
, SheetType'(..), classifySheetType
|
|
, SheetArchiveFileTypeDirectory(..)
|
|
, ShortStudyDegree(..)
|
|
, ShortStudyTerms(..)
|
|
, StudyDegreeTerm(..)
|
|
, ShortStudyFieldType(..)
|
|
, StudyDegreeTermType(..)
|
|
, ErrorResponseTitle(..)
|
|
, WorkflowPayloadBool(..)
|
|
, 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 Utils.Workflow (RouteWorkflowScope)
|
|
|
|
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
|
|
|
|
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'
|
|
|
|
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 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 "Workflow" "messages/uniworx/categories/workflows" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Course" "messages/uniworx/categories/courses/courses" "de-de-formal"
|
|
mkMessageAddition ''UniWorX "Allocation" "messages/uniworx/categories/courses/allocation" "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 "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"
|
|
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"
|
|
|
|
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
|
|
|
|
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 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
|
|
|
|
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 ("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 ''WorkflowScope' $ ("WorkflowScopeKind" <>) . concat . drop 1 . splitCamel . fromMaybe (error "Expected WorkflowScope' to have '") . stripSuffix "'"
|
|
embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'"
|
|
|
|
embedRenderMessage ''UniWorX ''AuthenticationMode id
|
|
|
|
embedRenderMessage ''UniWorX ''RatingValidityException id
|
|
|
|
embedRenderMessage ''UniWorX ''UrlFieldMessage id
|
|
|
|
embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" <>)
|
|
|
|
newtype ShortSex = ShortSex Sex
|
|
embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
|
|
|
|
data SheetType'
|
|
= NotGraded' | Normal' | Bonus' | Informational' | ExamPartPoints'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
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, Typeable)
|
|
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 WorkflowPayloadBool = WorkflowPayloadBool { unWorkflowPayloadBool :: Bool }
|
|
embedRenderMessageVariant ''UniWorX ''WorkflowPayloadBool ("WorkflowPayloadBool" <>)
|
|
|
|
|
|
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
|
|
|
|
instance RenderMessage UniWorX RouteWorkflowScope where
|
|
renderMessage foundation ls = \case
|
|
WSGlobal -> mr MsgWorkflowScopeGlobal
|
|
WSTerm{..} -> mr . ShortTermIdentifier $ unTermKey wisTerm
|
|
WSSchool{..} -> mr $ unSchoolKey wisSchool
|
|
WSTermSchool{..} -> mr $ MsgWorkflowScopeTermSchool wisTerm wisSchool
|
|
WSCourse{ wisCourse = (tid, ssh, csh) } -> mr $ MsgWorkflowScopeCourse tid ssh csh
|
|
where
|
|
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
|
|
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 :: forall a master. (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
|