From e71864368c7a5530b1ef17457c40f9ef977893e3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Apr 2018 14:35:11 +0200 Subject: [PATCH] Implement links to toggle table sorting --- src/Handler/Term.hs | 16 +++---- src/Handler/Utils/Table/Pagination.hs | 48 +++++++++++++++++-- src/Handler/Utils/Table/Pagination/Types.hs | 40 ++++++++++++++++ .../layout-wrapper.hamlet} | 0 .../layout.hamlet} | 0 templates/table/sortable-header.hamlet | 7 +++ templates/table/table.hamlet | 12 +++++ 7 files changed, 111 insertions(+), 12 deletions(-) create mode 100644 src/Handler/Utils/Table/Pagination/Types.hs rename templates/{table-layout-wrapper.hamlet => table/layout-wrapper.hamlet} (100%) rename templates/{table-layout.hamlet => table/layout.hamlet} (100%) create mode 100644 templates/table/sortable-header.hamlet create mode 100644 templates/table/table.hamlet diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 5deecac7e..2461a05fc 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -42,7 +42,7 @@ getTermShowR = do provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ do let colonnadeTerms = mconcat - [ headed "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do + [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do -- Scrap this if to slow, create term edit page instead adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False [whamlet| @@ -52,22 +52,22 @@ getTermShowR = do $else #{termToText termName} |] - , headed "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> + , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termLectureStart - , headed "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> + , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termLectureEnd - , headed "Aktiv" $ \(Entity _ Term{..},_) -> + , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) -> textCell $ bool "" tickmark termActive - , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) -> + , sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) -> cell [whamlet| #{show numCourses} Kurse |] - , headed "Semesteranfang" $ \(Entity _ Term{..},_) -> + , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termStart - , headed "Semesterende" $ \(Entity _ Term{..},_) -> + , sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termEnd - , headed "Feiertage im Semester" $ \(Entity _ Term{..},_) -> + , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) -> stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays ] table <- dbTable def $ DBTable diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 23f0b6608..6f0c1d4c5 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -14,15 +14,24 @@ module Handler.Utils.Table.Pagination , DBTable(..) , PaginationSettings(..) , PSValidator(..) + , Sortable(..), sortable , dbTable ) where +import Handler.Utils.Table.Pagination.Types + import Import import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) import qualified Database.Esqueleto.Internal.Language as E (From) import Text.Blaze (Attribute) import qualified Text.Blaze.Html5.Attributes as Html5 +import qualified Text.Blaze.Html5 as Html5 +import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..)) + +import qualified Data.Binary.Builder as Builder + +import qualified Network.Wai as Wai import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -32,6 +41,7 @@ import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_) import Data.Map (Map, (!)) import Colonnade hiding (bool, fromMaybe) +import Colonnade.Encode import Yesod.Colonnade import Text.Hamlet (hamletFile) @@ -56,7 +66,7 @@ sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t data DBTable = forall a r h i t. - ( Headedness h + ( ToSortable h , E.SqlSelect a r , PathPiece i , E.From E.SqlQuery E.SqlExpr E.SqlBackend t @@ -94,6 +104,7 @@ instance Default PSValidator where modify $ \ps -> ps { psLimit = psLimit def } tell . pure $ SomeMessage MsgPSLimitNonPositive + dbTable :: PSValidator -> DBTable -> Handler Widget dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do let @@ -138,11 +149,40 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ E.from dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64))) bool return (sendResponse <=< tblLayout) psShortcircuit $ do - let table = encodeCellTable dbtAttrs' dbtColonnade rows + getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest + let table = $(widgetFile "table/table") pageCount = max 1 . ceiling $ rowCount % psLimit - $(widgetFile "table-layout") + tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams + withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell + { cellContents = $(widgetFile "table/sortable-header") + , .. + } + $(widgetFile "table/layout") where tblLayout :: Widget -> Handler Html tblLayout tbl' = do tbl <- widgetToPageContent tbl' - withUrlRenderer $(hamletFile "templates/table-layout-wrapper.hamlet") + withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet") + + setParam :: Text -> Maybe Text -> QueryText -> QueryText + setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ] + +widgetFromCell :: + (Attribute -> WidgetT site IO () -> WidgetT site IO ()) + -> Cell site + -> WidgetT site IO () +widgetFromCell f (Cell attrs contents) = + f attrs contents +td,th :: + Attribute -> WidgetT site IO () -> WidgetT site IO () + +td = liftParent Html5.td +th = liftParent Html5.th + +liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a +liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do + (a,gwd) <- f hdata + let Body bodyFunc = gwdBody gwd + newBodyFunc render = + el Html5.! attrs $ (bodyFunc render) + return (a,gwd { gwdBody = Body newBodyFunc }) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs new file mode 100644 index 000000000..c2038c4d0 --- /dev/null +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , RankNTypes + , RecordWildCards + #-} + +module Handler.Utils.Table.Pagination.Types where + +import Import hiding (singleton) + +import Colonnade +import Colonnade.Encode + +data Sortable a = Sortable + { sortableKey :: (Maybe Text) + , sortableContent :: a + } + +sortable :: Maybe Text -> c -> (a -> c) -> Colonnade Sortable a c +sortable k h = singleton (Sortable k h) + +instance Headedness Sortable where + headednessPure = Sortable Nothing + headednessExtract = Just $ \(Sortable _ x) -> x + headednessExtractForall = Just $ ExtractForall (\(Sortable _ x) -> x) + +newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a} + +class Headedness s => ToSortable s where + pSortable :: Maybe (SortableP s) + +instance ToSortable Sortable where + pSortable = Just $ SortableP id + +instance ToSortable Headed where + pSortable = Just $ SortableP (\(Headed x) -> Sortable Nothing x) + +instance ToSortable Headless where + pSortable = Nothing + diff --git a/templates/table-layout-wrapper.hamlet b/templates/table/layout-wrapper.hamlet similarity index 100% rename from templates/table-layout-wrapper.hamlet rename to templates/table/layout-wrapper.hamlet diff --git a/templates/table-layout.hamlet b/templates/table/layout.hamlet similarity index 100% rename from templates/table-layout.hamlet rename to templates/table/layout.hamlet diff --git a/templates/table/sortable-header.hamlet b/templates/table/sortable-header.hamlet new file mode 100644 index 000000000..1054b1ce0 --- /dev/null +++ b/templates/table/sortable-header.hamlet @@ -0,0 +1,7 @@ +^{cellContents} +$maybe flag <- sortableKey +
+ "-asc")}>asc + / + "-desc")}>desc +$nothing diff --git a/templates/table/table.hamlet b/templates/table/table.hamlet new file mode 100644 index 000000000..b1de810bf --- /dev/null +++ b/templates/table/table.hamlet @@ -0,0 +1,12 @@ + + $maybe sortableP <- pSortable + $with toSortable <- toSortable sortableP + + $forall OneColonnade{..} <- getColonnade dbtColonnade + ^{widgetFromCell th $ withSortLinks $ toSortable oneColonnadeHead} + $nothing + + $forall row <- rows + + $forall OneColonnade{..} <- getColonnade dbtColonnade + ^{widgetFromCell td $ oneColonnadeEncode row}