refactor(schedule): split up types, implement btn class
This commit is contained in:
Sarah Vaupel
parent
02767b4c5b
commit
d3afd526ed
@ -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'
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
104
src/Utils/Schedule/Types/ButtonScheduleOffset.hs
Normal file
104
src/Utils/Schedule/Types/ButtonScheduleOffset.hs
Normal 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
28
src/Utils/Schedule/Types/ScheduleEntry.hs
Normal 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
56
src/Utils/Schedule/Types/ScheduleOptions.hs
Normal 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
|
||||
Reference in New Issue
Block a user