refactor: don't interpret during lookup

src/Handler/Course.hs

@@ -43,6 +43,7 @@ postCFavouriteR tid ssh csh = do
   runDB $ do
     -- Nothing means blacklist
     -- should never return FavouriteCurrent
+    -- Just (Maybe reason, blacklist, associated)
     currentReason <- storedFavouriteReason tid ssh csh muid
     -- TODO change stored reason in DB
     -- TODO participants can't remove favourite (only toggle between automatic/manual)?

src/Handler/Course/Show.hs

@@ -59,10 +59,11 @@ courseFavouriteToggleForm currentReason html
       (Just FavouriteManual) -> BtnCourseFavouriteToggleManual
       (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic
 
--- Nothing means blacklist
+-- (storedReason, isBlacklist, isAssociated)
 -- Will never return FavouriteCurrent
+-- Nothing if no entry for current user (e.g. not logged in)
 storedFavouriteReason :: (MonadIO m) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX)
-                        -> ReaderT SqlBackend m (Maybe FavouriteReason)
+                        -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool, Bool))
 storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
       E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
             E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
@@ -89,16 +90,20 @@ storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $
               E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
             E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
           isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
-
+          reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool), E.SqlExpr (E.Value Bool))
+          reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist, isAssociated)
+          {-
           reason :: E.SqlExpr (E.Value (Maybe FavouriteReason))
           reason = E.case_
               [ E.when_ isBlacklist E.then_ E.nothing,
                 E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
               ] (E.else_ . E.just $ E.coalesceDefault [courseFavourite E.?. CourseFavouriteReason] (E.val FavouriteVisited))
+          -}
       pure reason
   where
-    unValueFirst :: [E.Value (Maybe a)] -> Maybe a
+    unValueFirst :: [(E.Value (Maybe a), E.Value Bool, E.Value Bool)] -> Maybe (Maybe a, Bool, Bool)
-    unValueFirst = join . fmap E.unValue . listToMaybe
+    -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised
+    unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue . over _3 E.unValue) . listToMaybe
 
 -- TODO add toggle Manual favorite Icon here
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -106,7 +111,7 @@ getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
   muid <- maybeAuthPair
   now <- liftIO getCurrentTime
-  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason) <- runDB . maybeT notFound $ do
+  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason') <- runDB . maybeT notFound $ do
     [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
        <- lift . E.select . E.from $
          \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@@ -338,6 +343,13 @@ getCShowR tid ssh csh = do
   mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR
   mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
 
+  let favouriteReason = case favouriteReason' of
+        -- (reason, blacklist, associated)
+        (Just (_reason, _blacklist, True))  -> Just FavouriteParticipant
+        (Just (_reason, True, False))       -> Nothing
+        (Just (Just reason, False, False))  -> Just reason
+        (Just (Nothing, False, False))      -> Just FavouriteCurrent
+        Nothing                             -> Just FavouriteCurrent
   favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason
   let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) ->
         wrapForm favouriteToggleView def