287 lines
10 KiB
Haskell
287 lines
10 KiB
Haskell
module Handler.Utils.Table.Cells where
|
|
|
|
import Import hiding (link)
|
|
|
|
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 Text.Blaze (ToMarkup(..))
|
|
|
|
import Handler.Utils.Table.Pagination
|
|
import Handler.Utils.DateTime
|
|
import Handler.Utils.Widgets
|
|
|
|
import Utils.Occurrences
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
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
|
|
|
|
-- | Display a breakable space
|
|
spacerCell :: IsDBTable m a => DBCell m a
|
|
spacerCell = cell [whamlet| |]
|
|
|
|
tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
|
|
tellCell = flip mappend . writerCell . tell
|
|
|
|
cellTell :: 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
|
|
|
|
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
|
|
htmlCell = cell . toWidget . toMarkup
|
|
|
|
pathPieceCell :: (IsDBTable m a, PathPiece p) => p -> DBCell m a
|
|
pathPieceCell = cell . toWidget . toPathPiece
|
|
|
|
-- | execute a DB action that return a widget for the cell contents
|
|
sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a
|
|
sqlCell act = mempty & cellContents .~ lift act
|
|
|
|
-- | Highlight table cells with warning: Is not yet implemented in frontend.
|
|
markCell :: IsDBTable m a => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
|
|
markCell status condition normal x
|
|
| condition x = normal x & addCellClass (statusToUrgencyClass status)
|
|
| otherwise = normal x
|
|
|
|
ifCell :: (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
|
|
ifCell decision cTrue cFalse x
|
|
| decision x = cTrue x
|
|
| otherwise = cFalse x
|
|
|
|
linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
|
|
linkEmptyCell = anchorCell
|
|
|
|
msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a
|
|
msgCell = textCell . toMessage
|
|
|
|
-- Recall: for line numbers, use dbRow
|
|
|
|
---------------------
|
|
-- Icon cells
|
|
|
|
iconCell :: IsDBTable m a => Icon -> DBCell m a
|
|
iconCell = cell . toWidget . icon
|
|
|
|
addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a
|
|
addIconFixedWidth = addCellClass ("icon-fixed-width" :: Text)
|
|
|
|
iconSpacerCell :: IsDBTable m a => DBCell m a
|
|
iconSpacerCell = mempty & addIconFixedWidth
|
|
|
|
-- | Maybe display a tickmark/checkmark icon
|
|
tickmarkCell :: IsDBTable m a => Bool -> DBCell m a
|
|
tickmarkCell = cell . toWidget . hasTickmark
|
|
|
|
-- | Maybe display an icon for tainted rows
|
|
isBadCell :: IsDBTable m a => Bool -> DBCell m a
|
|
isBadCell = cell . toWidget . isBad
|
|
|
|
-- | Maybe display a exclamation icon
|
|
isNewCell :: IsDBTable m a => Bool -> DBCell m a
|
|
isNewCell = cell . toWidget . isNew
|
|
|
|
-- | Maybe display comment icon linking a given URL or show nothing at all
|
|
commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
|
|
commentCell Nothing = mempty
|
|
commentCell (Just link) = anchorCell link $ hasComment True
|
|
|
|
-- | whether something is visible or hidden
|
|
isVisibleCell :: IsDBTable m a => Bool -> DBCell m a
|
|
isVisibleCell True = cell . toWidget $ isVisible True
|
|
isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
|
|
where
|
|
addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
|
|
|
|
-- | for simple file downloads
|
|
fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
|
|
fileCell route = anchorCell route iconFileDownload
|
|
|
|
-- | for zip-archive downloads
|
|
zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a
|
|
zipCell route = anchorCell route iconFileZip
|
|
|
|
-- | for csv downloads
|
|
csvCell :: IsDBTable m a => Route UniWorX -> DBCell m a
|
|
csvCell route = anchorCell route iconFileCSV
|
|
|
|
-- | Display an icon that opens a modal upon clicking
|
|
modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
|
|
modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content)
|
|
|
|
-----------------
|
|
-- Datatype cells
|
|
timeCell :: IsDBTable m a => UTCTime -> DBCell m a
|
|
timeCell t = cell $ formatTime SelFormatTime t >>= toWidget
|
|
|
|
dateCell :: IsDBTable m a => UTCTime -> DBCell m a
|
|
dateCell t = cell $ formatTime SelFormatDate t >>= toWidget
|
|
|
|
dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a
|
|
dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
|
|
|
|
-- | Show a date, and highlight date earlier than given watershed with an icon and cell class Warning
|
|
--
|
|
-- Cannot use `Handler.Utils.visibleUTCTime`, since setting the UrgencyClass must be done outside the monad, hence the watershed argument.
|
|
dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a
|
|
dateTimeCellVisible watershed t
|
|
| watershed < t = cell $(widgetFile "widgets/date-time/yet-invisible") & addUrgencyClass
|
|
| otherwise = cell timeStampWgt
|
|
where
|
|
timeStampWgt = formatTimeW SelFormatDateTime t
|
|
addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
|
|
|
|
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 email = cell $(widgetFile "widgets/link-email")
|
|
where linkText= toWgt 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
|
|
|
|
|
|
cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c
|
|
cellHasSemester = numCell . view _studyFeaturesSemester
|
|
|
|
|
|
cellHasField :: (IsDBTable m c, HasStudyTerms a) => a -> DBCell m c
|
|
cellHasField x = maybe (numCell $ x ^. _studyTermsKey) textCell $ x ^. _studyTermsName <|> x ^. _studyTermsShorthand
|
|
|
|
|
|
cellHasDegreeShort :: (IsDBTable m c, HasStudyDegree a) => a -> DBCell m c
|
|
cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _studyDegreeShorthand <|> x ^. _studyDegreeName
|
|
|
|
|
|
|
|
-- Just for documentation purposes; inline this code instead:
|
|
maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
|
|
maybeDateTimeCell = maybe mempty dateTimeCell
|
|
|
|
numCell :: (IsDBTable m a, ToMessage b) => b -> DBCell m a
|
|
numCell = textCell . toMessage
|
|
|
|
propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a
|
|
propCell curr max' = i18nCell $ MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
|
|
|
|
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 = toWgt tid
|
|
|
|
termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
|
|
termCellCL (tid,_,_) = termCell tid
|
|
|
|
schoolCell :: IsDBTable m a => TermId -> SchoolId -> DBCell m a
|
|
schoolCell tid ssh = anchorCell link name
|
|
where
|
|
link = TermSchoolCourseListR tid ssh
|
|
name = toWgt ssh
|
|
|
|
schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a
|
|
schoolCellCL (tid,ssh,_) = schoolCell 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 = toWgt 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 $ toWgt 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 = toWgt
|
|
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
|
|
|
|
occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a
|
|
occurrencesCell (normalizeOccurrences -> Occurrences{..}) = cell $ do
|
|
let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case
|
|
ScheduleWeekly{..} -> do
|
|
scheduleStart' <- formatTime SelFormatTime scheduleStart
|
|
scheduleEnd' <- formatTime SelFormatTime scheduleEnd
|
|
$(widgetFile "widgets/occurrence/cell/weekly")
|
|
occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case
|
|
ExceptOccur{..} -> do
|
|
exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
|
|
exceptEnd' <- formatTime SelFormatTime exceptStart
|
|
$(widgetFile "widgets/occurrence/cell/except-occur")
|
|
ExceptNoOccur{..} -> do
|
|
exceptTime' <- formatTime SelFormatDateTime exceptTime
|
|
$(widgetFile "widgets/occurrence/cell/except-no-occur")
|
|
$(widgetFile "widgets/occurrence/cell")
|