Implement table sorting

src/Handler/Term.hs

@@ -1,11 +1,13 @@
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE NoImplicitPrelude
-{-# LANGUAGE OverloadedStrings #-}
+           , OverloadedStrings
-{-# LANGUAGE RecordWildCards #-}
+           , OverloadedLists
-{-# LANGUAGE TemplateHaskell #-}
+           , RecordWildCards
-{-# LANGUAGE QuasiQuotes #-}
+           , TemplateHaskell
-{-# LANGUAGE MultiParamTypeClasses #-}
+           , QuasiQuotes
-{-# LANGUAGE TypeFamilies #-}
+           , MultiParamTypeClasses
-{-# LANGUAGE FlexibleContexts #-}
+           , 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
         }

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 :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
-sqlSortDirection (SortColumn e, SortAsc ) = E.asc  e
+sqlSortDirection t (SortColumn e, SortAsc ) = E.asc  $ e t
-sqlSortDirection (SortColumn e, SortDesc) = E.desc e
+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
+    sqlQuery' = E.from $ \t -> dbtSQLQuery t
-      <* E.orderBy (map sqlSortDirection psSorting')
+      <* 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