From d3afd526ed8d7faaddc8d4c3c27ec34fe5b82bde Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sat, 29 Aug 2020 14:31:53 +0200 Subject: [PATCH] refactor(schedule): split up types, implement btn class --- src/Handler/Schedule.hs | 80 +++-------- src/Utils/Parameters.hs | 1 + src/Utils/Schedule/Types.hs | 127 +----------------- .../Schedule/Types/ButtonScheduleOffset.hs | 104 ++++++++++++++ src/Utils/Schedule/Types/ScheduleEntry.hs | 28 ++++ src/Utils/Schedule/Types/ScheduleOptions.hs | 56 ++++++++ 6 files changed, 215 insertions(+), 181 deletions(-) create mode 100644 src/Utils/Schedule/Types/ButtonScheduleOffset.hs create mode 100644 src/Utils/Schedule/Types/ScheduleEntry.hs create mode 100644 src/Utils/Schedule/Types/ScheduleOptions.hs diff --git a/src/Handler/Schedule.hs b/src/Handler/Schedule.hs index 36c1895df..fa9d85eb0 100644 --- a/src/Handler/Schedule.hs +++ b/src/Handler/Schedule.hs @@ -4,97 +4,54 @@ module Handler.Schedule import Import ---import qualified Data.Map as Map ---import qualified Data.Set as Set - import Handler.Utils.Form ---import Utils.Form -- TODO: move Utils.Schedule to Handler.Utils.Schedule? import Utils.Schedule.Types import Utils.Schedule.Week -data ScheduleGetParam = ScheduleGetView | ScheduleGetOffset - deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable) - -instance PathPiece ScheduleGetParam where - toPathPiece = (camelToPathPiece' 2) . tshow - fromPathPiece "view" = Just ScheduleGetView - fromPathPiece "offset" = Just ScheduleGetOffset - fromPathPiece _ = Nothing - - --- TODO: remove ---type ScheduleOffsetInfo = ( ScheduleOffset -- offset value --- , Icon -- button icon for display --- , Maybe UniWorXMessage -- message to display when hovering over the button --- ) - --- TODO: remove ---scheduleViewOffsets :: Map ScheduleView [ScheduleOffsetInfo] -- (Set ScheduleOffsetInfo) ---scheduleViewOffsets = Map.fromList $ -- (\(k,v) -> (k, Set.fromList v)) <$> --- [ ( ScheduleViewWeek --- , [ (ScheduleOffsetDays (-7), IconFastBackward, Just MsgScheduleOffsetWeekBackwardWeek) --- , (ScheduleOffsetDays (-1), IconBackward, Just MsgScheduleOffsetWeekBackwardDay ) --- , (ScheduleOffsetNone , IconCurrent, Just MsgScheduleOffsetWeekCurrent ) --- , (ScheduleOffsetDays 1 , IconForward, Just MsgScheduleOffsetWeekForwardDay ) --- , (ScheduleOffsetDays 7 , IconFastForward, Just MsgScheduleOffsetWeekForwardWeek ) --- ] --- ) --- ] - --- TODO: remove ---iconTooltipMessage :: Icon -> UniWorXMessage -> Widget ---iconTooltipMessage ico msg = iconTooltip [whamlet| _{msg} |] (Just ico) True - -addOffsets :: ScheduleOffset -> ScheduleOffset -> ScheduleOffset -addOffsets ScheduleOffsetNone offset = offset -addOffsets offset ScheduleOffsetNone = offset -addOffsets (ScheduleOffsetDays d) (ScheduleOffsetDays d') = ScheduleOffsetDays $ d + d' - - getScheduleR, postScheduleR :: Handler Html getScheduleR = postScheduleR postScheduleR = do uid <- requireAuthId -- mr <- getMessageRender + + mView <- lookupGlobalGetParam GetScheduleView + mOffset <- lookupGlobalGetParam GetScheduleOffset let - -- TODO: persist default schedule view (week, month, ...) in user settings, lookup default and choose schedule accordingly + -- TODO: persist default schedule view in user settings, lookup default and choose schedule accordingly + -- if mView == Nothing defaultScheduleOptions :: ScheduleOptions defaultScheduleOptions = ScheduleOptions { scheduleView = ScheduleViewWeek , scheduleOffset = ScheduleOffsetNone } - -- TODO: lookup get param, if not present take default currentScheduleView :: ScheduleView - currentScheduleView = scheduleView defaultScheduleOptions + currentScheduleView = fromMaybe (scheduleView defaultScheduleOptions) mView - -- TODO: lookup get param, if not present take default currentScheduleOffset :: ScheduleOffset - currentScheduleOffset = scheduleOffset defaultScheduleOptions + currentScheduleOffset = fromMaybe (scheduleOffset defaultScheduleOptions) mOffset offsetFromWeekBtn :: ButtonScheduleOffsetWeek -> ScheduleOffset - offsetFromWeekBtn BtnSOWCurrent = ScheduleOffsetNone - offsetFromWeekBtn btn = currentScheduleOffset `addOffsets` btnOffset where - btnOffset = case btn of - BtnSOWBackwardWeek -> ScheduleOffsetDays (-7) - BtnSOWBackwardDay -> ScheduleOffsetDays (-1) - BtnSOWForwardDay -> ScheduleOffsetDays 1 - BtnSOWForwardWeek -> ScheduleOffsetDays 7 - _ -> ScheduleOffsetNone + offsetFromWeekBtn btn = case schedBtnOffset btn of + ScheduleOffsetNone -> ScheduleOffsetNone + offset -> currentScheduleOffset `addOffsets` offset scheduleOptionsForm :: MForm (HandlerFor UniWorX) (FormResult ScheduleOptions, Widget) scheduleOptionsForm = do + -- viewRess :: [FormResult (Maybe ScheduleView)] (_viewRess, viewWidgets) <- fmap unzip . for (universeF :: [ScheduleView]) $ \sView -> - mopt (buttonField sView) ("" { fsName = Just $ toPathPiece ScheduleGetView + mopt (buttonField sView) ("" { fsName = Just $ toPathPiece GetScheduleView , fsAttrs = if sView == currentScheduleView then [("disabled","")] else mempty }) Nothing -- TODO: choose offset button set according to viewRess + let + -- offsetRess :: [FormResult (Maybe ScheduleOffset)] (_offsetRess, offsetWidgets) <- fmap unzip . for (universeF :: [ButtonScheduleOffsetWeek]) $ \sOffsetBtn -> - mopt (buttonField sOffsetBtn) ("" { fsName = Just $ toPathPiece ScheduleGetOffset + mopt (buttonField sOffsetBtn) ("" { fsName = Just $ toPathPiece GetScheduleOffset , fsAttrs = if offsetFromWeekBtn sOffsetBtn == currentScheduleOffset then [("disabled","")] else mempty }) Nothing @@ -115,3 +72,10 @@ postScheduleR = do siteLayoutMsg MsgMenuSchedule $ do setTitleI MsgMenuSchedule $(widgetFile "schedule") + + +-- | Join two ScheduleOffsets by addition +addOffsets :: ScheduleOffset -> ScheduleOffset -> ScheduleOffset +addOffsets ScheduleOffsetNone offset = offset +addOffsets offset ScheduleOffsetNone = offset +addOffsets (ScheduleOffsetDays d) (ScheduleOffsetDays d') = ScheduleOffsetDays $ d + d' diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index f056be9c6..dbe9c1cb4 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -22,6 +22,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..)) data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData | GetDryRun + | GetScheduleView | GetScheduleOffset deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index e22d596d3..ad5264167 100644 --- a/src/Utils/Schedule/Types.hs +++ b/src/Utils/Schedule/Types.hs @@ -1,20 +1,12 @@ module Utils.Schedule.Types - ( ScheduleCourseEventInfo - , ScheduleTutorialInfo - , ScheduleExamOccurrenceInfo - , ScheduleExamOccurrenceJoinedInfo - , ScheduleEntry(..) - , ScheduleOptions(..) - , ScheduleView(..) - , ScheduleOffset(..) - , ButtonScheduleOffsetWeek(..) + ( module Utils.Schedule.Types ) where import Import -import Handler.Utils - -import Web.PathPieces (readFromPathPiece) +import Utils.Schedule.Types.ScheduleEntry as Utils.Schedule.Types +import Utils.Schedule.Types.ScheduleOptions as Utils.Schedule.Types +import Utils.Schedule.Types.ButtonScheduleOffset as Utils.Schedule.Types -- TODO: replace Info types with one joined type and fetch info in one single runDB @@ -22,114 +14,3 @@ type ScheduleCourseEventInfo = (Entity Course, Entity CourseEvent) type ScheduleTutorialInfo = (Entity Course, Entity Tutorial) type ScheduleExamOccurrenceInfo = (Entity Course, Entity Exam, Entity ExamOccurrence) type ScheduleExamOccurrenceJoinedInfo = (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) - -data ScheduleEntry = ScheduleCourseEvent - { sceCourse :: Entity Course -- TODO: just course? - , sceType :: CourseEventType - , sceRoom :: CourseEventRoom - , sceOccurrence :: Either OccurrenceException OccurrenceSchedule - } - | ScheduleTutorial - { stCourse :: Entity Course - , stName :: TutorialName - , stType :: TutorialType - , stRoom :: Maybe Text -- TODO: introduce TutorialRoom type synonym - , stOccurrence :: Either OccurrenceException OccurrenceSchedule - } - | ScheduleExamOccurrence - { seoCourse :: Entity Course - , seoExamName :: ExamName - , seoRooms :: NonEmpty ExamOccurrenceRoom - , seoStart :: UTCTime - , seoEnd :: Maybe UTCTime - } - deriving (Generic, Typeable) - - -data ScheduleOptions = ScheduleOptions - { scheduleView :: ScheduleView - , scheduleOffset :: ScheduleOffset - } - deriving (Eq, Ord, Show, Read, Generic, Typeable) - - -data ScheduleView = ScheduleViewWeek - deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable) - -instance Bounded ScheduleView where - minBound = maxBound - maxBound = ScheduleViewWeek -instance Finite ScheduleView -instance Universe ScheduleView - -instance PathPiece ScheduleView where - toPathPiece = camelToPathPiece' 2 . tshow - fromPathPiece "week" = Just ScheduleViewWeek - fromPathPiece _ = Nothing - -instance Button UniWorX ScheduleView where - btnClasses ScheduleViewWeek = [BCIsButton, BCScheduleView] - btnLabel ScheduleViewWeek = [whamlet| _{MsgBtnScheduleViewWeek} |] - - -data ScheduleOffset = ScheduleOffsetNone - | ScheduleOffsetDays Int - -- | ScheduleOffsetMonths Int - deriving (Eq, Ord, Show, Read, Generic, Typeable) - -instance PathPiece ScheduleOffset where - toPathPiece ScheduleOffsetNone = "none" - toPathPiece (ScheduleOffsetDays d) = tshow d <> "d" - --toPathPiece (ScheduleOffsetMonths m) = tshow m <> "m" - fromPathPiece "none" = Just ScheduleOffsetNone - fromPathPiece t - | Just t' <- fromNullable t - , Just n <- readFromPathPiece (init t') = case last t' of - 'd' -> Just $ ScheduleOffsetDays n - --'m' -> Just $ ScheduleOffsetMonths n - _ -> Nothing - | otherwise = Nothing - -data ButtonScheduleOffsetWeek = BtnSOWBackwardWeek - | BtnSOWBackwardDay - | BtnSOWCurrent - | BtnSOWForwardDay - | BtnSOWForwardWeek - deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable) - -instance Bounded ButtonScheduleOffsetWeek where - minBound = BtnSOWBackwardWeek - maxBound = BtnSOWForwardWeek -instance Finite ButtonScheduleOffsetWeek -instance Universe ButtonScheduleOffsetWeek - -instance PathPiece ButtonScheduleOffsetWeek where - toPathPiece BtnSOWCurrent = toPathPiece ScheduleOffsetNone - toPathPiece btn = toPathPiece $ ScheduleOffsetDays d where - d = case btn of - BtnSOWBackwardWeek -> (-7) - BtnSOWBackwardDay -> (-1) - BtnSOWForwardDay -> 1 - BtnSOWForwardWeek -> 7 - _ -> 0 - fromPathPiece t = case (fromPathPiece :: Text -> Maybe ScheduleOffset) t of - Just ScheduleOffsetNone -> Just BtnSOWCurrent - Just (ScheduleOffsetDays d) -> case d of - (-7) -> Just BtnSOWBackwardWeek - (-1) -> Just BtnSOWBackwardDay - 0 -> Just BtnSOWCurrent - 1 -> Just BtnSOWForwardDay - 7 -> Just BtnSOWForwardWeek - _ -> Nothing - _ -> Nothing - -instance Button UniWorX ButtonScheduleOffsetWeek where - btnClasses = const [BCIsButton, BCScheduleOffset] - btnLabel btn = [whamlet| ^{iconTooltipMessage ico tip} |] where - (ico, tip) = case btn of - BtnSOWBackwardWeek -> (IconFastBackward , MsgScheduleOffsetWeekBackwardWeek) - BtnSOWBackwardDay -> (IconBackward , MsgScheduleOffsetWeekBackwardDay ) - BtnSOWCurrent -> (IconCurrent , MsgScheduleOffsetWeekCurrent ) - BtnSOWForwardDay -> (IconForward , MsgScheduleOffsetWeekForwardDay ) - BtnSOWForwardWeek -> (IconFastForward , MsgScheduleOffsetWeekForwardWeek ) - iconTooltipMessage i m = iconTooltip [whamlet| _{m} |] (Just i) True diff --git a/src/Utils/Schedule/Types/ButtonScheduleOffset.hs b/src/Utils/Schedule/Types/ButtonScheduleOffset.hs new file mode 100644 index 000000000..7da01d73e --- /dev/null +++ b/src/Utils/Schedule/Types/ButtonScheduleOffset.hs @@ -0,0 +1,104 @@ +module Utils.Schedule.Types.ButtonScheduleOffset + ( ButtonScheduleOffset + , schedOffsetBtn, schedBtnOffset, schedBtnContent + , ButtonScheduleOffsetWeek(..) + ) + +where + +import Import + +import Utils.Form + +import Utils.Schedule.Types.ScheduleOptions + + +class (PathPiece button, Button UniWorX button) => ButtonScheduleOffset button where + schedOffsetBtn :: ScheduleOffset -> Maybe button + schedBtnOffset :: button -> ScheduleOffset + schedBtnContent :: button -> Either UniWorXMessage (Icon, Maybe UniWorXMessage) + +--instance ButtonScheduleOffset button => PathPiece button where +-- toPathPiece = toPathPiece . schedBtnOffset +-- fromPathPiece t = case fromPathPiece t of +-- Just offset -> Just $ schedOffsetBtn offset +-- _ -> Nothing +-- +--instance ButtonScheduleOffset button => Button UniWorX button where +-- btnClasses = const [BCIsButton, BCScheduleOffset] +-- btnLabel btn = case schedBtnContent btn of +-- Right (ico, Just tip) -> [whamlet| ^{iconTooltipMessage ico tip} |] +-- Right (ico, Nothing ) -> [whamlet| ^{icon ico} |] +-- Left msg -> [whamlet| _{msg} |] +-- where +-- iconTooltipMessage ico tip = iconTooltip [whamlet| _{tip} |] (Just ico) True + + +data ButtonScheduleOffsetWeek = BtnSOWBackwardWeek + | BtnSOWBackwardDay + | BtnSOWCurrent + | BtnSOWForwardDay + | BtnSOWForwardWeek + deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable) + +instance Bounded ButtonScheduleOffsetWeek where + minBound = BtnSOWBackwardWeek + maxBound = BtnSOWForwardWeek +instance Finite ButtonScheduleOffsetWeek +instance Universe ButtonScheduleOffsetWeek + +instance PathPiece ButtonScheduleOffsetWeek where + toPathPiece BtnSOWCurrent = toPathPiece ScheduleOffsetNone + toPathPiece btn = toPathPiece $ ScheduleOffsetDays d where + d = case btn of + BtnSOWBackwardWeek -> (-7) + BtnSOWBackwardDay -> (-1) + BtnSOWForwardDay -> 1 + BtnSOWForwardWeek -> 7 + _ -> 0 + fromPathPiece t = case (fromPathPiece :: Text -> Maybe ScheduleOffset) t of + Just ScheduleOffsetNone -> Just BtnSOWCurrent + Just (ScheduleOffsetDays d) -> case d of + (-7) -> Just BtnSOWBackwardWeek + (-1) -> Just BtnSOWBackwardDay + 0 -> Just BtnSOWCurrent + 1 -> Just BtnSOWForwardDay + 7 -> Just BtnSOWForwardWeek + _ -> Nothing + _ -> Nothing + +instance Button UniWorX ButtonScheduleOffsetWeek where + btnClasses = const [BCIsButton, BCScheduleOffset] + btnLabel btn = [whamlet| ^{iconTooltipMessage ico tip} |] where + (ico, tip) = case btn of + BtnSOWBackwardWeek -> (IconFastBackward , MsgScheduleOffsetWeekBackwardWeek) + BtnSOWBackwardDay -> (IconBackward , MsgScheduleOffsetWeekBackwardDay ) + BtnSOWCurrent -> (IconCurrent , MsgScheduleOffsetWeekCurrent ) + BtnSOWForwardDay -> (IconForward , MsgScheduleOffsetWeekForwardDay ) + BtnSOWForwardWeek -> (IconFastForward , MsgScheduleOffsetWeekForwardWeek ) + iconTooltipMessage i m = iconTooltip [whamlet| _{m} |] (Just i) True + +instance ButtonScheduleOffset ButtonScheduleOffsetWeek where + schedOffsetBtn ScheduleOffsetNone = Just BtnSOWCurrent + schedOffsetBtn (ScheduleOffsetDays d) = case d of + (-7) -> Just BtnSOWBackwardWeek + (-1) -> Just BtnSOWBackwardDay + 0 -> Just BtnSOWCurrent + 1 -> Just BtnSOWForwardDay + 7 -> Just BtnSOWForwardWeek + _ -> Nothing + + schedBtnOffset BtnSOWCurrent = ScheduleOffsetNone + schedBtnOffset btn = ScheduleOffsetDays $ case btn of + BtnSOWBackwardWeek -> (-7) + BtnSOWBackwardDay -> (-1) + BtnSOWForwardDay -> 1 + BtnSOWForwardWeek -> 7 + _ -> 0 + + schedBtnContent btn = Right $ case btn of + BtnSOWBackwardWeek -> (IconFastBackward , Just MsgScheduleOffsetWeekBackwardWeek) + BtnSOWBackwardDay -> (IconBackward , Just MsgScheduleOffsetWeekBackwardDay ) + BtnSOWCurrent -> (IconCurrent , Just MsgScheduleOffsetWeekCurrent ) + BtnSOWForwardDay -> (IconForward , Just MsgScheduleOffsetWeekForwardDay ) + BtnSOWForwardWeek -> (IconFastForward , Just MsgScheduleOffsetWeekForwardWeek ) diff --git a/src/Utils/Schedule/Types/ScheduleEntry.hs b/src/Utils/Schedule/Types/ScheduleEntry.hs new file mode 100644 index 000000000..8f5ce59f3 --- /dev/null +++ b/src/Utils/Schedule/Types/ScheduleEntry.hs @@ -0,0 +1,28 @@ +module Utils.Schedule.Types.ScheduleEntry + ( ScheduleEntry(..) + ) where + +import Import + + +data ScheduleEntry = ScheduleCourseEvent + { sceCourse :: Entity Course -- TODO: just course? + , sceType :: CourseEventType + , sceRoom :: CourseEventRoom + , sceOccurrence :: Either OccurrenceException OccurrenceSchedule + } + | ScheduleTutorial + { stCourse :: Entity Course + , stName :: TutorialName + , stType :: TutorialType + , stRoom :: Maybe Text -- TODO: introduce TutorialRoom type synonym + , stOccurrence :: Either OccurrenceException OccurrenceSchedule + } + | ScheduleExamOccurrence + { seoCourse :: Entity Course + , seoExamName :: ExamName + , seoRooms :: NonEmpty ExamOccurrenceRoom + , seoStart :: UTCTime + , seoEnd :: Maybe UTCTime + } + deriving (Generic, Typeable) diff --git a/src/Utils/Schedule/Types/ScheduleOptions.hs b/src/Utils/Schedule/Types/ScheduleOptions.hs new file mode 100644 index 000000000..289ef3cb7 --- /dev/null +++ b/src/Utils/Schedule/Types/ScheduleOptions.hs @@ -0,0 +1,56 @@ +module Utils.Schedule.Types.ScheduleOptions + ( ScheduleOptions(..) + , ScheduleView(..) + , ScheduleOffset(..) + ) where + +import Import + +import Utils.Form + +import Web.PathPieces (readFromPathPiece) + + +data ScheduleOptions = ScheduleOptions + { scheduleView :: ScheduleView + , scheduleOffset :: ScheduleOffset + } + deriving (Eq, Ord, Show, Read, Generic, Typeable) + + +data ScheduleView = ScheduleViewWeek + deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable) + +instance Bounded ScheduleView where + minBound = maxBound + maxBound = ScheduleViewWeek +instance Finite ScheduleView +instance Universe ScheduleView + +instance PathPiece ScheduleView where + toPathPiece = camelToPathPiece' 2 . tshow + fromPathPiece "week" = Just ScheduleViewWeek + fromPathPiece _ = Nothing + +instance Button UniWorX ScheduleView where + btnClasses ScheduleViewWeek = [BCIsButton, BCScheduleView] + btnLabel ScheduleViewWeek = [whamlet| _{MsgBtnScheduleViewWeek} |] + + +data ScheduleOffset = ScheduleOffsetNone + | ScheduleOffsetDays Int + -- | ScheduleOffsetMonths Int + deriving (Eq, Ord, Show, Read, Generic, Typeable) + +instance PathPiece ScheduleOffset where + toPathPiece ScheduleOffsetNone = "none" + toPathPiece (ScheduleOffsetDays d) = tshow d <> "d" + --toPathPiece (ScheduleOffsetMonths m) = tshow m <> "m" + fromPathPiece "none" = Just ScheduleOffsetNone + fromPathPiece t + | Just t' <- fromNullable t + , Just n <- readFromPathPiece (init t') = case last t' of + 'd' -> Just $ ScheduleOffsetDays n + --'m' -> Just $ ScheduleOffsetMonths n + _ -> Nothing + | otherwise = Nothing