Implement links to toggle table sorting

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|
                   <a href=@{CourseListTermR tid}>
                     #{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

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 })

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
+ 

templates/table/sortable-header.hamlet

@@ -0,0 +1,7 @@
+^{cellContents}
+$maybe flag <- sortableKey
+  <br>
+  <a href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-asc")}>asc
+  /
+  <a href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-desc")}>desc
+$nothing

templates/table/table.hamlet

@@ -0,0 +1,12 @@
+<table>
+  $maybe sortableP <- pSortable
+    $with toSortable <- toSortable sortableP
+      <thead>
+        $forall OneColonnade{..} <- getColonnade dbtColonnade
+          ^{widgetFromCell th $ withSortLinks $ toSortable oneColonnadeHead}
+  $nothing
+  <tbody>
+    $forall row <- rows
+      <tr>
+        $forall OneColonnade{..} <- getColonnade dbtColonnade
+          ^{widgetFromCell td $ oneColonnadeEncode row}