diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 9dd373ce9..112f87361 100644 --- a/src/Handler/Course.hs +++ b/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 - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias) +-- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if +-- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) +-- | 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) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 6e4c640de..6033da345 100644 --- a/src/Handler/Profile.hs +++ b/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 - 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 + let + procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + procData = id + + -- 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))) - -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value UTCTime)) +-- courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) +-- -> 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" - , SortColumn $ \(course `E.InnerJoin` _) -> course E.^. CourseName ) + [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse 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 } diff --git a/src/Handler/Utils/Table/Convenience.hs b/src/Handler/Utils/Table/Convenience.hs new file mode 100644 index 000000000..0aea84073 --- /dev/null +++ b/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| ^{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 + + + diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 084adf0e1..269b3b9bc 100644 --- a/src/Utils/DB.hs +++ b/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