From 6182e9414395fbfba2c303d546f2eeaa48ca1801 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 May 2019 21:02:05 +0200 Subject: [PATCH] Sheet: unpublished files marked with icon and class --- src/Handler/Sheet.hs | 5 ++-- src/Handler/Utils/Table/Cells.hs | 18 ++++++------ src/Utils.hs | 2 +- src/Utils/Form.hs | 28 ++++++++++--------- src/Utils/Message.hs | 3 ++ .../widgets/date-time/yet-invisible.hamlet | 1 + 6 files changed, 33 insertions(+), 24 deletions(-) create mode 100644 templates/widgets/date-time/yet-invisible.hamlet diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5a9448177..6187c4580 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -296,6 +296,7 @@ instance Button UniWorX ButtonGeneratePseudonym where -- Show single sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do + now <- liftIO getCurrentTime Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn -- without Colonnade -- fileNameTypes <- runDB $ E.select $ E.from $ @@ -325,7 +326,7 @@ getSShowR tid ssh csh shn = do (str2widget fName) -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) -- , colFileModification (view _2) - , sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCell modified + , sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCellVisible now modified ] let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable @@ -763,7 +764,7 @@ getSCorrR tid ssh csh shn = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do update shid [ SheetAutoDistribute =. autoDistribute ] - + let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors deleteWhere [ SheetCorrectorSheet ==. shid ] diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 139d13dc6..e5906e993 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -54,9 +54,9 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell ( sqlCell act = mempty & cellContents .~ lift act -- | Highlight table cells with warning: Is not yet implemented in frontend. -markCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -markCell condition normal x - | condition x = normal x & cellAttrs <>~ [("class","urgency__warning")] ---TODO: handle existing classe akin to Form.addAttr/addClass +markCell :: (IsDBTable m a) => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) +markCell status condition normal x + | condition x = normal x & over cellAttrs (insertAttr "class" $ statusToUrgencyClass status) | otherwise = normal x ifCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a) @@ -102,12 +102,14 @@ 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 dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a -dateTimeCellVisible watershed t = cell $ do - let tfw = formatTimeW SelFormatDateTime t - icn :: Widget - icn = bool mempty (toWidget $ isVisible False) $ watershed < t - [whamlet|^{tfw} ^{icn}|] +dateTimeCellVisible watershed t + | watershed < t = cell $(widgetFile "widgets/date-time/yet-invisible") & addUrgencyClass + | otherwise = cell timeStampWgt + where + timeStampWgt = formatTimeW SelFormatDateTime t + addUrgencyClass = over cellAttrs $ insertAttr "class" $ statusToUrgencyClass Warning userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname diff --git a/src/Utils.hs b/src/Utils.hs index 4ca14e49c..7f85d43a7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -335,7 +335,7 @@ lastMaybe (_:t) = lastMaybe t lastMaybe' :: [a] -> Maybe a lastMaybe' l = fmap snd $ l ^? _Snoc - +-- | Merge two lists of attribures, also see `Utils.Form.insertAttrs` mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)] mergeAttrs = mergeAttrs' `on` sort where diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 862c204fb..b0b4413ac 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -82,23 +82,25 @@ fslpI lbl placeholder , fsAttrs = [("placeholder", placeholder)] } -addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site -addAttr attr valu fs = fs { fsAttrs = newAttrs $ fsAttrs fs } +-- | Merge/Add an attribute-value Pair to an existing list of such pairs. +-- If the attribute exists, the new valu will be prepended, separated by a single empty space +-- Also see `Utils.mergeAttrs` +insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] +insertAttr attr valu = aux where - newAttrs :: [(Text,Text)] -> [(Text,Text)] - newAttrs [] = [(attr, valu)] - newAttrs (p@(a,v) : t) + aux :: [(Text,Text)] -> [(Text,Text)] + aux [] = [(attr,valu)] + aux (p@(a,v) : t) | attr==a = (a, T.append valu $ cons ' ' v) : t - | otherwise = p : newAttrs t + | otherwise = p : aux t + +addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site +addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs } addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site -addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs } +addAttrs attr valus fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs } where - newAttrs :: [(Text, Text)] -> [(Text, Text)] - newAttrs [] = [(attr, T.intercalate " " valus)] - newAttrs (p@(a,v) : t) - | attr==a = ( a, T.intercalate " " $ v : valus ) : t - | otherwise = p : newAttrs t + valu = T.intercalate " " valus addPlaceholder :: Text -> FieldSettings site -> FieldSettings site addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : filter ((/= placeholderAttr) . fst) (fsAttrs fs) } @@ -352,7 +354,7 @@ autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosub -- | just Html for a Submit-Button submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO () submitButtonView = buttonView BtnSubmit - + buttonView :: forall site button. Button site button => button -> WidgetT site IO () buttonView btn = do let bField :: Field (HandlerT site IO) button diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 69ce9e45e..7a9e492bc 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -2,6 +2,7 @@ module Utils.Message ( MessageStatus(..) , UnknownMessageStatus(..) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget + , statusToUrgencyClass , Message(..) , messageI, messageIHamlet, messageFile, messageWidget ) where @@ -67,6 +68,8 @@ instance FromJSON Message where messageContent <- preEscapedText . sanitizeBalance <$> o .: "content" return Message{..} +statusToUrgencyClass :: MessageStatus -> Text +statusToUrgencyClass status = "urgency__" <> toPathPiece status addMessage :: MonadHandler m => MessageStatus -> Html -> m () addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) diff --git a/templates/widgets/date-time/yet-invisible.hamlet b/templates/widgets/date-time/yet-invisible.hamlet new file mode 100644 index 000000000..ea24583d5 --- /dev/null +++ b/templates/widgets/date-time/yet-invisible.hamlet @@ -0,0 +1 @@ +^{timeStampWgt} #{isVisible False} \ No newline at end of file