rigid type problem with rendermessage

src/Foundation.hs

@@ -253,6 +253,32 @@ instance RenderMessage UniWorX SheetType where
       mr :: RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
 
+instance RenderMessage UniWorX StudyDegree where
+  renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
+
+newtype ShortStudyDegree = ShortStudyDegree StudyDegree
+
+instance RenderMessage UniWorX ShortStudyDegree where
+  renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
+
+instance RenderMessage UniWorX StudyTerms where
+  renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
+
+newtype ShortStudyTerms = ShortStudyTerms StudyTerms
+
+instance RenderMessage UniWorX ShortStudyTerms where
+  renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand
+
+data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms
+
+instance RenderMessage UniWorX StudyDegreeTerm where
+  renderMessage foundation ls (StudyDegreeTerm deg trm) = (mr trm) <> " (" <> (mr $ ShortStudyDegree deg) <> ")"
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+
+
 newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
 embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
 

src/Handler/Utils/Form.hs

@@ -215,7 +215,6 @@ schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
 schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
 
 -- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user)
--- (too many special cases, hence not used in course registration anymore)
 studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
 studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
     -- we need a join, so we cannot just use optionsPersistCryptoId
@@ -226,7 +225,7 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
               E.||. isPrimaryActiveUserStudyFeature feature
         return (feature E.^. StudyFeaturesId, degree, field)
     mr <- getMessageRender
-    mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM procOptions rawOptions
+    mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM (procOptions mr) rawOptions
   where
     isPrimaryActiveUserStudyFeature feature = case mbuid of
       Nothing    -> E.val False
@@ -234,13 +233,11 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
               E.&&. feature E.^. StudyFeaturesValid E.==. E.val True
               E.&&. feature E.^. StudyFeaturesType  E.==. E.val FieldPrimary
 
-    procOptions :: (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
+    procOptions :: (RenderMessage UniWorX msg) =>  (msg -> Text) -> (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
-    procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do
+    procOptions mr (E.Value sfid, Entity dgid sdegree, Entity stid sterm) = do
-      let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName)
-          stname = fromMaybe (tshow stid) (studyTermsShorthand  <|> studyTermsName )
       cfid <- encrypt sfid
       return Option
-        { optionDisplay = stname <> " (" <> dgname <> ")"
+        { optionDisplay = mr $ StudyDegreeTerm sdegree sterm
         , optionInternalValue = Just sfid
         , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId)
         }

src/Model.hs

@@ -19,7 +19,6 @@ import Data.Aeson (Value)
 import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive.Instances ()
 
-import Text.Blaze (ToMarkup, toMarkup, Markup)
 import Utils.Message (MessageStatus)
 
 import Settings.Cluster (ClusterSettingsKey)
@@ -43,20 +42,3 @@ deriving instance Binary (Key Term)
 
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime
-
--- Do these instances belong here?
-instance ToMarkup StudyDegree where
-  toMarkup StudyDegree{..} = toMarkup $
-    fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
-
-shortStudyDegree :: StudyDegree -> Markup
-shortStudyDegree StudyDegree{..} = toMarkup $
-    fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
-
-instance ToMarkup StudyTerms where
-  toMarkup StudyTerms{..} = toMarkup $
-    fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
-
-shortStudyTerms :: StudyTerms -> Markup
-shortStudyTerms StudyTerms{..} = toMarkup $
-    fromMaybe (tshow studyTermsKey) studyTermsShorthand