fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

refactor(schedule): split up types, implement btn class

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-29 14:31:53 +02:00
parent 02767b4c5b
commit d3afd526ed
6 changed files with 215 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
src/Handler/Schedule.hs
View File

@ -4,97 +4,54 @@ module Handler.Schedule
import Import import Import
--import qualified Data.Map as Map
--import qualified Data.Set as Set
import Handler.Utils.Form import Handler.Utils.Form
--import Utils.Form
-- TODO: move Utils.Schedule to Handler.Utils.Schedule? -- TODO: move Utils.Schedule to Handler.Utils.Schedule?
import Utils.Schedule.Types import Utils.Schedule.Types
import Utils.Schedule.Week 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 :: Handler Html
getScheduleR = postScheduleR getScheduleR = postScheduleR
postScheduleR = do postScheduleR = do
uid <- requireAuthId uid <- requireAuthId
-- mr <- getMessageRender -- mr <- getMessageRender
mView <- lookupGlobalGetParam GetScheduleView
mOffset <- lookupGlobalGetParam GetScheduleOffset
let 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
defaultScheduleOptions = ScheduleOptions defaultScheduleOptions = ScheduleOptions
{ scheduleView = ScheduleViewWeek { scheduleView = ScheduleViewWeek
, scheduleOffset = ScheduleOffsetNone , scheduleOffset = ScheduleOffsetNone
} }
-- TODO: lookup get param, if not present take default
currentScheduleView :: ScheduleView currentScheduleView :: ScheduleView
currentScheduleView = scheduleView defaultScheduleOptions currentScheduleView = fromMaybe (scheduleView defaultScheduleOptions) mView
-- TODO: lookup get param, if not present take default
currentScheduleOffset :: ScheduleOffset currentScheduleOffset :: ScheduleOffset
currentScheduleOffset = scheduleOffset defaultScheduleOptions currentScheduleOffset = fromMaybe (scheduleOffset defaultScheduleOptions) mOffset
offsetFromWeekBtn :: ButtonScheduleOffsetWeek -> ScheduleOffset offsetFromWeekBtn :: ButtonScheduleOffsetWeek -> ScheduleOffset
offsetFromWeekBtn BtnSOWCurrent = ScheduleOffsetNone offsetFromWeekBtn btn = case schedBtnOffset btn of
offsetFromWeekBtn btn = currentScheduleOffset `addOffsets` btnOffset where ScheduleOffsetNone -> ScheduleOffsetNone
btnOffset = case btn of offset -> currentScheduleOffset `addOffsets` offset
BtnSOWBackwardWeek -> ScheduleOffsetDays (-7)
BtnSOWBackwardDay -> ScheduleOffsetDays (-1)
BtnSOWForwardDay -> ScheduleOffsetDays 1
BtnSOWForwardWeek -> ScheduleOffsetDays 7
_ -> ScheduleOffsetNone
scheduleOptionsForm :: MForm (HandlerFor UniWorX) (FormResult ScheduleOptions, Widget) scheduleOptionsForm :: MForm (HandlerFor UniWorX) (FormResult ScheduleOptions, Widget)
scheduleOptionsForm = do scheduleOptionsForm = do
-- viewRess :: [FormResult (Maybe ScheduleView)]
(_viewRess, viewWidgets) <- fmap unzip . for (universeF :: [ScheduleView]) $ \sView -> (_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 , fsAttrs = if sView == currentScheduleView then [("disabled","")] else mempty
}) Nothing }) Nothing
-- TODO: choose offset button set according to viewRess -- TODO: choose offset button set according to viewRess
let
-- offsetRess :: [FormResult (Maybe ScheduleOffset)]
(_offsetRess, offsetWidgets) <- fmap unzip . for (universeF :: [ButtonScheduleOffsetWeek]) $ \sOffsetBtn -> (_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 , fsAttrs = if offsetFromWeekBtn sOffsetBtn == currentScheduleOffset then [("disabled","")] else mempty
}) Nothing }) Nothing
@ -115,3 +72,10 @@ postScheduleR = do
siteLayoutMsg MsgMenuSchedule $ do siteLayoutMsg MsgMenuSchedule $ do
setTitleI MsgMenuSchedule setTitleI MsgMenuSchedule
$(widgetFile "schedule") $(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'

1
src/Utils/Parameters.hs
View File

@ -22,6 +22,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData | GetDryRun data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData | GetDryRun
| GetScheduleView | GetScheduleOffset
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)

127
src/Utils/Schedule/Types.hs
View File

@ -1,20 +1,12 @@
module Utils.Schedule.Types module Utils.Schedule.Types
( ScheduleCourseEventInfo ( module Utils.Schedule.Types
, ScheduleTutorialInfo
, ScheduleExamOccurrenceInfo
, ScheduleExamOccurrenceJoinedInfo
, ScheduleEntry(..)
, ScheduleOptions(..)
, ScheduleView(..)
, ScheduleOffset(..)
, ButtonScheduleOffsetWeek(..)
) where ) where
import Import import Import
import Handler.Utils import Utils.Schedule.Types.ScheduleEntry as Utils.Schedule.Types
import Utils.Schedule.Types.ScheduleOptions as Utils.Schedule.Types
import Web.PathPieces (readFromPathPiece) import Utils.Schedule.Types.ButtonScheduleOffset as Utils.Schedule.Types
-- TODO: replace Info types with one joined type and fetch info in one single runDB -- 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 ScheduleTutorialInfo = (Entity Course, Entity Tutorial)
type ScheduleExamOccurrenceInfo = (Entity Course, Entity Exam, Entity ExamOccurrence) type ScheduleExamOccurrenceInfo = (Entity Course, Entity Exam, Entity ExamOccurrence)
type ScheduleExamOccurrenceJoinedInfo = (Entity Course, Entity Exam, NonEmpty (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

104
src/Utils/Schedule/Types/ButtonScheduleOffset.hs Normal file
View File

@ -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 )

28
src/Utils/Schedule/Types/ScheduleEntry.hs Normal file
View File

@ -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)

56
src/Utils/Schedule/Types/ScheduleOptions.hs Normal file
View File

@ -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