diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index ce1767303..c0ad787ca 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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) () - go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = censor wrap . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do + -> WriterT (Seq (Seq (Widget, Int))) (WriterT x m) () + 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 row = case dbsTemplate of + wrap' :: Seq (Seq (Widget, Int)) -> Widget + 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 - DBSTCourse{} -> return $(widgetFile "table/course/header") - DBSTDefault{} -> return $(widgetFile "table/cell/header") + rowspan = preview _head $ do + (key, val) <- attrs + 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 diff --git a/templates/table/header.hamlet b/templates/table/header.hamlet index 200126344..c2882f1b3 100644 --- a/templates/table/header.hamlet +++ b/templates/table/header.hamlet @@ -1,6 +1,7 @@ $newline never