Sorting/Filter refactro Profile Data

src/Handler/Course.hs

@@ -172,9 +172,12 @@ makeCourseTable whereClause colChoices psValidator = do
                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
           )
-        , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
+--         , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
-                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+--                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
-                | otherwise          -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
+--                 | otherwise          -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
+--           )
+        , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
+              emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
           )
         , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)

src/Handler/Profile.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiWayIf, LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE PartialTypeSignatures #-}
@@ -7,6 +8,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE FlexibleInstances #-}
 
 module Handler.Profile where
@@ -20,6 +22,7 @@ import Utils.Lens
 -- import Colonnade hiding (fromMaybe, singleton)
 -- import Yesod.Colonnade
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 -- import           Database.Esqueleto      ((^.))
 
@@ -147,6 +150,21 @@ postProfileR = do
 ----------------------------------------
 -- TODO: Are these really a good idea?
 --  If yes: Move to appropriate Place: Utils.Lens and Utils.Table.Convenience
+--
+-- Or Maybe make Course an instance of Data.Data and use biplate instead?
+-- λ>  ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [String]
+-- ["a","b","c","d","e","f"]
+-- it :: [String]
+-- *Main Control.Lens Data.Data.Lens
+-- λ> ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [Int]
+-- []
+-- it :: [Int]
+-- *Main Control.Lens Data.Data.Lens
+-- λ> ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [Integer]
+-- [7,9,8]
+-- it :: [Integer]
+
+
 
 -- instance HasCourse (DBRow (Entity Course, a)) where
 --   course = _dbrOutput . _1 . _entityVal
@@ -168,6 +186,8 @@ instance HasCourse a => HasCourse (DBRow a) where
 
 --
 
+-- type CourseTableData = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)
+-- NOTE: use procData instead as a flexible inlines Type signature
 
 getProfileDataR  :: Handler Html
 getProfileDataR = do
@@ -177,19 +197,24 @@ getProfileDataR = do
   -- Tabelle mit eigenen Kursen
   -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
   courseTable <- do
-        let -- should be inlined
+        let
-            courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a)
+            procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
-            courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad
+                     -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
-              course <- view $ _dbrOutput . _1 . _entityVal -- view == ^.
+            procData = id
-              -- "preview _left" in order to match Either (result is Maybe)
+
-              return $ courseCell course
+            -- should be inlined
+--             courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a)
+--             courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad
+--               course <- view $ _dbrOutput . _1 . _entityVal -- view == ^.
+--               -- "preview _left" in order to match Either (result is Maybe)
+--               return $ courseCell course
 
 --             termCol = sortable (Just "school") (i18nCell MsgCourseSchool) $ do
 --               Course{..} <- view $ _dbrOutput . _1 . _entityVal
 --               return $ anchorCell (TermsSchoolCourseListR
 
-            courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant)))
+--             courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant)))
-                            -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value UTCTime))
+--                             -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value UTCTime))
             courseData = \(course `E.InnerJoin` participant) -> do
               E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
               E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
@@ -205,10 +230,14 @@ getProfileDataR = do
               ]
           , dbtProj      = return
           , dbtSorting   = Map.fromList
-              [ ( "course"
+              [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName )
-                , SortColumn $ \(course `E.InnerJoin` _) -> course E.^. CourseName )
+              , ( "time"  , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration)
+              ]
+          , dbtFilter    = Map.fromList
+              [
+                ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand )
+--               , ( "time"  , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
               ]
-          , dbtFilter    = mempty
           , dbtStyle     = def
           }
 

src/Handler/Utils/Table/Convenience.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Handler.Utils.Table.Convenience where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils
+-- import Handler.Utils.Table.Pagination
+
+
+-- Special cells
+
+timeCell :: IsDBTable m a => UTCTime -> DBCell m a
+timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
+
+-- Just for documentation purposes; inline the code instead:
+maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
+maybeTimeCell = maybe mempty timeCell
+
+courseCell :: IsDBTable m a => Course -> DBCell m a
+courseCell (Course {..}) = anchorCell link name `mappend` desc
+  where
+    link = CourseR courseTerm courseSchool courseShorthand CShowR
+    name = citext2widget courseName
+    desc = case courseDescription of
+            Nothing      -> mempty
+            (Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
+
+
+-- Generic Columns
+
+colCourseDescr :: (HasEntity c Course, HasDBRow s r, IsDBTable m a) =>
+  ((c -> Const Course c) -> r -> Const Course r) -> Colonnade Sortable s (DBCell m a)
+colCourseDescr courseLens = sortable (Just "course") (i18nCell MsgCourse) $ do
+    crs <- view $ _dbrOutput . courseLens . _entityVal
+    return $ courseCell crs
+
+colCourseDescr_ :: IsDBTable m a => Getting Course s Course -> Colonnade Sortable s (DBCell m a)
+colCourseDescr_ getter =
+  sortable (Just "course") (i18nCell MsgCourse) $ do
+    crs <- view getter
+    return $ courseCell crs
+
+colCourseDescrG :: (HasCourse s, IsDBTable m a) => Colonnade Sortable s (DBCell m a)
+colCourseDescrG =
+  sortable (Just "course") (i18nCell MsgCourse) $ do
+    crs <- view course
+    return $ courseCell crs
+
+
+

src/Utils/DB.hs

@@ -10,9 +10,18 @@ import ClassyPrelude.Yesod
 import qualified Data.List as List
 import Data.Map (Map)
 import qualified Data.Map as Map
-
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Database.Esqueleto as E
 -- import Database.Persist -- currently not needed here
 
+-- TODO: is this the right place?
+emptyOrIn :: PersistField typ =>
+  E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
+emptyOrIn criterion testSet
+  | Set.null testSet = E.val True
+  | otherwise        = criterion `E.in_` E.valList (Set.toList testSet)
+
 
 entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
 entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty