Replaced DisplayAble Text instance, started adding ToMarkup instances for keys, attempted adding interface for CryptoIDs (TODO)

src/Data/CryptoID/Instances.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.CryptoID.Instances
+  (
+  ) where
+
+-- import qualified Data.CryptoID as CID
+
+-- import Data.CaseInsensitive (CI)
+-- import qualified Data.CaseInsensitive as CI
+
+-- import Text.Blaze (ToMarkup(..))
+
+-- import ClassyPrelude
+
+-- TODO: markup instance for UUIDs
+-- instance ToMarkup c => ToMarkup (CID.CryptoID c s) where
+--   toMarkup = toMarkup . CID.ciphertext

src/Data/Maybe/Instances.hs

@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Maybe.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Text.Blaze (ToMarkup(..), string)
+
+instance ToMarkup a => ToMarkup (Maybe a) where
+  toMarkup Nothing  = string ""
+  toMarkup (Just x) = toMarkup x

src/Foundation.hs

@@ -91,15 +91,18 @@ import qualified Data.Aeson as JSON
 import Data.FileEmbed (embedFile)
 
 
+-- TODO: remove once CryptoID is an instance of ToMarkup
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => DisplayAble (E.CryptoID namespace (CI FilePath)) where
   display = toPathPiece
 
+-- TODO: remove
 instance DisplayAble TermId where
   display = termToText . unTermKey
 
+-- TODO: remove
 instance DisplayAble SchoolId where
   display = CI.original . unSchoolKey
 
@@ -215,6 +218,7 @@ maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text  -> Text
 maybeDisplay _      Nothing  _     = mempty
 maybeDisplay before (Just x) after = before <> (display x) <> after
 
+-- TODO: decouple from DisplayAble
 -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
 mkMessage "UniWorX" "messages/uniworx" "de"
 mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"

src/Handler/Corrections.hs

@@ -126,7 +126,7 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row ->
               ssh   = course ^. _4
               csh   = course ^. _2
               shn   = sheetName $ entityVal sheet
-          in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
+          in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|]
 
 colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $

src/Handler/Course.hs

@@ -53,7 +53,7 @@ colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colCourse = sortable (Just "course") (i18nCell MsgCourse)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
-              [whamlet|#{display courseName}|]
+              [whamlet|_{courseName}|]
 
 -- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 -- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
@@ -70,7 +70,7 @@ colDescription = sortable Nothing mempty
 colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
-            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
+            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]
 
 -- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 -- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
@@ -89,17 +89,17 @@ colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
 colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
-            anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
+            anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
 
 colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
-            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
+            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolName}|]
 
 colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
-            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
+            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
 
 colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)

src/Handler/Home.hs

@@ -33,14 +33,14 @@ homeOpenCourses = do
       colonnade = mconcat
         [ -- dbRow
           sortable (Just "term")   (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
-            textCell $ display $ courseTerm course
+            textCell $ display $ courseTerm course  -- TODO: ToText instance for Key Term
         , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
-            textCell $ display $ courseSchool course
+            textCell $ display $ courseSchool course  -- TODO: ToText instance
         , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
             let tid = courseTerm      course
                 ssh = courseSchool    course
                 csh = courseShorthand course
-            anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
+            anchorCell (CourseR tid ssh csh CShowR) (toWidget csh)
         , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
             cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
         ]
@@ -121,9 +121,9 @@ homeUpcomingSheets uid = do
         , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
             textCell $ display ssh
         , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
-            anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
+            anchorCell (CourseR tid ssh csh CShowR) (toWidget csh)
         , sortable (Just "sheet")  (i18nCell MsgSheet)  $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
-            anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
+            anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget shn)
         , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
             cell $ formatTime SelFormatDateTime deadline >>= toWidget
         , sortable (Just "done")   (i18nCell MsgDone)   $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->

src/Handler/Profile.hs

@@ -45,6 +45,7 @@ makeSettingForm template html = do
         <*> notificationForm (stgNotificationSettings <$> template)
     return (result, widget) -- no validation required here
   where
+    -- TODO: replace display
     themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
 --
 -- Version with proper grouping:

src/Handler/Sheet.hs

@@ -236,7 +236,7 @@ getSheetListR tid ssh csh = do
                     mkRoute = do
                       cid' <- mkCid
                       return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
-                in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
+                in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])  -- TODO: replace display
       , sortable (Just "rating") (i18nCell MsgRating)
           $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
             let stats = sheetTypeSum sheetType in -- for statistics over all shown rows

src/Handler/Users.hs

@@ -41,7 +41,7 @@ getUsersR = do
           (nameWidget userDisplayName userSurname)
       , sortable (Just "matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
           (AdminUserR <$> encrypt uid)
-          (toWidget . display $ userMatrikelnummer)
+          (toWgt userMatrikelnummer)
 --       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
 --           (AdminUserR <$> encrypt uid)
 --           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)

src/Handler/Utils/Table/Cells.hs

@@ -185,7 +185,7 @@ termCell :: IsDBTable m a => TermId -> DBCell m a
 termCell tid = anchorCell link name
   where
     link = TermCourseListR tid
-    name = text2widget $ display tid
+    name = toWgt tid
 
 termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
 termCellCL (tid,_,_) = termCell tid
@@ -194,11 +194,11 @@ 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
+    name = toWgt ssh
 schoolCell Nothing ssh  = anchorCell link name
   where
     link = SchoolShowR ssh
-    name = text2widget $ display ssh
+    name = toWgt ssh
 
 schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a
 schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh
@@ -207,7 +207,7 @@ 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
+    name = toWgt csh
 
 courseCell :: IsDBTable m a => Course -> DBCell m a
 courseCell Course{..} = anchorCell link name `mappend` desc
@@ -228,7 +228,7 @@ sheetCell crse shn =
       ssh = crse ^. _2
       csh = crse ^. _3
       link= CSheetR tid ssh csh shn SShowR
-  in anchorCell link $ display2widget shn
+  in anchorCell link $ toWgt shn
 
 submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
 submissionCell crse shn sid =
@@ -237,7 +237,7 @@ submissionCell crse shn sid =
       csh = crse ^. _3
       mkCid = encrypt sid
       mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
-      mkText      = display2widget
+      mkText      = display2widget  -- TODO: replace with toWgt once there is a ToMarkup instance for CryptoIDs
   in anchorCellM' mkCid mkRoute mkText
 
 correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a

src/Import/NoModel.hs

@@ -76,6 +76,8 @@ import Language.Haskell.TH.Instances as Import ()
 import Data.List.NonEmpty.Instances as Import ()
 import Data.NonNull.Instances as Import ()
 import Data.Monoid.Instances  as Import ()
+import Data.Maybe.Instances  as Import ()
+import Data.CryptoID.Instances  as Import ()
 import Data.Set.Instances     as Import ()
 import Data.HashMap.Strict.Instances as Import ()
 import Data.HashSet.Instances as Import ()

src/Model.hs

@@ -23,6 +23,9 @@ import Utils.Message (MessageStatus)
 
 import Settings.Cluster (ClusterSettingsKey)
 
+import Text.Blaze (ToMarkup(..))
+
+
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:
@@ -38,3 +41,17 @@ deriving instance Eq (Unique Tutorial)  -- instance Eq Tutorial
 
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime
+
+-- ToMarkup instances for displaying certain database primary keys
+-- TODO: work in progress, populate with more instances
+-- TODO: is there a better place for this?
+
+instance ToMarkup (Key School) where
+  toMarkup = toMarkup . unSchoolKey
+
+instance ToMarkup (Key Term) where
+  toMarkup = toMarkup . termToText . unTermKey
+
+-- TODO: unfinished
+-- instance ToMarkup (Key Submission) where
+--   toMarkup = toMarkup . unSubmissionKey

src/Utils.hs

@@ -251,12 +251,6 @@ class DisplayAble a where
   default display :: Show a => a -> Text
   display = pack . show
 
-instance DisplayAble Text where
-  display = id
-
--- instance DisplayAble String where
---   display = pack
-
 instance DisplayAble Int
 instance DisplayAble Int64
 instance DisplayAble Integer

templates/correction-user.hamlet

@@ -6,7 +6,7 @@
     $maybe Entity _ User{userDisplayName} <- corrector
       <tr .table__row>
         <th .table__th>_{MsgRatingBy}
-        <td .table__td>#{display userDisplayName}
+        <td .table__td>#{userDisplayName}
     $maybe time <- submissionRatingTime
       <tr .table__row>
         <th .table__th>_{MsgRatingTime}

templates/mail/submissionRated.hamlet

@@ -27,7 +27,7 @@ $newline never
         <dt>
           _{MsgRatingBy}
         <dd>
-          #{display userDisplayName}
+          #{userDisplayName}
       $maybe time <- submissionRatingTime'
         <dt>
           _{MsgRatingTime}

templates/profileData.hamlet

@@ -9,7 +9,7 @@
       <dt .deflist__dt> _{MsgEMail}
       <dd .deflist__dd> #{mailtoHtml userEmail}
       <dt .deflist__dt> _{MsgIdent}
-      <dd .deflist__dd> #{display userIdent}
+      <dd .deflist__dd> #{userIdent}
       <dt .deflist__dt> _{MsgLastLogin}
       <dd .deflist__dd>
         $maybe llogin <- lastLogin
@@ -23,7 +23,7 @@
           $forall (E.Value institute) <- admin_rights
             <li .list-ul__item>
               <a href=@{SchoolShowR $ SchoolKey institute}>
-                #{display institute}
+                #{institute}
     $if not $ null lecturer_rights
       <dt .deflist__dt>_{MsgLecturerFor}
       <dd .deflist__dd>
@@ -31,14 +31,14 @@
           $forall (E.Value institute) <- lecturer_rights
             <li .list-ul__item>
               <a href=@{SchoolShowR $ SchoolKey institute}>
-                #{display institute}
+                #{institute}
     $if not $ null lecture_corrector
       <dt .deflist__dt> Korrektor
       <dd .deflist__dd>
         <ul .list-ul>
           $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
             <li .list-ul__item>
-              <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
+              <a href=@{CourseR tid ssh csh CShowR}>#{tid}-#{ssh}-#{csh}
     $if not $ null studies
       <dt .deflist__dt> Studiengänge
       <dd .deflist__dd>
@@ -58,7 +58,7 @@
                 <td .table__td>_{field}#{notUsedT studyFeaturesField}
                 <td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
                 <td .table__td>_{studyFeaturesType}
-                <td .table__td>#{display studyFeaturesSemester}
+                <td .table__td>#{studyFeaturesSemester}
                 <td .table__td>#{hasTickmark studyFeaturesValid}
                 <td .table__td>^{formatTimeW SelFormatDateTime studyFeaturesUpdated}
 

templates/submission.hamlet

@@ -20,7 +20,7 @@ $maybe cID <- mcid
           $maybe name <- mbName
             <li>_{MsgEditedBy name time}
           $nothing
-            <li>#{display time}
+            <li>#{time}
 
   $if maySubmit
     <section>