190 lines
6.6 KiB
Haskell
190 lines
6.6 KiB
Haskell
module Handler.Utils.Table.Cells where
|
|
|
|
import Import
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
-- import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Monoid (Any(..))
|
|
import Control.Monad.Writer.Class (MonadWriter(..))
|
|
import Control.Monad.Trans.Writer (WriterT)
|
|
|
|
import Utils.Lens
|
|
import Handler.Utils
|
|
|
|
|
|
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
|
|
|
|
----------------
|
|
-- Some basic cells are defined in Handler.Utils.Table.Pagination
|
|
-- such as: i18nCell, cellTooltip, anchorCell for links, etc.
|
|
|
|
----------------
|
|
-- Special cells
|
|
|
|
tellCell :: (Monoid a, IsDBTable m a) => a -> DBCell m a -> DBCell m a
|
|
tellCell = flip mappend . writerCell . tell
|
|
|
|
cellTell :: (Monoid a, IsDBTable m a) => DBCell m a -> a -> DBCell m a
|
|
cellTell = flip tellCell
|
|
|
|
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
|
|
indicatorCell = writerCell . tell $ Any True
|
|
|
|
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
|
|
writerCell act = mempty & cellContents %~ (<* act)
|
|
|
|
maybeCell :: (IsDBTable m a) => Maybe a -> (a -> DBCell m a) -> DBCell m a
|
|
maybeCell =flip foldMap
|
|
|
|
|
|
---------------------
|
|
-- Icon cells
|
|
|
|
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
|
|
tickmarkCell = cell . toWidget . hasTickmark
|
|
|
|
commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
|
|
commentCell Nothing = mempty
|
|
commentCell (Just link) = anchorCell link icon
|
|
where icon = toWidget $ hasComment True
|
|
|
|
|
|
-----------------
|
|
-- Datatype cells
|
|
timeCell :: IsDBTable m a => UTCTime -> DBCell m a
|
|
timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
|
|
|
|
userCell :: IsDBTable m a => Text -> Text -> DBCell m a
|
|
userCell displayName surname = cell $ nameWidget displayName surname
|
|
|
|
emailCell :: IsDBTable m a => CI Text -> DBCell m a
|
|
emailCell userEmail = cell $(widgetFile "widgets/link-email")
|
|
|
|
cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c
|
|
cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname)
|
|
|
|
cellHasUserLink :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
|
|
-- cellHasUserLink toLink user =
|
|
-- let uid = user ^. hasEntityUser . _entityKey
|
|
-- nWdgt = nameWidget (user ^. hasEntityUser . _entityVal . _userDisplayName) (user ^. hasEntityUser . _entityVal . _userSurname)
|
|
-- in anchorCellM (toLink <$> encrypt uid) nWdgt
|
|
cellHasUserLink toLink user =
|
|
let userEntity = user ^. hasEntityUser
|
|
uid = userEntity ^. _entityKey
|
|
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
|
in anchorCellM (toLink <$> encrypt uid) nWdgt
|
|
|
|
cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
|
|
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
|
|
|
|
cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a
|
|
cellHasEMail = emailCell . view _userEmail
|
|
|
|
|
|
|
|
-- Just for documentation purposes; inline this code instead:
|
|
maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
|
|
maybeTimeCell = maybe mempty timeCell
|
|
|
|
numCell :: (IsDBTable m a, Num b, DisplayAble b) => b -> DBCell m a
|
|
numCell = textCell . display
|
|
|
|
int64Cell :: (IsDBTable m a) => Int64-> DBCell m a
|
|
int64Cell = numCell
|
|
|
|
termCell :: IsDBTable m a => TermId -> DBCell m a
|
|
termCell tid = anchorCell link name
|
|
where
|
|
link = TermCourseListR tid
|
|
name = text2widget $ display tid
|
|
|
|
termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
|
|
termCellCL (tid,_,_) = termCell 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
|
|
|
|
schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a
|
|
schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh
|
|
|
|
courseCellCL :: IsDBTable m a => CourseLink -> DBCell m a
|
|
courseCellCL (tid,ssh,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|
|
|
$newline never
|
|
<div>
|
|
^{modal "Beschreibung" (Right $ toWidget descr)}
|
|
|]
|
|
|
|
sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
|
|
sheetCell crse shn =
|
|
let tid = crse ^. _1
|
|
ssh = crse ^. _2
|
|
csh = crse ^. _3
|
|
link= CSheetR tid ssh csh shn SShowR
|
|
in anchorCell link $ display2widget shn
|
|
|
|
submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
|
|
submissionCell crse shn sid =
|
|
let tid = crse ^. _1
|
|
ssh = crse ^. _2
|
|
csh = crse ^. _3
|
|
mkCid = encrypt sid
|
|
mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
|
|
mkText = display2widget
|
|
in anchorCellM' mkCid mkRoute mkText
|
|
|
|
correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a
|
|
correctorStateCell sc =
|
|
i18nCell $ sheetCorrectorState sc
|
|
|
|
correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
|
|
correctorLoadCell sc =
|
|
i18nCell $ sheetCorrectorLoad sc
|
|
|
|
|
|
--------------------------------
|
|
-- Generic Columns
|
|
-- reuse encourages consistency
|
|
--
|
|
-- if it works out, turn into its own module
|
|
-- together with filters and sorters
|
|
|
|
|
|
-- | Does not work, since we have now show Instance for RenderMesage UniWorX msg
|
|
colUser :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c)
|
|
colUser msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
|
|
|
|
colUserParticipant :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
|
colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMembers) cellHasUser
|
|
|
|
colUserParticipantLink :: (IsDBTable m c, HasEntity a User) => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable a (DBCell m c)
|
|
colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMembers) (cellHasUserLink courseLink)
|
|
where
|
|
-- courseLink :: CryptoUUIDUser -> Route UniWorX
|
|
courseLink = CourseR tid ssh csh . CUserR
|
|
|
|
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
|
colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
|
|
|
|
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
|
colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail
|