chore: try out different toggle-button locations

src/Foundation/Instances.hs

@@ -10,7 +10,6 @@ module Foundation.Instances
 import Import.NoFoundation
 
 import qualified Data.Text as Text
-import qualified Data.List as List
 import Data.List (inits)
 
 import qualified Yesod.Core.Unsafe as Unsafe
@@ -28,6 +27,7 @@ import qualified Foundation.Yesod.StaticContent as UniWorX
 import qualified Foundation.Yesod.Persist as UniWorX
 import qualified Foundation.Yesod.Auth as UniWorX
 
+import Foundation.Instances.ButtonClass
 import Foundation.SiteLayout
 import Foundation.Type
 import Foundation.I18n
@@ -51,29 +51,6 @@ import qualified Data.CaseInsensitive as CI
 import qualified Database.Esqueleto as E
 
 
-data instance ButtonClass UniWorX
-  = BCIsButton
-  | BCDefault
-  | BCPrimary
-  | BCSuccess
-  | BCInfo
-  | BCWarning
-  | BCDanger
-  | BCLink
-  | BCMassInputAdd | BCMassInputDelete
-  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-  deriving anyclass (Universe, Finite)
-
-instance PathPiece (ButtonClass UniWorX) where
-  toPathPiece BCIsButton = "btn"
-  toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
-  fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
-
-instance Button UniWorX ButtonSubmit where
-  btnClasses BtnSubmit = [BCIsButton, BCPrimary]
-
-
-
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
 instance Yesod UniWorX where

src/Foundation/Instances/ButtonClass.hs

@@ -0,0 +1,33 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Foundation.Instances.ButtonClass (ButtonClass(..)) where
+
+import Import.NoFoundation
+
+import Utils.Form
+import Foundation.Type
+import qualified Data.List as List
+
+-- instance RenderMessage UniWorX ButtonSubmit
+import Foundation.I18n ()
+
+
+data instance ButtonClass UniWorX
+  = BCIsButton
+  | BCDefault
+  | BCPrimary
+  | BCSuccess
+  | BCInfo
+  | BCWarning
+  | BCDanger
+  | BCLink
+  | BCMassInputAdd | BCMassInputDelete
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+instance PathPiece (ButtonClass UniWorX) where
+  toPathPiece BCIsButton = "btn"
+  toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
+  fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
+
+instance Button UniWorX ButtonSubmit where
+  btnClasses BtnSubmit = [BCIsButton, BCPrimary]

src/Foundation/SiteLayout.hs

@@ -15,6 +15,7 @@ import Foundation.Routes
 import Foundation.Navigation
 import Foundation.I18n
 import Foundation.Yesod.Persist
+import Foundation.Instances.ButtonClass
 
 import Utils.SystemMessage
 import Utils.Form
@@ -37,6 +38,65 @@ import Text.Cassius (cassiusFile)
 import Text.Hamlet (hamletFile)
 import Data.FileEmbed (embedFile)
 
+-----------------------------------------------------------------------------------------
+-- copy&paste from Handler.Course.Show for now
+data CourseFavouriteToggleButton
+  = BtnCourseFavouriteToggleManual
+  | BtnCourseFavouriteToggleAutomatic
+  | BtnCourseFavouriteToggleOff
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe CourseFavouriteToggleButton
+instance Finite CourseFavouriteToggleButton
+
+nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4
+
+instance Button UniWorX CourseFavouriteToggleButton where
+  btnLabel BtnCourseFavouriteToggleManual
+    = toWidget $ icon2x IconCourseFavouriteManual
+  btnLabel BtnCourseFavouriteToggleAutomatic
+    = toWidget $ icon2x IconCourseFavouriteAutomatic
+  btnLabel BtnCourseFavouriteToggleOff
+    = toWidget $ iconStacked IconCourseFavouriteManual IconCourseFavouriteOff
+
+  btnClasses _ = [BCIsButton, BCLink]
+
+-- inspired by examAutoOccurrenceIgnoreRoomsForm
+courseFavouriteToggleForm :: Maybe FavouriteReason -> Form ()
+courseFavouriteToggleForm currentReason html
+  = over _1 void <$> identifyForm FIDCourseFavouriteToggle (buttonForm' [btn]) html
+  where
+    btn :: CourseFavouriteToggleButton
+    btn = case currentReason of
+      Nothing -> BtnCourseFavouriteToggleOff
+      (Just FavouriteVisited) -> BtnCourseFavouriteToggleAutomatic
+      (Just FavouriteParticipant) -> BtnCourseFavouriteToggleAutomatic
+      (Just FavouriteManual) -> BtnCourseFavouriteToggleManual
+      (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic
+
+-- (storedReason, isBlacklist, isAssociated)
+-- Will never return FavouriteCurrent
+-- Nothing if no entry for current user (e.g. not logged in)
+storedFavouriteReason :: (MonadIO m, BearerAuthSite UniWorX) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX)
+                        -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, 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)
+      E.where_ $  course E.^. CourseTerm E.==. E.val tid
+            E.&&. course E.^. CourseSchool E.==. E.val ssh
+            E.&&. course E.^. CourseShorthand E.==. E.val csh
+      E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
+      let isBlacklist = E.exists . E.from $ \courseNoFavourite ->
+              E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
+                   E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
+          reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool))
+          reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist)
+      pure reason
+  where
+    unValueFirst :: [(E.Value (Maybe a), E.Value Bool)] -> Maybe (Maybe a, Bool)
+    -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised
+    unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue) . listToMaybe
+---------------------------------------------------------------------------------------
+
 
 data MemcachedKeyFavourites
   = MemcachedKeyFavouriteQuickActions (TermId, SchoolId, CourseShorthand) AuthContext (NonEmpty Lang)
@@ -201,6 +261,30 @@ siteLayout' overrideHeading widget = do
            , maybe userDefaultTheme userTheme $ view _2 <$> muid
            )
 
+  --------------------------------------
+  muid <- maybeAuthPair
+  (currentReason', maybeRoute) <- case mcurrentRoute of
+    (Just (CourseR tid ssh csh _)) -> (, Just . SomeRoute $ CourseR tid ssh csh CFavouriteR) <$> runDB (storedFavouriteReason tid ssh csh muid)
+    _otherwise -> pure (Nothing, Nothing)
+  let currentReason = case currentReason' of
+        -- (reason, blacklist)
+        (Just (_reason, True))      -> Nothing
+        (Just (Just reason, False)) -> Just reason
+        (Just (Nothing, False))     -> Just FavouriteCurrent
+        Nothing                     -> Just FavouriteCurrent
+      showFavToggle :: FavouriteReason -> Bool
+      showFavToggle FavouriteCurrent = isJust muid
+      showFavToggle _favouriteReason = False
+  favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm currentReason
+  let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) ->
+        wrapForm favouriteToggleView def
+          { formAction   = maybeRoute
+          , formEncoding = favouriteToggleEncoding
+          , formSubmit   = FormNoSubmit
+          , formAttrs = [("class", "buttongroup buttongroup--inline")]
+          }
+  -------------------------------------
+
   let favouriteTerms :: [TermIdentifier]
       favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\((_, tid, _, _), _, _, _, _) -> Set.singleton $ unTermKey tid) favourites'
   

src/Handler/Course/Show.hs

@@ -338,12 +338,12 @@ getCShowR tid ssh csh = do
 
   let heading = [whamlet|
           $newline never
+          $if isJust muid
+            <span .button--favourite-toggle>
+              ^{favouriteToggleWgt} #
           ^{courseName course}
           $if not courseVisible && mayEdit
             \ #{iconInvisible}
-          $if isJust muid
-            <span .button--favourite-toggle>
-              ^{favouriteToggleWgt}
         |]
 
   siteLayout heading $ do