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

fix(types): move term identifier start/end information to type definition; simplifies fill

Browse Source
This commit is contained in:
Steffen Jost 2021-09-22 13:36:05 +02:00
parent 9540f5ce0f
commit aeafe3118b
2 changed files with 28 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
src/Handler/Term.hs
View File

@ -19,37 +19,13 @@ import qualified Data.Set as Set
import qualified Control.Monad.State.Class as State import qualified Control.Monad.State.Class as State
import Data.Time.Calendar.WeekDate
data TermDay
= TermDayStart | TermDayEnd
| TermDayLectureStart | TermDayLectureEnd
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
guessDay :: TermIdentifier
-> TermDay
-> Day
guessDay TermIdentifier{ year, season = Q1 } TermDayStart = fromGregorian year 1 1
guessDay TermIdentifier{ year, season = Q1 } TermDayEnd = fromGregorian year 3 31
guessDay TermIdentifier{ year, season = Q2 } TermDayStart = fromGregorian year 4 1
guessDay TermIdentifier{ year, season = Q2 } TermDayEnd = fromGregorian year 6 30
guessDay TermIdentifier{ year, season = Q3 } TermDayStart = fromGregorian year 7 1
guessDay TermIdentifier{ year, season = Q3 } TermDayEnd = fromGregorian year 9 30
guessDay TermIdentifier{ year, season = Q4 } TermDayStart = fromGregorian year 10 1
guessDay TermIdentifier{ year, season = Q4 } TermDayEnd = fromGregorian year 12 31
guessDay tid@TermIdentifier{ year } TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter
where (_, weekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year } TermDayLectureEnd = fromWeekDate year weekStart 5 -- Friday of last week within Quarter
where (_, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd
validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX) validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> FormValidator TermForm m () => FormValidator TermForm m ()
validateTerm = do validateTerm = do
TermForm{..} <- State.get TermForm{..} <- State.get
guardValidation MsgTermStartMustMatchName $ tfStart `withinTerm` tfName guardValidation MsgTermStartMustMatchName $ tfStart `withinTermYear` tfName
guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart

28
src/Model/Types/DateTime.hs
View File

@ -16,6 +16,8 @@ import qualified Data.CaseInsensitive as CI
import Data.Either.Combinators (maybeToRight) import Data.Either.Combinators (maybeToRight)
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Data.Time.Calendar.WeekDate
import Database.Persist.Sql import Database.Persist.Sql
import Web.HttpApiData import Web.HttpApiData
@ -31,7 +33,7 @@ data Season = Q1 | Q2 | Q3 | Q4
deriving anyclass (Binary, Universe, Finite, NFData) deriving anyclass (Binary, Universe, Finite, NFData)
numSeasons :: Int -- to be flexible numSeasons :: Int -- to be flexible
numSeasons = fromEnum(maxBound::Season) numSeasons = succ $ fromEnum(maxBound::Season)
seasonFromText' :: Text -> Either Text Season seasonFromText' :: Text -> Either Text Season
seasonFromText' t = maybeToRight errmsg (readMaybe $ Text.unpack $ Text.toUpper t) seasonFromText' t = maybeToRight errmsg (readMaybe $ Text.unpack $ Text.toUpper t)
@ -159,9 +161,31 @@ pathPieceCsv ''TermIdentifier
See Handler.Utils.Form.termsField and termActiveField See Handler.Utils.Form.termsField and termActiveField
-} -}
data TermDay
= TermDayStart | TermDayEnd
| TermDayLectureStart | TermDayLectureEnd
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
guessDay :: TermIdentifier
-> TermDay
-> Day
guessDay TermIdentifier{ year, season = Q1 } TermDayStart = fromGregorian year 1 1
guessDay TermIdentifier{ year, season = Q2 } TermDayStart = fromGregorian year 4 1
guessDay TermIdentifier{ year, season = Q3 } TermDayStart = fromGregorian year 7 1
guessDay TermIdentifier{ year, season = Q4 } TermDayStart = fromGregorian year 10 1
guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart
guessDay tid@TermIdentifier{ year } TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter
where (_, weekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year } TermDayLectureEnd = fromWeekDate year weekStart 5 -- Friday of last week within Quarter
where (_, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd
withinTerm :: Day -> TermIdentifier -> Bool withinTerm :: Day -> TermIdentifier -> Bool
time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd
-- | Check only if last two digits within the year numbers match
withinTermYear :: Day -> TermIdentifier -> Bool
time `withinTermYear` term = timeYear `mod` 100 == termYear `mod` 100
where where
timeYear = fst3 $ toGregorian time timeYear = fst3 $ toGregorian time
termYear = year term termYear = year term