Handler.Utils.Table.Convenience -> Cells; ProfileData clean refactored

src/Handler/Course.hs

@@ -21,7 +21,7 @@ import Control.Lens
 import Utils.Lens
 import Utils.TH
 import Handler.Utils
-import Handler.Utils.Table.Convenience
+import Handler.Utils.Table.Cells
 
 -- import Data.Time
 import qualified Data.Text as T

src/Handler/Profile.hs

@@ -17,11 +17,12 @@ module Handler.Profile where
 import Import
 
 import Handler.Utils
-import Handler.Utils.Table.Convenience
+import Handler.Utils.Table.Cells
 
 import Utils.Lens
 -- import Colonnade hiding (fromMaybe, singleton)
 -- import Yesod.Colonnade
+import Data.Monoid (Any(..))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
@@ -150,7 +151,7 @@ postProfileR = do
 
 ----------------------------------------
 -- TODO: Are these really a good idea?
---  If yes: Move to appropriate Place: Utils.Lens and Utils.Table.Convenience
+--  If yes: Move to appropriate Place: Utils.Lens and Utils.Table.Cells
 --
 -- 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]
@@ -173,11 +174,15 @@ getProfileDataR = do
   --   mr <- getMessageRender
 
   -- Tabelle mit eigenen Kursen
-  ownCourseTable <- do -- TODO: only display when non-empty
+  (Any hasRows, ownCourseTable) <- do -- TODO: only display when non-empty
     let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
                  -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
         withType = id
-    dbTableWidget' def $ DBTable
+
+        validator = def
+          & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)]
+
+    dbTableWidget validator $ DBTable
       { dbtIdent     = "courseOwnership" :: Text
       , dbtStyle     = def
       , dbtSQLQuery  = \(course `E.InnerJoin` lecturer) -> do
@@ -185,15 +190,20 @@ getProfileDataR = do
           E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
           return ( course E.^. CourseTerm
                  , course E.^. CourseSchool
-                 , course E.^. CourseId
                  , course E.^. CourseShorthand
                  )
+      , dbtProj = \x -> return $ x & _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
       , dbtColonnade = mconcat
           [ dbRow
-          , colsCourseLink' $ _dbrOutput
+          , sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do
---           [ colsCourseLink $ (over each _unValue) . _dbrOutput -- different types in Tuple prevents "over each"
+              tid <- view (_dbrOutput . _1)
+              return $ indicatorCell `mappend` termCell tid
+          , sortable (Just "school") (i18nCell MsgCourseSchool) $
+              schoolCell <$> view (_dbrOutput . _1 . re _Just)
+                         <*> view (_dbrOutput . _2 )
+          , sortable (Just "course") (i18nCell MsgCourse) $
+              courseLinkCell <$> view (_dbrOutput)
           ]
-      , dbtProj = return
       , dbtSorting = Map.fromList
           [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) -- consider PatternSynonyms. Drawback: not enclosed with table, since they must be at Top-Level. Maybe make Lenses for InnerJoins then?
           , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm     )
@@ -208,39 +218,34 @@ getProfileDataR = do
 
   -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
   courseTable <- do
-        let
+        let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
-            withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
                      -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
             withType = id
 
-            -- should be inlined
+            validator = def
---             courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a)
+              & defaultSorting [("time",SortDesc)]
---             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 = \(course `E.InnerJoin` participant) -> do
               E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
               E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
               return (course, participant E.^. CourseParticipantRegistration)
-        dbTableWidget' def $ DBTable
+        dbTableWidget' validator $ DBTable
           { dbtIdent     = "courseMembership" :: Text
           , dbtSQLQuery  = courseData
+          , dbtProj      = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
           , dbtColonnade = mconcat
               [ dbRow
-              , colsCourseDescr $ _dbrOutput . _1 . _entityVal
+              , sortable (Just "term") (i18nCell MsgTerm) $
+                  termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
+              , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
+                  schoolCell <$> view ( _courseTerm . re _Just)
+                             <*> view ( _courseSchool )
+              , sortable (Just "course") (i18nCell MsgCourse) $
+                  courseCell <$> view (_dbrOutput . _1 . _entityVal)
               , sortable (Just "time") (i18nCell MsgRegistered) $ do
-                  regTime <- view $ _dbrOutput . _2 . _unValue
+                  regTime <- view $ _dbrOutput . _2
                   return $ timeCell regTime
-              ]
+                ]
-          , dbtProj      = return
           , dbtSorting   = Map.fromList
               [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName  )
               , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm  )
@@ -261,14 +266,18 @@ getProfileDataR = do
     let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
                 ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
         withType = id
-    let validator = def -- DUPLICATED CODE: Handler.Corrections
+
+        validator = def -- DUPLICATED CODE: Handler.Corrections
           & restrictFilter  (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
           & restrictSorting (\name _ -> name /= "corrector")
+          & defaultSorting [("edit",SortDesc)]
+
         lastSubEdit submission = -- latest Edit-Time of this user for submission
           E.sub_select . E.from $ \subEdit -> do
             E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
                 E.&&.  subEdit E.^. SubmissionEditUser E.==. E.val uid
             return . E.max_ $ subEdit E.^. SubmissionEditTime
+
     dbTableWidget' validator $ DBTable
       { dbtIdent     = "submissions" :: Text
       , dbtStyle     = def
@@ -279,41 +288,37 @@ getProfileDataR = do
           E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
           let crse = ( course E.^. CourseTerm
                      , course E.^. CourseSchool
-                     , course E.^. CourseId
                      , course E.^. CourseShorthand
                      )
           let sht  = ( sheet E.^. SheetName
                      )
           return (crse, sht, submission, lastSubEdit submission)
+      , dbtProj = \x -> return $ x
+          & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
+          & _dbrOutput . _2 %~ E.unValue
+          & _dbrOutput . _4 %~ E.unValue
       , dbtColonnade = mconcat
           [ dbRow
-          , colsCourseLink' $ _dbrOutput . _1
+          , sortable (Just "term") (i18nCell MsgTerm) $
-          , sortable (Just "sheet") (i18nCell MsgSheet) $ do
+              termCell   <$> view (_dbrOutput . _1 . _1)
-              shn  <- view $ _dbrOutput . _2 . _unValue
+          , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
-              crse <- view $ _dbrOutput . _1
+              schoolCell <$> view ( _1. re _Just)
-              let tid = crse ^. _1 . _unValue
+                         <*> view ( _2 )
-                  ssh = crse ^. _2 . _unValue
+          , sortable (Just "course") (i18nCell MsgCourse) $
-                  csh = crse ^. _4 . _unValue
+              courseLinkCell <$> view (_dbrOutput . _1)
-                  link= CSheetR tid ssh csh shn SShowR
+          , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
-              return $ anchorCell link $ display2widget shn
+              sheetCell <$> view _1
-
+                        <*> view _2
-          , sortable (toNothing "submission") (i18nCell MsgSubmission) $ do -- TODO: use submissionCell?!
+          , sortable (toNothing "submission") (i18nCell MsgSubmission) . magnify _dbrOutput $
-              shn  <- view $ _dbrOutput . _2 . _unValue
+              submissionCell  <$> view  _1
-              sid  <- view $ _dbrOutput . _3 . _entityKey
+                              <*> view  _2
-              crse <- view $ _dbrOutput . _1
+                              <*> view (_3 . _entityKey)
-
+--           , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do
-
+--               regTime <- view $ _dbrOutput . _4
-              let tid = crse ^. _1 . _unValue
+--               return $ maybe mempty timeCell regTime
-                  ssh = crse ^. _2 . _unValue
+          , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $
-                  csh = crse ^. _4 . _unValue
+              maybe mempty timeCell <$> view (_dbrOutput . _4)
-                  mkCid = encrypt (sid :: SubmissionId) -- TODO: executed twice
-                  mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
-              return $ anchorCellM' mkCid mkRoute display2widget
-          , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do
-              regTime <- view $ _dbrOutput . _4 . _unValue
-              return $ maybe mempty timeCell regTime
           ]
-      , dbtProj = return
       , dbtSorting = Map.fromList
           [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
           , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm     )

src/Handler/School.hs

@@ -21,7 +21,7 @@ import Import
 -- import Utils.Lens
 -- import Utils.TH
 -- import Handler.Utils
--- import Handler.Utils.Table.Convenience
+-- import Handler.Utils.Table.Cells
 --
 -- -- import Data.Time
 -- import qualified Data.Text as T

src/Handler/Submission.hs

@@ -23,7 +23,7 @@ import Import hiding (joinPath)
 -- import Yesod.Form.Bootstrap3  
 
 import Handler.Utils
-import Handler.Utils.Table.Convenience
+import Handler.Utils.Table.Cells
 
 import Network.Mime
 

src/Handler/Utils/Table/Cells.hs

@@ -5,25 +5,26 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
 
-module Handler.Utils.Table.Convenience where
+module Handler.Utils.Table.Cells where
 
 import Import
 
+import Data.Monoid (Any(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
+
 import Utils.Lens
 import Handler.Utils
--- import Handler.Utils.Table.Pagination
-
-import qualified Database.Esqueleto as E (Value(..))
-
--- newtype CourseLink = CourseLink (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId
-type CourseLink = (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId
--- TODO: can we get rid of this type through lenses?
-type CourseLink' = (E.Value TermId, E.Value SchoolId, E.Value CourseId, E.Value CourseShorthand) -- cannot be in Types due to CourseId
 
 
+type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
 
+--------------------
 -- Special cells
 
+indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
+indicatorCell = mempty & cellContents %~ (tell (Any True) *>)
+
+-- Datatype cells
 timeCell :: IsDBTable m a => UTCTime -> DBCell m a
 timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
 
@@ -48,13 +49,7 @@ schoolCell Nothing ssh  = anchorCell link name
     name = text2widget $ display ssh
 
 courseLinkCell :: IsDBTable m a => CourseLink -> DBCell m a
-courseLinkCell (tid,ssh,_cid,csh) = anchorCell link name
+courseLinkCell (tid,ssh,csh) = anchorCell link name
-  where
-    link = CourseR tid ssh csh CShowR
-    name = citext2widget csh
-
-courseLinkCell' :: IsDBTable m a => CourseLink' -> DBCell m a
-courseLinkCell' (E.Value tid, E.Value ssh,_cid,E.Value csh) = anchorCell link name
   where
     link = CourseR tid ssh csh CShowR
     name = citext2widget csh
@@ -68,27 +63,27 @@ courseCell (Course {..}) = anchorCell link name `mappend` desc
             Nothing      -> mempty
             (Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
 
-sheetCell :: IsDBTable m a => (CourseLink', E.Value SheetName) -> DBCell m a
+sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
-sheetCell (crse, E.Value shn) =
+sheetCell crse shn =
-  let tid = crse ^. _1 . _unValue
+  let tid = crse ^. _1
-      ssh = crse ^. _2 . _unValue
+      ssh = crse ^. _2
-      csh = crse ^. _4 . _unValue
+      csh = crse ^. _3
       link= CSheetR tid ssh csh shn SShowR
   in anchorCell link $ display2widget shn
 
-submissionCell :: IsDBTable m a => (CourseLink', E.Value SheetName, Entity Submission) -> DBCell m a
+submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
-submissionCell (crse, E.Value shn, submission) =
+submissionCell crse shn sid =
-  let tid = crse ^. _1 . _unValue
+  let tid = crse ^. _1
-      ssh = crse ^. _2 . _unValue
+      ssh = crse ^. _2
-      csh = crse ^. _4 . _unValue
+      csh = crse ^. _3
-      sid = entityKey submission
+      mkCid = encrypt sid
-      mkCid = encrypt (sid :: SubmissionId) -- TODO: executed twice -- FIXED here, but not everywhere!
       mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
       mkText  cid = display2widget cid
   in anchorCellM' mkCid mkRoute mkText
 
 
--- Generic Columns
+{-# DEPRECATED colCourseDescr, colsCourseDescr, colsCourseLink "Bad idea, write columns yourself you lazy bat!" #-}
+-- Generic Columns -- We want to avoid these due to the literals occuring
 colCourseDescr :: IsDBTable m a => Getting Course s Course -> Colonnade Sortable s (DBCell m a)
 colCourseDescr getter =
   sortable (Just "course") (i18nCell MsgCourse) $ do
@@ -120,18 +115,3 @@ colsCourseLink getter = mconcat
       crs <- view getter
       return $ courseLinkCell crs
   ]
-
-colsCourseLink' :: (IsDBTable m a) => Getting CourseLink' s CourseLink' -> Colonnade Sortable s (DBCell m a)
-colsCourseLink' getter = mconcat
-  [ sortable (Just "term") (i18nCell MsgTerm) $ do
-      crs <- view getter
-      return $ termCell $ crs ^. _1 . _unValue
-  , sortable (Just "school") (i18nCell MsgCourseSchool) $ do
-      crs <- view getter
-      return $ schoolCell (Just $ crs ^. _1 . _unValue) (crs ^. _2  . _unValue)
-  , sortable (Just "course") (i18nCell MsgCourse) $ do
-      crs <- view getter
-      return $ courseLinkCell' crs
-  ]
-
-

src/Handler/Utils/Table/Pagination.hs

@@ -21,7 +21,7 @@
 module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
   , FilterColumn(..), IsFilterColumn
-  , DBRow(..), HasDBRow(..)
+  , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
   , DBStyle(..), DBEmptyStyle(..)
   , DBTable(..), IsDBTable(..), DBCell(..)
   , cellAttrs, cellContents
@@ -45,6 +45,7 @@ module Handler.Utils.Table.Pagination
   ) where
 
 import Handler.Utils.Table.Pagination.Types
+import Utils.Lens.TH
 
 import Import hiding (Proxy(..))
 import qualified Database.Esqueleto as E
@@ -134,7 +135,7 @@ data PaginationSettings = PaginationSettings
   , psShortcircuit :: Bool
   }
 
-makeClassy_ ''PaginationSettings
+makeLenses_ ''PaginationSettings
 
 instance Default PaginationSettings where
   def = PaginationSettings
@@ -153,7 +154,7 @@ data PaginationInput = PaginationInput
   , piShortcircuit :: Bool
   }
 
-makeClassy_ ''PaginationInput
+makeLenses_ ''PaginationInput
 
 piIsUnset :: PaginationInput -> Bool
 piIsUnset PaginationInput{..} = and
@@ -169,7 +170,7 @@ data DBRow r = DBRow
   , dbrIndex, dbrCount :: Int64
   } deriving (Show, Read, Eq, Ord)
 
-makeClassy_ ''DBRow
+makeLenses_ ''DBRow
 
 instance Functor DBRow where
   fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }

src/Utils/DB.hs

@@ -15,7 +15,8 @@ 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

src/index.md

@@ -75,7 +75,7 @@ Handler.Utils.Table.Pagination
 Handler.Utils.Table.Pagination.Types
   : `Sortable`-Headedness for colonnade
 
-Handler.Utils.Table.Convenience
+Handler.Utils.Table.Cells
   : extends dbTable with UniWorX specific functions, such as special courseCell
 
 Handler.Utils.Templates

templates/profileData.hamlet

@@ -8,10 +8,11 @@
 
   <em> TODO: Hier alle Daten in Tabellen anzeigen!
 
-  <div .container>
+  $if hasRows
-    <h2> Eigene Kurse
     <div .container>
-      ^{ownCourseTable}
+      <h2> Eigene Kurse
+      <div .container>
+        ^{ownCourseTable}
 
   <div .container>
     <h2> Kursanmeldungen