Sheet: unpublished files marked with icon and class

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 ]

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}&nbsp;^{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

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

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

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)

templates/widgets/date-time/yet-invisible.hamlet

@@ -0,0 +1 @@
+^{timeStampWgt} #{isVisible False}