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 Text.Blaze (ToMarkup(..)) import Utils.Lens import Handler.Utils import Utils.Occurences 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 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 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 markCell :: (IsDBTable m a) => (a -> Bool) -> (a -> DBCell m a) -> a -> DBCell m a markCell condition normal x | condition x = normal x <> cell (isVisibleWidget False) | otherwise = normal x -- Recall: for line numbers, use dbRow --------------------- -- Icon cells -- | 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 icon where icon = toWidget $ hasComment True -- | 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 dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a dateTimeCellVisible watershed t = cell $ do tfw <- formatTime SelFormatDateTime t >>= toWidget icn <- bool mempty (toWidget $ isVisible False) $ watershed < t return $ tfw <> icn 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 -- 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, 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
^{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 occurencesCell :: IsDBTable m a => Occurences -> DBCell m a occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd $(widgetFile "widgets/occurence/cell/weekly") occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case ExceptOccur{..} -> do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptStart $(widgetFile "widgets/occurence/cell/except-occur") ExceptNoOccur{..} -> do exceptTime' <- formatTime SelFormatDateTime exceptTime $(widgetFile "widgets/occurence/cell/except-no-occur") $(widgetFile "widgets/occurence/cell")