fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(i18n): make SomeMessages more flexible to distinguish it from UniWorXMessages, deprecated the latter

Browse Source
This commit is contained in:
Steffen Jost 2025-01-30 18:53:49 +01:00
parent 7c1df8a261
commit a76a23b9e2
9 changed files with 62 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
src/Foundation/I18n.hs
View File

@ -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

8
src/Handler/Firm.hs
View File

@ -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)
]

4
src/Handler/MailCenter.hs
View File

@ -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

2
src/Handler/Qualification.hs
View File

@ -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")

2
src/Handler/Qualification/Edit.hs
View File

@ -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 ()

2
src/Handler/Submission/Assign.hs
View File

@ -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

29
src/Handler/Utils.hs
View File

@ -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]

2
src/Handler/Utils/Form.hs
View File

@ -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

2
src/Handler/Utils/Table/Columns.hs
View File

@ -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]))