Custom styling for massInput

src/Handler/Admin.hs

@@ -205,7 +205,7 @@ postAdminTestR = do
 
   -- The actual call to @massInput@ is comparatively simple:
 
-  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing
+  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction defaultMiLayout) "" True Nothing
 
 
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]

src/Handler/Course.hs

@@ -27,6 +27,7 @@ import Data.Monoid (Last(..))
 
 import Data.Maybe (fromJust)
 import qualified Data.Set as Set
+import Data.Map ((!))
 import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
@@ -637,34 +638,18 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
                         | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
                 FormFailure errs -> FormFailure errs
                 FormMissing -> FormMissing
-              addView'  = toWidget csrf >> fvInput addView >> fvInput btn
+              addView' = $(widgetFile "course/lecturerMassInput/add")
           return (addRes'', addView')
 
         miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
         miCell _ (Right lid) defType nudge = \csrf -> do
           (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
           User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
-          let lrwView' = [whamlet|$newline never
+          let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
-                  #{csrf}
-                  ^{nameEmailWidget userEmail userDisplayName userSurname} #
-                  ^{fvInput lrwView}
-                |]
           return (Just <$> lrwRes,lrwView')
         miCell _ (Left lEmail) defType nudge = \csrf -> do
           (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
-          let lrwView' = [whamlet|
+          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
-                           $newline never
-                           #{csrf}
-                           <span style="font-family:monospace">
-                             #{lEmail}
-                            #
-                           <div .tooltip>
-                             <div .tooltip__handle>
-                             <div .tooltip__content>
-                               _{MsgEmailInvitationWarning}
-                            #
-                           ^{fvInput lrwView}
-                         |]
           return (lrwRes,lrwView')
 
         miDelete :: ListLength   -- ^ Current shape
@@ -675,6 +660,13 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
         miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
         miAllowAdd _ _ _ = True
 
+        miLayout :: ListLength
+                 -> Map ListPosition Widget -- ^ Cell widgets
+                 -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
+                 -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
+                 -> Widget
+        miLayout lLength cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
+
 
         lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput

src/Handler/Utils/Form/MassInput.hs

@@ -2,6 +2,7 @@
 
 module Handler.Utils.Form.MassInput
   ( MassInput(..)
+  , defaultMiLayout
   , massInput
   , massInputList
   , BoxDimension(..)
@@ -24,6 +25,7 @@ import Text.Blaze (Markup)
 import qualified Data.Text as Text
 
 import qualified Data.Set as Set
+import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Foldable as Fold
 import Data.List (genericLength, genericIndex, iterate)
@@ -206,6 +208,11 @@ data MassInput handler liveliness cellData cellResult = MassInput
                -> liveliness
                -> Bool -- ^ Decide whether an addition-operation should be permitted
   , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
+  , miLayout :: liveliness
+             -> Map (BoxCoord liveliness) Widget -- ^ Cell Widgets
+             -> Map (BoxCoord liveliness) (FieldView UniWorX) -- ^ Delete buttons
+             -> Map (Natural, BoxCoord liveliness) Widget -- ^ Addition forms
+             -> Widget
   }
 
 massInput :: forall handler cellData cellResult liveliness.
@@ -342,22 +349,12 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
         guard $ not shapeChanged
         for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult
 
-  let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
+  let miWidget
-      miWidget' _ [] = mempty
+        = miLayout
-      miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =
+          liveliness
-        let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
+          (fmap (view $ _2 . _2) cellResults)
-            cells
+          (fmap (view _2) delResults)
-              | [] <- remDims = do
+          (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
-                  coord <- coords
-                  Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults 
-                  let deleteButton = snd <$> Map.lookup coord delResults
-                  return (coord, $(widgetFile "widgets/massinput/cell"))
-              | otherwise =
-                  [ (coord, miWidget' coord remDims) | coord <- coords ]
-            addWidget = (\(_, mWgt) -> mWgt <* guard (miAllowAdd miCoord dimIx liveliness)) =<< Map.lookup (dimIx, miCoord) addResults
-         in $(widgetFile "widgets/massinput/row")
-
-      miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
 
   MsgRenderer mr <- getMsgRenderer
   
@@ -368,6 +365,31 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
     fvErrors = Nothing
     in return (result, FieldView{..})
 
+defaultMiLayout :: forall liveliness.
+                   Liveliness liveliness
+                => liveliness
+                -> Map (BoxCoord liveliness) Widget
+                -> Map (BoxCoord liveliness) (FieldView UniWorX)
+                -> Map (Natural, BoxCoord liveliness) Widget
+                -> Widget
+-- | Generic `miLayout` using recursively nested lists
+defaultMiLayout liveliness cellResults delResults addResults = miWidget' boxOrigin $ zip [0..] boxDimensions
+  where
+    miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
+    miWidget' _ [] = mempty
+    miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =
+      let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
+          cells
+            | [] <- remDims = do
+                coord <- coords
+                Just cellWdgt <- return $ Map.lookup coord cellResults 
+                let deleteButton = Map.lookup coord delResults
+                return (coord, $(widgetFile "widgets/massinput/cell"))
+            | otherwise =
+                [ (coord, miWidget' coord remDims) | coord <- coords ]
+          addWidget = Map.lookup (dimIx, miCoord) addResults
+       in $(widgetFile "widgets/massinput/row")
+
 
 -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
 massInputList :: forall handler cellResult.
@@ -389,6 +411,8 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes
             , miDelete = miDeleteList
             , miAllowAdd = \_ _ _ -> True
             , miButtonAction
+            , miLayout = \lLength cellWdgts delButtons addWdgts
+              -> $(widgetFile "widgets/massinput/list/layout")
             }
   miSettings
   miRequired

templates/course/lecturerMassInput/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=3>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput btn}

templates/course/lecturerMassInput/cellInvitation.hamlet

@@ -0,0 +1,12 @@
+ $newline never
+ <td>
+   #{csrf}
+   <span style="font-family: monospace">
+     #{lEmail}
+ <td>
+   <div .tooltip>
+     <div .tooltip__handle>
+     <div .tooltip__content>
+       _{MsgEmailInvitationWarning}
+ <td>
+   ^{fvInput lrwView}

templates/course/lecturerMassInput/cellKnown.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=2>
+  #{csrf}
+  ^{nameEmailWidget userEmail userDisplayName userSurname} #
+<td>
+  ^{fvInput lrwView}

templates/course/lecturerMassInput/layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput--cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/massinput/list/layout.hamlet

@@ -0,0 +1,14 @@
+$newline never
+<table>
+  <tbody>
+    <tr .massinput--cell>
+      $forall coord <- review liveCoords lLength
+        <td>
+          ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr>
+      <td>
+      <td .massinput--add>
+        ^{addWdgts ! (0, 0)}