style(dbtable): add rowspan to number column header

src/Handler/Utils/Table/Pagination.hs

@@ -74,7 +74,6 @@ import Control.Monad.State (evalStateT, execStateT)
 import Control.Monad.Trans.Maybe
 import Control.Monad.State.Class (modify)
 import qualified Control.Monad.State.Class as State
-import Control.Monad.Trans.Writer.Lazy (censor)
 
 import Data.Map ((!))
 import qualified Data.Map as Map
@@ -1277,22 +1276,22 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
           _other -> False
 
         genHeaders :: forall h. Cornice h _ _ (DBCell m x) -> SortableP h -> WriterT x m Widget
-        genHeaders cornice SortableP{..} = execWriterT . go mempty $ annotate cornice
+        genHeaders cornice SortableP{..} = fmap wrap' . execWriterT . go mempty $ annotate cornice
           where
             go :: forall (p' :: Pillar) r'.
                   [(Int, Int, Int)]
                -> AnnotatedCornice (Maybe Int) h p' r' (DBCell m x)
-               -> WriterT Widget (WriterT x m) ()
+               -> WriterT (Seq (Seq (Widget, Int))) (WriterT x m) ()
-            go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = censor wrap . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do
+            go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = mapWriterT (over (mapped . _2) pure) . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do
               let (_, cellSize') = compCellSize rowspanAcc (map oneColonnadeHead before) Sized{..}
-              whenIsJust cellSize' $ \cellSize -> tellM $ fromContent Sized { sizedSize = cellSize, sizedContent }
+              whenIsJust cellSize' $ \cellSize -> tellM . fmap pure $ fromContent Sized { sizedSize = cellSize, sizedContent }
             go rowspanAcc (AnnotatedCorniceCap _ v@(toList -> oneCornices)) = do
-              rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (censor wrap) . forM_ (zip (inits oneCornices) oneCornices) $ \(before, OneCornice h (size -> sz')) -> do
+              rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (mapWriterT $ over (mapped . _2) pure) . forM_ (zip (inits oneCornices) oneCornices) $ \(before, OneCornice h (size -> sz')) -> do
                 let sz = Sized sz' h
                 let (beforeSize, cellSize') = compCellSize rowspanAcc (concatMap (map oneColonnadeHead . toList . getColonnade . uncapAnnotated . oneCorniceBody) before) sz
                 whenIsJust cellSize' $ \cellSize -> do
                   let Sized{..} = sz
-                  lift . tellM $ fromContent Sized { sizedSize = cellSize, sizedContent }
+                  lift . tellM . fmap pure $ fromContent Sized { sizedSize = cellSize, sizedContent }
                   if | [n] <- mapMaybe (\(key, val) -> guardOnM (is _Rowspan key) $ readMay val) (toSortable sizedContent ^. _sortableContent . cellAttrs)
                        -> State.modify $ (:) (n, beforeSize, cellSize)
                      | otherwise -> return ()
@@ -1309,11 +1308,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                       guard $ beforeSize < firstCol + sz
                       return . Sum $ sz - (beforeSize - firstCol)
 
-            wrap :: Widget -> Widget
+            wrap' :: Seq (Seq (Widget, Int)) -> Widget
-            wrap row = case dbsTemplate of
+            wrap' wRows = view _2 $ Foldable.foldl (\(stackHeight', acc) row -> (Nothing, (acc <>) . wrap stackHeight' $ foldOf (folded . _1) row)) (stackHeight, mempty) wRows
+              where stackHeight = maximumOf (folded . to (ala Sum foldMap . fmap (view _2))) wRows
+            wrap :: Maybe Int -> Widget -> Widget
+            wrap stackHeight row = case dbsTemplate of
               DBSTCourse{} -> row
               DBSTDefault{} -> $(widgetFile "table/header")
-            fromContent :: Sized Int h (DBCell m x) -> WriterT x m Widget
+            fromContent :: Sized Int h (DBCell m x) -> WriterT x m (Widget, Int)
             fromContent Sized{ sizedSize = cellSize, sizedContent = toSortable -> Sortable{..} } = do
               widget <- sortableContent ^. cellContents
               let
@@ -1322,9 +1324,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                 isSorted dir = fromMaybe False $ (==) <$> (SortingSetting <$> sortableKey <*> pure dir) <*> listToMaybe psSorting
                 attrs = sortableContent ^. cellAttrs
                 piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ]
-              case dbsTemplate of
+                rowspan = preview _head $ do
-                DBSTCourse{}  -> return $(widgetFile "table/course/header")
+                  (key, val) <- attrs
-                DBSTDefault{} -> return $(widgetFile "table/cell/header")
+                  guard $ is _Rowspan key
+                  hoistMaybe $ readMay val
+              return . (, fromMaybe 1 rowspan) $ case dbsTemplate of
+                DBSTCourse{}  -> $(widgetFile "table/course/header")
+                DBSTDefault{} -> $(widgetFile "table/cell/header")
       in do
         wHeaders <- maybe (return Nothing) (fmap Just . genHeaders (dbtColonnade ^. _Cornice)) pSortable
         now <- liftIO getCurrentTime

templates/table/header.hamlet

@@ -1,6 +1,7 @@
 $newline never
 <tr .table__row.table__row--head>
-  $if numberColumn
+  $maybe rowspan <- stackHeight
-    <th .table__th uw-hide-columns--no-hide .table__th--number>
+    $if numberColumn
+      <th .table__th uw-hide-columns--no-hide .table__th--number :rowspan /= 1:rowspan=#{rowspan}>
   $# cell/header.hamlet
   ^{row}