From a76a23b9e21ede9dac292bb6bf7d1e02ad32bc2f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 30 Jan 2025 18:53:49 +0100 Subject: [PATCH] refactor(i18n): make SomeMessages more flexible to distinguish it from UniWorXMessages, deprecated the latter --- src/Foundation/I18n.hs | 58 +++++++++++++++++++----------- src/Handler/Firm.hs | 8 ++--- src/Handler/MailCenter.hs | 4 +-- src/Handler/Qualification.hs | 2 +- src/Handler/Qualification/Edit.hs | 2 +- src/Handler/Submission/Assign.hs | 2 +- src/Handler/Utils.hs | 29 ++++++++------- src/Handler/Utils/Form.hs | 2 +- src/Handler/Utils/Table/Columns.hs | 2 +- 9 files changed, 62 insertions(+), 47 deletions(-) diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index ea8672d29..7526d3a76 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -40,10 +40,9 @@ module Foundation.I18n , ShortStudyFieldType(..) , StudyDegreeTermType(..) , ErrorResponseTitle(..) - , UniWorXMessages(..) - , uniworxMessages + -- , UniWorXMessages(..), uniworxMessages , unRenderMessage, unRenderMessage', unRenderMessageLenient - , SomeMessages(..) + , SomeMessages(..), pattern SomeMsgs, pattern SpaceMsgs, pattern JoinMsgs , someMessages , module Foundation.I18n.TH ) where @@ -62,7 +61,7 @@ import qualified Data.Text as Text import Utils.Form -import qualified GHC.Exts (IsList(..)) +-- import qualified GHC.Exts (IsList(..)) -- for UniWorXMessages import Yesod.Form.I18n.German import Yesod.Form.I18n.English @@ -280,16 +279,31 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) +-- | Flexible variant of `UniWorXMessages` allowing custom separation +data SomeMessages master = SomeMessages Text [SomeMessage master] -newtype SomeMessages master = SomeMessages [SomeMessage master] - deriving newtype (Semigroup, Monoid) +pattern SomeMsgs :: [SomeMessage master] -> SomeMessages master +pattern SomeMsgs msgs = SomeMessages "\n " msgs + +pattern SpaceMsgs :: [SomeMessage master] -> SomeMessages master +pattern SpaceMsgs msgs = SomeMessages " " msgs + +pattern JoinMsgs :: [SomeMessage master] -> SomeMessages master +pattern JoinMsgs msgs = SomeMessages "" msgs + +-- Not yet needed: +-- instance Semigroup (SomeMessage master) where +-- (SomeMessages s1 t1) <> (SomeMessages _s2 t2) = SomeMessages s1 $ t1 ++ t2 + +-- instance Monoid (SomeMessage master) where +-- mempty = SomeMessages mempty mempty instance master ~ master' => RenderMessage master (SomeMessages master') where - renderMessage a b (SomeMessages msgs) = Text.intercalate "\n " $ renderMessage a b <$> msgs + renderMessage a b (SomeMessages sep msgs) = Text.intercalate sep $ renderMessage a b <$> msgs -- | convenienience function if all messages happen to belong to the exact same type someMessages :: RenderMessage master msg => [msg] -> SomeMessages master -someMessages msgs = SomeMessages $ SomeMessage <$> msgs +someMessages msgs = SomeMessages "\n " $ SomeMessage <$> msgs instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite @@ -537,22 +551,24 @@ instance HasResolution a => ToMessage (Fixed a) where newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) +-- -- A list of messages is a message by itself. Uses blank for separation. +-- -- Deprecated for now; replaced by the more flexibles SomeMessages. Easy to reinstate. +-- -- +-- newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX] +-- deriving stock (Generic) +-- deriving newtype (Semigroup, Monoid) -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 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 -- Text.unwords uses blank for separation -instance RenderMessage UniWorX UniWorXMessages where - renderMessage foundation ls (UniWorXMessages msgs) = - Text.concat $ map (renderMessage foundation ls) msgs -- Text.unwords for blank separation, Text.concat without - -uniworxMessages :: [UniWorXMessage] -> UniWorXMessages -uniworxMessages = UniWorXMessages . map SomeMessage +-- uniworxMessages :: [UniWorXMessage] -> UniWorXMessages +-- uniworxMessages = UniWorXMessages . map SomeMessage -- This instance is required to use forms. You can modify renderMessage to diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index ad44d1257..6bcecfa63 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -114,12 +114,12 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> aopt (textField & cfStrip & addDatalist ucdefAssocReasons) (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMsgs [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMsgs [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ _ = mempty @@ -1036,12 +1036,12 @@ mkFirmUserTable isAdmin cid = do , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMsgs [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData <$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing - <*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing + <*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMsgs [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing , singletonMap FirmUserActRemove $ FirmUserActRemoveData <$> areq boolField' (fslI MsgFirmActRemoveSupers) (Just True) ] diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 26ad06075..219445226 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -180,10 +180,10 @@ getMailAttachmentR cusm attdisp = do _ -> notFound getMailHtmlR :: CryptoUUIDSentMail -> Handler Html -getMailHtmlR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain] +getMailHtmlR = handleMailShow (SomeMsgs [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain] getMailPlainR :: CryptoUUIDSentMail -> Handler Html -getMailPlainR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml] +getMailPlainR = handleMailShow (SomeMsgs [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml] handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html handleMailShow hdr prefTypes cusm = do diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 7e2bb2724..68c161f93 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -44,7 +44,7 @@ getQualificationSchoolR :: SchoolId -> Handler Html -- getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) getQualificationSchoolR ssh = do qualiTable <- runDB $ view _2 <$> mkQualificationAllTable (Just ssh) - let heading = SomeMessages [SomeMessage MsgMenuQualifications, SomeMessage $ unSchoolKey ssh] + let heading = SomeMessages " " [SomeMessage MsgMenuQualifications, SomeMessage $ unSchoolKey ssh] siteLayoutMsg heading $ do setTitleI heading $(widgetFile "qualification-all") diff --git a/src/Handler/Qualification/Edit.hs b/src/Handler/Qualification/Edit.hs index f90c2cb43..487b0b9d1 100644 --- a/src/Handler/Qualification/Edit.hs +++ b/src/Handler/Qualification/Edit.hs @@ -60,7 +60,7 @@ mkQualificationForm ssh templ = identifyForm FIDQualificationEdit . validateForm avsLicenceField :: Field Handler AvsLicence avsLicenceField = selectFieldList [ (Text.singleton $ licence2char lic, lic) | lic <- universeF, lic /= AvsNoLicence ] - aopt_natFieldI msg = aopt (natFieldI $ UniWorXMessages [SomeMessage msg, text2message " ", SomeMessage MsgMustBePositive]) (fslI msg) + aopt_natFieldI msg = aopt (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg) -- [ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15] reorderedQualification = $(permuteFun [ 1, 2, 3, 4, 5,10, 6, 8, 7,11,12,13, 9,14,15]) Qualification -- == inversePermutation [1,2,3,4,5,7,9,8,13,6,10,11,12,14,15] validateQualificationEdit :: SchoolId -> FormValidator Qualification Handler () diff --git a/src/Handler/Submission/Assign.hs b/src/Handler/Submission/Assign.hs index 2a32f0c6d..a82f002b1 100644 --- a/src/Handler/Submission/Assign.hs +++ b/src/Handler/Submission/Assign.hs @@ -131,7 +131,7 @@ assignHandler tid ssh csh cid assignSids = do msg_status = bool Success Error $ nr_fail > 0 msg_header = SomeMessage $ shn <> ": " if | nr_ok > 0 || nr_fail > 0 -> do - addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail] + addMessageI msg_status $ SomeMessages " " $ msg_header : catMaybes [alert_ok, alert_fail] return $ Just status | otherwise -> do addMessageI Error $ MsgSheetsUnassignable $ CI.original shn diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index c4b6953ad..029762ee4 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -44,13 +44,12 @@ import Control.Monad.Logger checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool checkAdmin = liftHandler $ hasReadAccessTo AdminR - -- | Prefix a message with a short course id, -- eg. for window title bars, etc. -- This function should help to make this consistent everywhere -prependCourseTitle :: (RenderMessage UniWorX msg) => - TermId -> SchoolId -> CourseShorthand -> msg -> UniWorXMessages -prependCourseTitle tid ssh csh msg = UniWorXMessages +prependCourseTitle :: (RenderMessage master msg) => + TermId -> SchoolId -> CourseShorthand -> msg -> SomeMessages master +prependCourseTitle tid ssh csh msg = JoinMsgs [ SomeMessage $ toPathPiece tid , SomeMessage dashText , SomeMessage $ toPathPiece ssh @@ -196,14 +195,14 @@ adminProblem2Text adprob = do AdminProblemNewCompany{} -> return $ mr MsgAdminProblemNewCompany AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew} - -> return $ mr $ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew] + -> return $ mr $ SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew] AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} -> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid} -> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do uid <- MaybeT $ pure mbuid User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid - pure $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] + pure $ mr $ SomeMsgs [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing} -- -> return $ mr MsgAdminProblemCompanySuperiorChange -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid} @@ -211,32 +210,32 @@ adminProblem2Text adprob = do -- Nothing -> -- return $ mr MsgAdminProblemCompanySuperiorChange -- Just User{userDisplayName = udn, userSurname = usn} -> - -- return $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] + -- return $ mr $ SomeMsgs [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] AdminProblemCompanySuperiorNotFound{adminProblemUserOld=mbuid, adminProblemEmail=eml} -> let basemsg = MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml in maybeT (return $ mr basemsg) $ do uid <- MaybeT $ pure mbuid User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid - pure $ mr $ SomeMessages [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] + pure $ mr $ SomeMsgs [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] AdminProblemNewlyUnsupervised{adminProblemCompanyNew} - -> return $ mr $ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew] + -> return $ mr $ SomeMsgs [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew] AdminProblemUnknown{adminProblemText} -> return $ "Problem: " <> adminProblemText -- | Show AdminProblem as message, used in message pop-up after manually switching companies for a user msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ - SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] + SomeMsgs [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $ - SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp] + SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp] msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $ - SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp] + SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp] msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $ - SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp] + SomeMsgs [SomeMessage MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp] msgAdminProblem AdminProblemCompanySuperiorNotFound{adminProblemCompany=comp, adminProblemEmail=eml} = return $ - SomeMessages [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp] + SomeMsgs [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp] msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ - SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] + SomeMsgs [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $ someMessages ["Problem: ", err] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index a21eb208b..68a44dfe0 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1923,7 +1923,7 @@ userFieldAux viewUid wrapUid mergeRes onlySuggested suggestions = Field{..} ) E.limit 2 -- we need a single unique answer only, so no need to ask for more return $ user E.^. UserId - let errMsg m = SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, text2message t, m] + let errMsg m = SomeMessage $ SomeMsgs [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, text2message t, m] case dbRes of [uid] -> wrapUid $ Right $ E.unValue uid [] -> throwE $ errMsg $ SomeMessage $ bool MsgUnknown MsgUnknownOrNotAllowed onlySuggested diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 89ebeec61..fb2be7bbf 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -855,7 +855,7 @@ fltrAVSCardNos queryUser = ("avs-card", fch) fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrAVSCardNosUI mPrev = prismAForm (singletonFilter "avs-card" ) mPrev $ - aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded])) + aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMsgs [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))