fix(form): multiSelectField working with grouped options

messages/uniworx/utils/utils/de-de-formal.msg

@@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Anweisungen
 RoomReferenceLinkInstructionsPlaceholder: Anweisungen
 UtilEmptyChoice: Auswahl war leer
 UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
+MultiNoSelection: Keine Auswahl
 
 #invitation.hs
 InvitationAction: Aktion

messages/uniworx/utils/utils/en-eu.msg

@@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Instructions
 RoomReferenceLinkInstructionsPlaceholder: Instructions
 UtilEmptyChoice: Empty selection
 UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
+MultiNoSelection: No selection
 
 #invitation.hs
 InvitationAction: Action

src/Handler/Firm.hs

@@ -94,7 +94,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
                   <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
     mkAct _     FirmActAddSupersvisors   = singletonMap FirmActAddSupersvisors   $ FirmActAddSupersvisorsData
                   <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
-                  <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute )                                                            (Just True)
+                  <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute)                                                             (Just True)
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
     mkAct _     FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
@@ -704,10 +704,9 @@ mkFirmUserTable isAdmin cid = do
     return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
   let
     -- supervisorField :: Field Handler UserId
-    supervisorField  =      selectField $ procOptions rawSupers
+    -- supervisorField  =      selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
-    -- TODO: Markieren Alien/Standard/Irregulär
+    supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
-    -- supervisorsField = multiSelectField $ procOptions rawSupers
+    
-    -- supervisorsField = convertField pure head supervisorField
 
     fsh = unCompanyKey cid
     resultDBTable = DBTable{..}
@@ -796,8 +795,8 @@ mkFirmUserTable isAdmin cid = do
         -- superField = selectField $ ????
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
-          , prismAForm (singletonFilter "supervisor-is"          . maybePrism _PathPiece)     mPrev $ aopt (hoistField lift supervisorField)  (fslI MsgFilterSupervisor)
+          -- , prismAForm (singletonFilter "supervisor-is"          . maybePrism _PathPiece)     mPrev $ aopt (hoistField lift supervisorField)  (fslI MsgFilterSupervisor)
-          -- , prismAForm (multiFilter     "supervisors-are"        . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip )
+          , prismAForm (multiFilter     "supervisors-are"        . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip)
           , prismAForm (singletonFilter "has-supervisor"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
           , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
           , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh)
@@ -810,10 +809,10 @@ mkFirmUserTable isAdmin cid = do
               <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)         (Just $ Just False)
               -- <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
           , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
-              <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
+              <$> aopt (textField & cfAnySeparatedSet)                    (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
-              <*> fmap (fmap pure) (aopt supervisorField (fslI MsgFirmSetSupervisor) Nothing)
+              <*> aopt supervisorsField                                   (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip)                          Nothing
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
+              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
+              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
           , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
               <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
           , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData

src/Utils/Form.hs

@@ -950,6 +950,54 @@ selectField' optMsg mkOpts = Field{..}
                       #{optionDisplay opt}
       |]
 
+multiSelectField' :: ( Eq a
+                , RenderMessage (HandlerSite m) FormMessage
+                , MonadHandler m
+                )
+             => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
+             -> HandlerT (HandlerSite m) IO (OptionList a)
+             -> Field m [a]
+-- ^ Like @multiSelectField@, but it can handle OptionListGrouped and also offers more control over the @Nothing@-Option, if Field is optional
+multiSelectField' optMsg mkOpts = Field{..}
+  where
+    fieldEnctype = UrlEncoded
+
+    fieldParse []      _ = return $ Right Nothing
+    fieldParse optlist _ = do
+      let optlist' = filter notNull optlist
+      readExternal <- view _olReadExternal <$> liftHandler mkOpts
+      return . maybe (Left . SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist') (Right . Just) $ mapM readExternal optlist'
+      -- case mapM readExternal optlist' of
+      --   Nothing -> return $ Left $ SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist'
+      --   res     -> return $ Right res      
+
+    fieldView theId name attrs val isReq = do
+      opts <- liftHandler mkOpts
+      let
+        rendered = case val of
+          Left  _  -> []
+          Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]            
+        isSel Nothing    = ClassyPrelude.Yesod.null rendered
+        isSel (Just opt) = optionExternalValue opt `elem` rendered
+      [whamlet|
+        $newline never
+        <select ##{theId} name=#{name} multiple *{attrs} :isReq:required>
+          $maybe optMsg' <- assertM (const $ not isReq) optMsg
+            <option value="" :isSel Nothing:selected>
+              _{optMsg'}
+          $case opts
+            $of OptionList{olOptions}
+              $forall opt <- olOptions
+                <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
+                  #{optionDisplay opt}
+            $of OptionListGrouped{olOptionsGrouped}
+              $forall (groupLbl, iOpts) <- olOptionsGrouped
+                <optgroup label=#{groupLbl}>
+                  $forall opt <- iOpts
+                    <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
+                      #{optionDisplay opt}
+      |]
+
 radioField' :: ( Eq a
                , RenderMessage (HandlerSite m) FormMessage
                , MonadHandler m