refactor(icons): only allow semantics icons from now on

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
 

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

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 = (<>)

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

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
-            <i .fas .fa-#{iconName}>|]
-
--- 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 --
 ---------------------

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
-            <i .fas .fa-#{iconText iconName}>|]
+           <i .fas .fa-#{ict}>|]
 
-
--- 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

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

templates/exam-show.hamlet

@@ -24,7 +24,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result
 $maybe desc <- examDescription
   <section>
     #{desc}
-  
+
 <section>
   <dl .deflist>
     $if not examVisible
@@ -84,7 +84,7 @@ $maybe desc <- examDescription
     $maybe registerWdgt <- registerWidget
       <dt .deflist__dt>_{MsgExamRegistration}
       <dd .deflist__dd>^{registerWdgt}
-    
+
 
 $if not (null occurrences)
   <section>
@@ -121,7 +121,7 @@ $if not (null occurrences)
             $if occurrenceAssignmentsShown
               <td .table__td>
                 $if registered
-                  #{fontAwesomeIcon "check"}
+                  #{iconOK}
 
 $if gradingShown && not (null parts)
   <section>
@@ -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