diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 948febc54..2620ee83f 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -122,8 +122,7 @@ 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 = hasComment True +commentCell (Just link) = anchorCell link $ hasComment True -- | whether something is visible or hidden isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a @@ -134,11 +133,15 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass -- | for simple file downloads fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a -fileCell route = anchorCell route fileDownload +fileCell route = anchorCell route iconFileDownload -- | for zip-archive downloads zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a -zipCell route = anchorCell route zipDownload +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 @@ -197,11 +200,11 @@ 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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 4f6676899..ad436a996 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -285,7 +285,7 @@ instance Button UniWorX ButtonCsvMode where btnLabel BtnCsvExport = [whamlet| $newline never - #{iconCSV} + #{iconFileCSV} \ _{BtnCsvExport} |] btnLabel BtnCsvImport diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs index 48c419705..d4730efe6 100644 --- a/src/Language/Haskell/TH/Instances.hs +++ b/src/Language/Haskell/TH/Instances.hs @@ -7,8 +7,18 @@ module Language.Haskell.TH.Instances import Language.Haskell.TH import Language.Haskell.TH.Lift (deriveLift) import Data.Binary (Binary) - +import Data.Semigroup +import Data.Monoid () +import Control.Applicative instance Binary Loc deriveLift ''Loc + + +instance Semigroup (Q [Dec]) where + (<>) = liftA2 (<>) + +instance Monoid (Q [Dec]) where + mempty = pure mempty + mappend = (<>) diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 4a6c60a32..2f6e43200 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -171,10 +171,10 @@ instance PathPiece SheetFileType where fromPathPiece = finiteFromPathPiece sheetFile2markup :: SheetFileType -> Markup -sheetFile2markup SheetExercise = iconQuestion -sheetFile2markup SheetHint = iconHint -sheetFile2markup SheetSolution = iconSolution -sheetFile2markup SheetMarking = iconMarking +sheetFile2markup SheetExercise = iconSFTQuestion +sheetFile2markup SheetHint = iconSFTHint +sheetFile2markup SheetSolution = iconSFTSolution +sheetFile2markup SheetMarking = iconSFTMarking -- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a) -- partitionFileType' = groupMap diff --git a/src/Utils.hs b/src/Utils.hs index 7fbe88857..11db44ba0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,6 +23,7 @@ import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Route as Utils +import Utils.Icon as Utils import Utils.Message as Utils import Utils.Lang as Utils import Utils.Parameters as Utils @@ -79,9 +80,10 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) -{-# ANN choice ("HLint: ignore Use asum" :: String) #-} +{- # ANN choice ("HLint: ignore Use asum" :: String) # -} +$(iconShortcuts) -- declares constants for all known icons ----------- -- Yesod -- @@ -114,122 +116,6 @@ unsupportedAuthPredicate = do --- | A @Widget@ for any site; no language interpolation, etc. -type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) - => WidgetT site m () - - ------------ --- Icons -- ------------ - --- Create an icon from font-awesome without additional space -fontAwesomeIcon :: Text -> Markup -fontAwesomeIcon iconName = - [shamlet|$newline never - |] - --- We collect all used icons here for an overview. --- For consistency, some conditional icons are also provided, e.g. `isIvisble` - -iconQuestion :: Markup -iconQuestion = fontAwesomeIcon "question-circle" - -iconNew :: Markup -iconNew = fontAwesomeIcon "seedling" - -iconOK :: Markup -iconOK = fontAwesomeIcon "check" - -iconNotOK :: Markup -iconNotOK = fontAwesomeIcon "times" - -iconWarning :: Markup -iconWarning = fontAwesomeIcon "exclamation" - -iconProblem :: Markup -iconProblem = fontAwesomeIcon "bolt" - -iconHint :: Markup -iconHint = fontAwesomeIcon "life-ring" - --- Icons for Course -iconCourse :: Markup -iconCourse = fontAwesomeIcon "graduation-cap" - -iconExam :: Markup -iconExam = fontAwesomeIcon "file-invoice" - -iconEnrol :: Bool -> Markup -iconEnrol True = fontAwesomeIcon "user-plus" -iconEnrol False = fontAwesomeIcon "user-slash" - -iconExamRegister :: Bool -> Markup -iconExamRegister True = fontAwesomeIcon "calendar-check" -iconExamRegister False = fontAwesomeIcon "calendar-times" - - --- Icons for SheetFileType -iconSolution :: Markup -iconSolution =fontAwesomeIcon "exclamation-circle" - -iconMarking :: Markup -iconMarking = fontAwesomeIcon "check-circle" - -fileDownload :: Markup -fileDownload = fontAwesomeIcon "file-download" - -zipDownload :: Markup -zipDownload = fontAwesomeIcon "file-archive" - -iconCSV :: Markup -iconCSV = fontAwesomeIcon "file-csv" - - --- Generic Conditional icons - -isVisible :: Bool -> Markup --- ^ Display an icon that denotes that something™ is visible or invisible -isVisible True = fontAwesomeIcon "eye" -isVisible False = fontAwesomeIcon "eye-slash" --- --- For documentation on how to avoid these unneccessary functions --- we implement them here just once for the first icon: --- -isVisibleWidget :: Bool -> WidgetSiteless --- ^ Widget having an icon that denotes that something™ is visible or invisible -isVisibleWidget = toWidget . isVisible - -maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless --- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible -maybeIsVisibleWidget = toWidget . foldMap isVisible - --- Other _frequently_ used icons: -hasComment :: Bool -> Markup --- ^ Display an icon that denotes that something™ has a comment or not -hasComment True = fontAwesomeIcon "comment-alt" -hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free - -hasTickmark :: Bool -> Markup --- ^ Display an icon that denotes that something™ is okay -hasTickmark True = iconOK -hasTickmark False = mempty - -isBad :: Bool -> Markup --- ^ Display an icon that denotes that something™ is bad -isBad True = iconProblem -isBad False = mempty - -isNew :: Bool -> Markup -isNew True = iconNew -isNew False = mempty - -boolSymbol :: Bool -> Markup -boolSymbol True = iconOK -boolSymbol False = iconNotOK - - - --------------------- -- Text and String -- --------------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 865bba69f..09299e310 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,13 +1,22 @@ module Utils.Icon where +import ClassyPrelude.Yesod hiding (foldlM, Proxy) + +import Data.Universe +import Data.Char +import Utils.PathPiece +-- import Text.Hamlet +import Text.Blaze (Markup) +import Control.Lens +import Language.Haskell.TH +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Lift (deriveLift) +import Instances.TH.Lift () + -- | A @Widget@ for any site; no language interpolation, etc. type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) => WidgetT site m () -import Data.Universe -import Utils.PathPiece -import Text.Hamlet - ----------- -- Icons -- @@ -23,7 +32,7 @@ data Icon | IconWarning | IconProblem | IconVisible - | IconNotVisible + | IconInvisible | IconCourse | IconEnrolTrue | IconEnrolFalse @@ -49,7 +58,7 @@ iconText = \case IconWarning -> "exclamation" IconProblem -> "bolt" IconVisible -> "eye" - IconNotVisible -> "eye-slash" + IconInvisible -> "eye-slash" IconCourse -> "graduation-cap" IconEnrolTrue -> "user-plus" IconEnrolFalse -> "user-slash" @@ -57,7 +66,7 @@ iconText = \case IconExamRegisterTrue -> "calendar-check" IconExamRegisterFalse -> "calendar-times" IconCommentTrue -> "comment-alt" - IconCommentFalse -> "comment-slash" + IconCommentFalse -> "comment-slash" -- comment-alt-slash is not available for free IconFileDownload -> "file-download" IconFileZip -> "file-archive" IconFileCSV -> "file-csv" @@ -67,85 +76,74 @@ iconText = \case IconSFTMarking -> "check-circle" -- for SheetFileType only instance Universe Icon -instance Finte Icon +instance Finite Icon nullaryPathPiece ''Icon $ camelToPathPiece' 1 +deriveLift ''Icon -- Create an icon from font-awesome without additional space icon :: Icon -> Markup -icon iconName = +icon ic = let ict = iconText ic in [shamlet|$newline never - |] + |] - --- for compatibility and convenience +-- declare constats for all icons for compatibility and convenience +-- "IconCourse" generates "iconCourse = icon IconCourse" iconShortcuts :: Q [Dec] -iconShortcuts = forM universeF - (\ic -> - iname <- newName $ 'i' : (drop 1 $ show ic) - valD (varP iname) (normalB [|icon iname|]) - ) - -iconQuestion :: Markup -iconQuestion = icon IconQuestion - -iconNew :: Markup -iconNew = icon IconNew - -iconOK :: Markup -iconOK = icon IconOK - -iconNotOK :: Markup -iconNotOK = icon IconNotOK - -iconWarning :: Markup -iconWarning = icon IconWarning - -iconProblem :: Markup -iconProblem = icon IconProblem - -iconHint :: Markup -iconHint = icon - --- Icons for Course -iconCourse :: Markup -iconCourse = fontAwesomeIcon "graduation-cap" - -iconExam :: Markup -iconExam = fontAwesomeIcon "file-invoice" - -iconEnrol :: Bool -> Markup -iconEnrol True = fontAwesomeIcon "user-plus" -iconEnrol False = fontAwesomeIcon "user-slash" - -iconExamRegister :: Bool -> Markup -iconExamRegister True = fontAwesomeIcon "calendar-check" -iconExamRegister False = fontAwesomeIcon "calendar-times" +iconShortcuts = foldMap mkIcon (universeF :: [Icon]) + where + mkIcon :: Icon -> Q [Dec] + mkIcon ic = do + do + iname <- newName $ over (ix 0) Data.Char.toLower $ show ic + isig <- sigD iname [t|Markup|] + idef <- valD (varP iname) (normalB [|icon ic|]) [] + return $ [isig, idef] --- Icons for SheetFileType -iconSolution :: Markup -iconSolution =fontAwesomeIcon "exclamation-circle" - -iconMarking :: Markup -iconMarking = fontAwesomeIcon "check-circle" - -fileDownload :: Markup -fileDownload = fontAwesomeIcon "file-download" - -zipDownload :: Markup -zipDownload = fontAwesomeIcon "file-archive" - -iconCSV :: Markup -iconCSV = fontAwesomeIcon "file-csv" - - --- Generic Conditional icons +---------------------- +-- Conditional icons +-- +-- Some case are special, hence no Template Haskell here isVisible :: Bool -> Markup -- ^ Display an icon that denotes that something™ is visible or invisible -isVisible True = fontAwesomeIcon "eye" -isVisible False = fontAwesomeIcon "eye-slash" --- +isVisible True = icon IconVisible +isVisible False = icon IconInvisible + +hasComment :: Bool -> Markup +-- ^ Display an icon that denotes that something™ has a comment or not +hasComment True = icon IconCommentTrue +hasComment False = icon IconCommentFalse + +hasTickmark :: Bool -> Markup +-- ^ Maybe display an icon that denotes that something™ is okay +hasTickmark True = icon IconOK +hasTickmark False = mempty + +isBad :: Bool -> Markup +-- ^ Maybe display an icon that denotes that something™ is bad +isBad True = icon IconProblem +isBad False = mempty + +-- ^ Maybe display an icon that denotes that something™ is bad +isNew :: Bool -> Markup +isNew True = icon IconNew +isNew False = mempty + +boolSymbol :: Bool -> Markup +boolSymbol True = icon IconOK +boolSymbol False = icon IconNotOK + +iconEnrol :: Bool -> Markup +iconEnrol True = icon IconEnrolTrue +iconEnrol False = icon IconEnrolFalse + +iconExamRegister :: Bool -> Markup +iconExamRegister True = icon IconExamRegisterTrue +iconExamRegister False = icon IconExamRegisterTrue + + +---------------- -- For documentation on how to avoid these unneccessary functions -- we implement them here just once for the first icon: -- @@ -156,27 +154,3 @@ isVisibleWidget = toWidget . isVisible maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless -- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible maybeIsVisibleWidget = toWidget . foldMap isVisible - --- Other _frequently_ used icons: -hasComment :: Bool -> Markup --- ^ Display an icon that denotes that something™ has a comment or not -hasComment True = fontAwesomeIcon "comment-alt" -hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free - -hasTickmark :: Bool -> Markup --- ^ Display an icon that denotes that something™ is okay -hasTickmark True = iconOK -hasTickmark False = mempty - -isBad :: Bool -> Markup --- ^ Display an icon that denotes that something™ is bad -isBad True = iconProblem -isBad False = mempty - -isNew :: Bool -> Markup -isNew True = iconNew -isNew False = mempty - -boolSymbol :: Bool -> Markup -boolSymbol True = iconOK -boolSymbol False = iconNotOK diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 04dc41dcf..c4153b17d 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -47,6 +47,7 @@ instance Exception UnknownMessageStatus data Message = Message { messageStatus :: MessageStatus , messageContent :: Html + -- , messageIcon :: Maybe Icon } instance Eq Message where diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index e7d2a777b..188b76453 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -24,7 +24,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result $maybe desc <- examDescription
#{desc} - +
$if not examVisible @@ -84,7 +84,7 @@ $maybe desc <- examDescription $maybe registerWdgt <- registerWidget
_{MsgExamRegistration}
^{registerWdgt} - + $if not (null occurrences)
@@ -121,7 +121,7 @@ $if not (null occurrences) $if occurrenceAssignmentsShown $if registered - #{fontAwesomeIcon "check"} + #{iconOK} $if gradingShown && not (null parts)
@@ -148,7 +148,7 @@ $if gradingShown && not (null parts) $of Just (ExamAttended (Just ps)) #{showFixed True ps} $of Just (ExamAttended Nothing) - #{fontAwesomeIcon "check"} + #{iconOK} $of Just ExamNoShow _{MsgExamNoShow} $of Just ExamVoided