From fdeb2514c0faae19604b578358806aeb4677a95e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 7 Jun 2020 14:58:29 +0200 Subject: [PATCH] feat(dbtable): add support for Cornice --- src/Handler/Utils/Table/Pagination.hs | 48 +++++++++++++-------- src/Handler/Utils/Table/Pagination/Types.hs | 13 +++++- stack.yaml | 6 ++- stack.yaml.lock | 17 ++++++-- templates/table/cell/header.hamlet | 2 +- templates/table/colonnade.hamlet | 9 +--- templates/table/course/colonnade.hamlet | 8 ++-- templates/table/header.hamlet | 6 +++ 8 files changed, 72 insertions(+), 37 deletions(-) create mode 100644 templates/table/header.hamlet diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 52a9db794..46d06d62b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -597,16 +597,17 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException , dbtCsvRenderException :: csvException -> DB Text } -data DBTable m x = forall a r r' h i t k k' csv. +data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar). ( ToSortable h, Functor h , E.SqlSelect a r, E.SqlIn k k', DBTableKey k' , PathPiece i, Eq i , E.From t + , AsCornice h p r' (DBCell m x) colonnade ) => DBTable { dbtSQLQuery :: t -> E.SqlQuery a , dbtRowKey :: t -> k -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples. , dbtProj :: DBRow r -> DB r' - , dbtColonnade :: Colonnade h r' (DBCell m x) + , dbtColonnade :: colonnade , dbtSorting :: Map SortingKey (SortColumn t r') , dbtFilter :: Map FilterKey (FilterColumn t r') , dbtFilterUI :: DBFilterUI @@ -1259,21 +1260,32 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db table' :: WriterT x m Widget table' = let columnCount :: Int64 - columnCount = olength64 $ getColonnade dbtColonnade + columnCount = olength64 . getColonnade . discard $ dbtColonnade ^. _Cornice - genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do - widget <- sortableContent ^. cellContents - let - directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ] - isSortable = isJust sortableKey - 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") + numberColumn = case dbsTemplate of + DBSTDefault{..} -> dbstmNumber rowCount + _other -> False + + genHeaders :: _ -> [WriterT x m Widget] + genHeaders SortableP{..} = flip (headersMonoidal Nothing) (annotate $ dbtColonnade ^. _Cornice) $ pure + ( \Sized{ sizedSize, sizedContent = toSortable -> Sortable{..} } -> pure $ do + widget <- sortableContent ^. cellContents + let + cellSize = fromMaybe 1 sizedSize + directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ] + isSortable = isJust sortableKey + 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") + , case dbsTemplate of + DBSTCourse{} -> id + DBSTDefault{} -> pure . (>>= \row -> return $(widgetFile "table/header")) . foldMapM id + ) in do - wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable + wHeaders <- maybe (return Nothing) (fmap Just . foldMapM id . genHeaders) pSortable case dbsTemplate of DBSTCourse c l r s a -> do wRows <- forM rows $ \row' -> let @@ -1287,12 +1299,12 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db in return $(widgetFile "table/course/course-teaser") return $(widgetFile "table/course/colonnade") DBSTDefault{..} -> do - wRows' <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do + let colonnade = discard $ dbtColonnade ^. _Cornice + wRows' <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade colonnade) $ \(($ row') -> cell') -> do widget <- cell' ^. cellContents let attrs = cell' ^. cellAttrs return $(widgetFile "table/cell/body") - let numberColumn = dbstmNumber rowCount - wRows = zip [firstRow..] wRows' + let wRows = zip [firstRow..] wRows' return $(widgetFile "table/colonnade") pageCount diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 141e0b0b9..69566c3a9 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -1,12 +1,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Handler.Utils.Table.Pagination.Types - ( FilterKey, SortingKey + ( FilterKey(FilterKey), SortingKey(SortingKey) , Sortable(..) , sortable , ToSortable(..), FromSortable(..) , SortableP(..) , DBTableInvalid(..) + , AsCornice(..) ) where import Import hiding (singleton) @@ -74,3 +75,13 @@ data DBTableInvalid = DBTIRowsMissing Int instance Exception DBTableInvalid embedRenderMessage ''UniWorX ''DBTableInvalid id + + +class AsCornice h (p :: Pillar) a c x | x -> h p a c where + _Cornice :: Iso' x (Cornice h p a c) + +instance AsCornice h p a c (Cornice h p a c) where + _Cornice = id + +instance AsCornice h 'Base a c (Colonnade h a c) where + _Cornice = iso CorniceBase $ \(CorniceBase c) -> c diff --git a/stack.yaml b/stack.yaml index 989b5d9a5..ab91595e4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -30,9 +30,13 @@ extra-deps: - serversession-backend-acid-state - git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git commit: 074ed7c8810aca81f60f2c535f9e7bad67e9d95a + - git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git + commit: 65164334e9704afc24603a9f3197b4581c996ad8 + subdirs: + - colonnade - - colonnade-1.2.0.2 + # - colonnade-1.2.0.2 - hsass-0.8.0 - hlibsass-0.1.8.1 - tz-0.1.3.3 diff --git a/stack.yaml.lock b/stack.yaml.lock index 8ea803ff0..eea400a87 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -135,12 +135,21 @@ packages: git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git commit: 074ed7c8810aca81f60f2c535f9e7bad67e9d95a - completed: - hackage: colonnade-1.2.0.2@sha256:c95c2ecff5cfa28c736d8fa662d28b71129f67457068e3f4467b296a621607ab,2099 + subdir: colonnade + cabal-file: + size: 2020 + sha256: 28f603d097aee65ddf8fe032e7e0f87523a58c516253cba196922027c8fd54d5 + name: colonnade + version: 1.2.0.2 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git pantry-tree: - size: 327 - sha256: 98ccdd327916e0ff0ea2fa93ff9a96f5d492ae88258b330e991e6dcc4d332496 + size: 481 + sha256: c7137405813404f4e0d2334d67876ab7150e7dc7f8b9f23ad452c5ee76ce4737 + commit: 65164334e9704afc24603a9f3197b4581c996ad8 original: - hackage: colonnade-1.2.0.2 + subdir: colonnade + git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git + commit: 65164334e9704afc24603a9f3197b4581c996ad8 - completed: hackage: hsass-0.8.0@sha256:82d55fb2a10342accbc4fe80d263163f40a138d8636e275aa31ffa81b14abf01,2792 pantry-tree: diff --git a/templates/table/cell/header.hamlet b/templates/table/cell/header.hamlet index 45c103d49..e05dd9568 100644 --- a/templates/table/cell/header.hamlet +++ b/templates/table/cell/header.hamlet @@ -1,5 +1,5 @@ $newline never - + $maybe flag <- sortableKey $case directions $of [SortAsc] diff --git a/templates/table/colonnade.hamlet b/templates/table/colonnade.hamlet index 29e9d628f..4f5c29217 100644 --- a/templates/table/colonnade.hamlet +++ b/templates/table/colonnade.hamlet @@ -2,14 +2,9 @@ $newline never
- $maybe wHeaders' <- wHeaders + $maybe wdgt <- wHeaders - - $if numberColumn - $if null wRows && (dbsEmptyStyle == DBESHeading) diff --git a/templates/table/course/colonnade.hamlet b/templates/table/course/colonnade.hamlet index 65986997f..d23c64020 100644 --- a/templates/table/course/colonnade.hamlet +++ b/templates/table/course/colonnade.hamlet @@ -1,12 +1,10 @@ $newline never
- $maybe wHeaders' <- wHeaders + $maybe wdgt <- wHeaders
- $forall widget <- wHeaders' - ^{widget} - $nothing + ^{wdgt} $if null wRows && (dbsEmptyStyle == DBESHeading)

_{dbsEmptyMessage} $else $forall row <- wRows - ^{row} \ No newline at end of file + ^{row} diff --git a/templates/table/header.hamlet b/templates/table/header.hamlet new file mode 100644 index 000000000..200126344 --- /dev/null +++ b/templates/table/header.hamlet @@ -0,0 +1,6 @@ +$newline never +

+ $if numberColumn +
- $forall widget <- wHeaders' - $# cell/header.hamlet - ^{widget} + ^{wdgt} $nothing
+ $# cell/header.hamlet + ^{row}