138 lines
5.0 KiB
Haskell
138 lines
5.0 KiB
Haskell
{-# 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
|
|
|
|
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
|
|
|
|
|
|
|
|
-- Special cells
|
|
|
|
timeCell :: IsDBTable m a => UTCTime -> DBCell m a
|
|
timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
|
|
|
|
-- Just for documentation purposes; inline this code instead:
|
|
maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
|
|
maybeTimeCell = maybe mempty timeCell
|
|
|
|
termCell :: IsDBTable m a => TermId -> DBCell m a
|
|
termCell tid = anchorCell link name
|
|
where
|
|
link = TermCourseListR tid
|
|
name = text2widget $ display tid
|
|
|
|
schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a
|
|
schoolCell (Just tid) ssh = anchorCell link name
|
|
where
|
|
link = TermSchoolCourseListR tid ssh
|
|
name = text2widget $ display ssh
|
|
schoolCell Nothing ssh = anchorCell link name
|
|
where
|
|
link = SchoolShowR ssh
|
|
name = text2widget $ display ssh
|
|
|
|
courseLinkCell :: IsDBTable m a => CourseLink -> DBCell m a
|
|
courseLinkCell (tid,ssh,_cid,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
|
|
|
|
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} |]
|
|
|
|
sheetCell :: IsDBTable m a => (CourseLink', E.Value SheetName) -> DBCell m a
|
|
sheetCell (crse, E.Value shn) =
|
|
let tid = crse ^. _1 . _unValue
|
|
ssh = crse ^. _2 . _unValue
|
|
csh = crse ^. _4 . _unValue
|
|
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 (crse, E.Value shn, submission) =
|
|
let tid = crse ^. _1 . _unValue
|
|
ssh = crse ^. _2 . _unValue
|
|
csh = crse ^. _4 . _unValue
|
|
sid = entityKey submission
|
|
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
|
|
colCourseDescr :: IsDBTable m a => Getting Course s Course -> Colonnade Sortable s (DBCell m a)
|
|
colCourseDescr getter =
|
|
sortable (Just "course") (i18nCell MsgCourse) $ do
|
|
course <- view getter
|
|
return $ courseCell course
|
|
|
|
colsCourseDescr :: IsDBTable m a => Getting Course s Course -> Colonnade Sortable s (DBCell m a)
|
|
colsCourseDescr getter = mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTerm) $ do
|
|
course <- view getter
|
|
return $ termCell $ courseTerm course
|
|
, sortable (Just "school") (i18nCell MsgCourseSchool) $ do
|
|
course <- view getter
|
|
return $ schoolCell (Just $ courseTerm course) (courseSchool course)
|
|
, sortable (Just "course") (i18nCell MsgCourse) $ do
|
|
course <- view getter
|
|
return $ courseCell course
|
|
]
|
|
|
|
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
|
|
, sortable (Just "school") (i18nCell MsgCourseSchool) $ do
|
|
crs <- view getter
|
|
return $ schoolCell (Just $ crs ^. _1) (crs ^. _2)
|
|
, sortable (Just "course") (i18nCell MsgCourse) $ do
|
|
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
|
|
]
|
|
|
|
|