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

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]
+pattern SomeMsgs :: [SomeMessage master] -> SomeMessages master
-  deriving newtype (Semigroup, Monoid)
+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]
+-- instance IsList UniWorXMessages where
-  deriving stock (Generic)
+--   type Item UniWorXMessages = SomeMessage UniWorX
-  deriving newtype (Semigroup, Monoid)
+--   fromList = UniWorXMessages
+--   toList (UniWorXMessages msgs) = msgs
 
-instance IsList UniWorXMessages where
+-- instance RenderMessage UniWorX UniWorXMessages where
-  type Item UniWorXMessages = SomeMessage UniWorX
+--   renderMessage foundation ls (UniWorXMessages msgs) =
-  fromList = UniWorXMessages
+--     Text.unwords $ map (renderMessage foundation ls) msgs -- Text.unwords uses blank for separation
-  toList (UniWorXMessages msgs) = msgs
 
-instance RenderMessage UniWorX UniWorXMessages where
+-- uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
-  renderMessage foundation ls (UniWorXMessages msgs) =
+-- uniworxMessages = UniWorXMessages . map SomeMessage
-    Text.concat $ map (renderMessage foundation ls) msgs -- Text.unwords for blank separation, Text.concat without
-
-uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
-uniworxMessages = UniWorXMessages . map SomeMessage
 
 
 -- This instance is required to use forms. You can modify renderMessage to

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

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

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

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

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

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) =>
+prependCourseTitle :: (RenderMessage master msg) =>
-  TermId -> SchoolId -> CourseShorthand -> msg -> UniWorXMessages
+  TermId -> SchoolId -> CourseShorthand -> msg -> SomeMessages master
-prependCourseTitle tid ssh csh msg = UniWorXMessages
+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]
 

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

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