refactor(companies): mark table columns showing only prime company as such, fix #5

- also improve performance by changing dbtProj/selectList into a subselect - fix #5 no longer sensible, as most are single values to be displayed right away
2024-08-21 11:52:29 +02:00 · 2024-08-21 11:52:29 +02:00 · f61c35cfe7
commit f61c35cfe7
parent b0972bb154
4 changed files with 61 additions and 77 deletions
--- a/messages/uniworx/utils/table_column/de-de-formal.msg
+++ b/messages/uniworx/utils/table_column/de-de-formal.msg
@ -79,6 +79,7 @@ TableCompany: Firma
 TableCompanyFilter: Firma oder Nummer
 TableCompanyShort: Firmenkürzel
 TableCompanies: Firmen
+TablePrimeCompany: Primäre Firma
 TableCompanyNo: Firmennummer
 TableCompanyNos: Firmennummern
 TableCompanyUser: Firmenangehöriger
--- a/messages/uniworx/utils/table_column/en-eu.msg
+++ b/messages/uniworx/utils/table_column/en-eu.msg
@ -79,6 +79,7 @@ TableCompany: Company
 TableCompanyFilter: Company/Nr
 TableCompanyShort: Company shorthand
 TableCompanies: Companies
+TablePrimeCompany: Primary company
 TableCompanyNo: Company number
 TableCompanyNos: Company numbers
 TableCompanyUser: Associate
--- a/src/Handler/LMS.hs
+++ b/src/Handler/LMS.hs
@ -220,7 +220,6 @@ data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
  { ltcDisplayName    :: UserDisplayName
  , ltcEmail          :: UserEmail
  , ltcCompany        :: Maybe Text
-  , ltcCompanyNumbers :: CsvSemicolonList Int
  , ltcValidUntil     :: Day
  , ltcLastRefresh    :: Day
  , ltcFirstHeld      :: Day
@ -242,8 +241,7 @@ ltcExample :: LmsTableCsv
 ltcExample = LmsTableCsv
    { ltcDisplayName    = "Max Mustermann"
    , ltcEmail          = "m.mustermann@example.com"
-    , ltcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
-    , ltcCompanyNumbers = CsvSemicolonList [27,69]
+    , ltcCompany        = Just "Example Brothers LLC"
    , ltcValidUntil     = succ compDay
    , ltcLastRefresh    = compDay
    , ltcFirstHeld      = pred $ pred compDay
@ -285,8 +283,7 @@ instance CsvColumnsExplained LmsTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
    [ ('ltcDisplayName    , SomeMessage MsgLmsUser)
    , ('ltcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('ltcCompany        , SomeMessage MsgTableCompanies)
-    , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
+    , ('ltcCompany        , SomeMessage MsgTablePrimeCompany)
    , ('ltcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
    , ('ltcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
    , ('ltcFirstHeld      , SomeMessage MsgTableQualificationFirstHeld)
@ -320,7 +317,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc
 queryQualBlock = $(sqlLOJproj 2 2)


-type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)
+type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)

 resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
 resultQualUser = _dbrOutput . _1
@ -337,8 +334,8 @@ resultQualBlock = _dbrOutput . _4 . _Just
 resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
 resultPrintAck = _dbrOutput . _5 . _unValue . _Just

-resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
-resultCompanyUser = _dbrOutput . _6
+resultCompanyId :: Traversal' LmsTableData CompanyId
+resultCompanyId = _dbrOutput . _6 . _unValue . _Just

 resultValidQualification :: Lens' LmsTableData Bool
 resultValidQualification = _dbrOutput . _7 . _unValue
@ -406,6 +403,7 @@ lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
                , E.SqlExpr (Entity LmsUser)
                , E.SqlExpr (Maybe (Entity QualificationUserBlock))
                , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
+                , E.SqlExpr (E.Value (Maybe CompanyId))
                , E.SqlExpr (E.Value Bool)
                )
 lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
@ -421,12 +419,16 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
    E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification
    -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
    let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
-                    E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
-                        E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
-                    let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
-                    pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
-                           E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
-    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
+          E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
+              E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
+          let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
+          pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
+                  E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
+        primeComp = E.subSelect . E.from $ \uc -> do
+          E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
+          E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
+          return (uc E.^. UserCompanyCompany)
+    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser)


 mkLmsTable :: ( Functor h, ToSortable h
@ -435,25 +437,26 @@ mkLmsTable :: ( Functor h, ToSortable h
           => Bool
           -> Entity Qualification
           -> Map LmsTableAction (AForm Handler LmsTableActionData)
-           -> (Map CompanyId Company -> cols)
+           -> ((CompanyId -> CompanyName) -> cols)
           -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
           -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
 mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
  now <- liftIO getCurrentTime
  -- lookup all companies
-  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
+  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
    cmps <- selectList [] [] -- [Asc CompanyShorthand]
    return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
  let
+    getCompanyName :: CompanyId -> CompanyName
+    getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
+
    csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
    dbtIdent :: Text
    dbtIdent = "lms"
    dbtSQLQuery = lmsTableQuery now qid
    dbtRowKey = queryUser >>> (E.^. UserId)
-    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
-      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
-      return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
-    dbtColonnade = cols cmpMap
+    dbtProj = dbtProjId
+    dbtColonnade = cols getCompanyName
    dbtSorting = mconcat
      [ single $ sortUserNameLink   queryUser
      , single $ sortUserEmail      queryUser
@ -544,25 +547,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
        doEncode' = LmsTableCsv
          <$>  view    (resultUser     . _entityVal . _userDisplayName)
          <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*> (view     resultCompanyUser >>= getCompanies)
-          <*> (view     resultCompanyUser >>= getCompanyNos)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
+          <*>  preview (resultCompanyId . to getCompanyName . _CI)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserValidUntil)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserLastRefresh)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserFirstHeld)
          <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
          <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserIdent)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatus)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatusDay)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStarted)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserDatePin)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserReceived)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserEnded)
-        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
-          []        -> pure   Nothing
-          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserIdent)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStatus)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStatusDay)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStarted)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserDatePin)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserReceived)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserEnded)

    dbtCsvDecode = Nothing
    dbtExtraReps = []
@ -627,16 +625,12 @@ postLmsR sid qsh = do
              -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
              <*  aformMessage msgRestartWarning
          ]
-        colChoices cmpMap = mconcat
+        colChoices getCompanyName = mconcat
          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
          , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
          , colUserEmail
-          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
-              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
-                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
-                        ]
-              in intercalate spacerCell cs
+          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
+              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
          , colUserMatriclenr isAdmin
          -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@ -158,7 +158,6 @@ data QualificationTableCsv = QualificationTableCsv   -- Q..T..C.. -> qtc..
  { qtcDisplayName    :: UserDisplayName
  , qtcEmail          :: UserEmail
  , qtcCompany        :: Maybe Text
-  , qtcCompanyNumbers :: CsvSemicolonList Int
  , qtcValidUntil     :: Day
  , qtcLastRefresh    :: Day
  , qtcBlockStatus    :: Maybe Bool
@ -174,8 +173,7 @@ qtcExample :: QualificationTableCsv
 qtcExample = QualificationTableCsv
    { qtcDisplayName    = "Max Mustermann"
    , qtcEmail          = "m.mustermann@example.com"
-    , qtcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
-    , qtcCompanyNumbers = CsvSemicolonList [27,69]
+    , qtcCompany        = Just "Example Brothers LLC"
    , qtcValidUntil     = compDay
    , qtcLastRefresh    = compDay
    , qtcBlockStatus    = Nothing
@ -209,8 +207,7 @@ instance CsvColumnsExplained QualificationTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
    [ ('qtcDisplayName    , SomeMessage MsgLmsUser)
    , ('qtcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('qtcCompany        , SomeMessage MsgTableCompanies)
-    , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
+    , ('qtcCompany        , SomeMessage MsgTablePrimeCompany)
    , ('qtcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
    , ('qtcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
    , ('qtcBlockStatus    , SomeMessage MsgInfoQualificationBlockStatus)
@ -238,7 +235,7 @@ queryLmsUser = $(sqlLOJproj 3 2)
 queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
 queryQualBlock = $(sqlLOJproj 3 3)

-type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
+type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), E.Value (Maybe CompanyId))

 resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
 resultQualUser = _dbrOutput . _1
@ -252,8 +249,8 @@ resultLmsUser = _dbrOutput . _3 . _Just
 resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
 resultQualBlock = _dbrOutput . _4 . _Just

-resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
-resultCompanyUser = _dbrOutput . _5
+resultCompanyId :: Traversal' QualificationTableData CompanyId
+resultCompanyId = _dbrOutput . _5 . _unValue . _Just


 instance HasEntity QualificationTableData User where
@ -340,6 +337,7 @@ qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Valu
                , E.SqlExpr (Entity User)
                , E.SqlExpr (Maybe (Entity LmsUser))
                , E.SqlExpr (Maybe (Entity QualificationUserBlock))
+                , E.SqlExpr (E.Value (Maybe CompanyId))
                )
 qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
  -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
@ -351,7 +349,11 @@ qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJo
    E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
    E.where_ $    fltr qualUser
            E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
-    return (qualUser, user, lmsUser, qualBlock)
+    let primeComp = E.subSelect . E.from $ \uc -> do
+          E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
+          E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
+          return (uc E.^. UserCompanyCompany)
+    return (qualUser, user, lmsUser, qualBlock, primeComp)


 mkQualificationTable ::
@ -361,17 +363,19 @@ mkQualificationTable ::
           => Bool
           -> Entity Qualification
           -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-           -> (Map CompanyId Company -> cols)
+           -> ((CompanyId -> CompanyName) -> cols)
           -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
           -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
 mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
  svs <- getSupervisees
  now <- liftIO getCurrentTime
  -- lookup all companies
-  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
+  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
    cmps <- selectList [] [] -- [Asc CompanyShorthand]
    return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
  let
+    getCompanyName :: CompanyId -> CompanyName
+    getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
    nowaday = utctDay now
    mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
    csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
@ -380,15 +384,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
    fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
    dbtSQLQuery = qualificationTableQuery now qid fltrSvs
    dbtRowKey = queryUser >>> (E.^. UserId)
-    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
-      -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
-      --   E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
-      --   E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
-      --   E.orderBy [E.asc (comp E.^. CompanyName)]
-      --   return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
-      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
-      return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
-    dbtColonnade = cols cmpMap
+    dbtProj = dbtProjId
+    dbtColonnade = cols getCompanyName
    dbtSorting = mconcat
      [ single $ sortUserNameLink   queryUser
      , single $ sortUserEmail      queryUser
@ -471,8 +468,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
        doEncode' = QualificationTableCsv
          <$>  view    (resultUser     . _entityVal . _userDisplayName)
          <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*> (view     resultCompanyUser >>= getCompanies)
-          <*> (view     resultCompanyUser >>= getCompanyNos)
+          <*>  preview (resultCompanyId . to getCompanyName . _CI)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
          <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
@ -480,10 +476,6 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
          <*>  view    (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
          <*>  getStatusPlusTxt
          <*>  getStatusPlusDay
-        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
-          []        -> pure   Nothing
-          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))

        getStatusPlusTxt =
          (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus)) >>= \case
@ -585,16 +577,12 @@ postQualificationR sid qsh = do
          ] isAdmin
        linkLmsUser     = toMaybe isAdmin (LmsUserR sid qsh)
        linkUserName    = bool ForProfileR ForProfileDataR isAdmin
-        colChoices cmpMap = mconcat
+        colChoices getCompanyName = mconcat
          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , colUserNameModalHdr MsgLmsUser linkUserName
          , colUserEmail
-          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
-              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
-                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
-                        ]
-              in intercalate spacerCell cs
+          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
+              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
          , guardMonoid isAdmin $ colUserMatriclenr isAdmin
          -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $    \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d