From 72b2b72f0396b157ada9f29f168042d4b700ad69 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Apr 2018 12:54:00 +0200 Subject: [PATCH] Implement table sorting --- src/Handler/Term.hs | 36 +++++++++++++++++++-------- src/Handler/Utils/Table/Pagination.hs | 25 +++++++++++-------- 2 files changed, 39 insertions(+), 22 deletions(-) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 9d85edbee..5deecac7e 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude + , OverloadedStrings + , OverloadedLists + , RecordWildCards + , TemplateHaskell + , QuasiQuotes + , MultiParamTypeClasses + , TypeFamilies + , FlexibleContexts + #-} module Handler.Term where @@ -29,7 +31,7 @@ getTermShowR = do -- return term -- let - termData = E.from $ \term -> do + termData term = do -- E.orderBy [E.desc $ term E.^. TermStart ] let courseCount :: E.SqlExpr (E.Value Int) courseCount = E.sub_select . E.from $ \course -> do @@ -37,7 +39,7 @@ getTermShowR = do return E.countRows return (term, courseCount) selectRep $ do - provideRep $ toJSON . map fst <$> runDB (E.select termData) + provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ do let colonnadeTerms = mconcat [ headed "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do @@ -71,7 +73,19 @@ getTermShowR = do table <- dbTable def $ DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms - , dbtSorting = mempty + , dbtSorting = [ ( "start" + , SortColumn $ \term -> term E.^. TermStart + ) + , ( "end" + , SortColumn $ \term -> term E.^. TermEnd + ) + , ( "lecture-start" + , SortColumn $ \term -> term E.^. TermLectureStart + ) + , ( "lecture-end" + , SortColumn $ \term -> term E.^. TermLectureEnd + ) + ] , dbtAttrs = tableDefault , dbtIdent = "terms" :: Text } diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 28fcb1073..23f0b6608 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -6,6 +6,7 @@ , QuasiQuotes , LambdaCase , ViewPatterns + , FlexibleContexts #-} module Handler.Utils.Table.Pagination @@ -19,6 +20,7 @@ module Handler.Utils.Table.Pagination 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 @@ -37,7 +39,7 @@ import Text.Hamlet (hamletFile) import Data.Ratio ((%)) -data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) } +data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } data SortDirection = SortAsc | SortDesc deriving (Eq, Ord, Enum, Show, Read) @@ -49,18 +51,19 @@ instance PathPiece SortDirection where | t == "desc" = Just SortDesc | otherwise = Nothing -sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy -sqlSortDirection (SortColumn e, SortAsc ) = E.asc e -sqlSortDirection (SortColumn e, SortDesc) = E.desc e +sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy +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. +data DBTable = forall a r h i t. ( Headedness h , E.SqlSelect a r , PathPiece i + , E.From E.SqlQuery E.SqlExpr E.SqlBackend t ) => DBTable - { dbtSQLQuery :: E.SqlQuery a + { dbtSQLQuery :: t -> E.SqlQuery a , dbtColonnade :: Colonnade h r (Cell UniWorX) - , dbtSorting :: Map Text SortColumn + , dbtSorting :: Map Text (SortColumn t) , dbtAttrs :: Attribute , dbtIdent :: i } @@ -109,7 +112,7 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do | otherwise = dbtAttrs psResult <- runInputGetResult $ PaginationSettings - <$> ireq (multiSelectField $ return sortingOptions) (wIdent "sorting") + <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")) <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize")) <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) <*> ireq checkBoxField (wIdent "table-only") @@ -125,14 +128,14 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing FormMissing -> runPSValidator Nothing psSorting' = map (first (dbtSorting !)) psSorting - sqlQuery' = dbtSQLQuery - <* E.orderBy (map sqlSortDirection psSorting') + sqlQuery' = E.from $ \t -> dbtSQLQuery t + <* E.orderBy (map (sqlSortDirection t) psSorting') <* E.limit psLimit <* E.offset (psPage * psLimit) mapM_ (addMessageI "warning") errs - (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64))) + (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