chore(terms): switched to years
This commit is contained in:
Steffen Jost
parent
ac9590f27c
commit
88b22d50e8
@ -163,7 +163,7 @@ mkUserlistTable sid qsh qid = do
|
||||
, LmsUserlistTimestamp =. now
|
||||
]
|
||||
-- audit
|
||||
lift $ queueDBJob $ JobLmsUserlist qid
|
||||
lift . queueDBJob $ JobLmsUserlist qid
|
||||
return $ LmsUserlistR sid qsh
|
||||
dbtCsvRenderKey = const $ \case
|
||||
LmsUserlistInsertData{..} -> do -- TODO: i18n
|
||||
|
||||
@ -12,13 +12,14 @@ module Model.Types.DateTime
|
||||
import Import.NoModel
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import Data.Either.Combinators (maybeToRight, mapLeft)
|
||||
-- import Data.Either.Combinators (maybeToRight, mapLeft)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Data.Time.Calendar.WeekDate
|
||||
import Data.Time.Format.ISO8601
|
||||
-- import Data.Time.Format.ISO8601
|
||||
|
||||
import qualified Text.Parsec as Parse (choice, parse, string, try)
|
||||
import qualified Text.ParserCombinators.Parsec.Number as ParseNum (nat)
|
||||
-- import qualified Text.Parsec as Parse (choice, parse, string, try)
|
||||
-- import qualified Text.ParserCombinators.Parsec.Number as ParseNum (nat)
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
@ -30,12 +31,14 @@ import Data.Aeson.Types as Aeson
|
||||
----
|
||||
-- Terms and anything loosely related to time
|
||||
|
||||
newtype TermIdentifier = TermIdentifier { getTermDay :: Day }
|
||||
newtype TermIdentifier = TermIdentifier { year :: Integer } -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
|
||||
deriving (Show, Read, Eq, Ord, Generic, Typeable, Enum)
|
||||
deriving newtype (Binary, ISO8601, PersistField, PersistFieldSql)
|
||||
deriving newtype (Binary) -- , ISO8601, PersistField, PersistFieldSql) -- , ToJSON, FromJSON)
|
||||
deriving anyclass (NFData)
|
||||
-- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Typeable, Enum, Binary, NFData)
|
||||
|
||||
-- Note: Working Implementations for TermIdentifiers being single Days, half-years and quarters exits in git history
|
||||
|
||||
-- Conversion TermId <-> TermIdentifier::
|
||||
-- from_TermId_to_TermIdentifier = unTermKey
|
||||
-- from_TermIdentifier_to_TermId = TermKey
|
||||
@ -68,48 +71,16 @@ shortened = iso shorten expand
|
||||
-- Handler.Utils.Widget.tidFromText
|
||||
-- MsgTermPlaceHolder
|
||||
termToText :: TermIdentifier -> Text
|
||||
termToText = termToText1
|
||||
termToText TermIdentifier{..} = Text.pack . show $ year ^. shortened
|
||||
|
||||
termFromText :: Text -> Either Text TermIdentifier
|
||||
termFromText t = termFromText1 t <> termFromText2 t
|
||||
|
||||
-- Option 1: date in iso8601, i.e. YYYY-MM-DD
|
||||
termToText1 :: TermIdentifier -> Text
|
||||
termToText1 = Text.pack . iso8601Show
|
||||
|
||||
termFromText1 :: Text -> Either Text TermIdentifier
|
||||
termFromText1 t = maybeToRight errm $ iso8601ParseM $ Text.unpack t
|
||||
where
|
||||
errm = "Invalid TermIdentifier: “" <> t <> "”"
|
||||
|
||||
-- Option 2: show as WeekNr-DayOfWeek-Year, e.g. 22Mon2021?
|
||||
termToText2 :: TermIdentifier -> Text
|
||||
termToText2 TermIdentifier{..} = Text.pack $ show weeknr ++ wd ++ show year
|
||||
where
|
||||
wd = take 3 $ show $ dayOfWeek getTermDay
|
||||
(year,weeknr,_wd_) = toWeekDate getTermDay
|
||||
|
||||
termFromText2 :: Text -> Either Text TermIdentifier
|
||||
termFromText2 t = mapLeft (const errm) parseTerm
|
||||
where
|
||||
parseTerm = Parse.parse pWeekDate "termFromText2" $ Text.unpack t
|
||||
|
||||
-- pWeekDate :: Parse.Parsec String () TermIdentifier
|
||||
pWeekDate = do
|
||||
wknr <- ParseNum.nat
|
||||
dowk <- Parse.choice $ pDayOfWeek <$> (universe :: [DayOfWeek])
|
||||
year <- ParseNum.nat
|
||||
case fromWeekDateValid year wknr (fromEnum dowk) of
|
||||
(Just d) -> return $ TermIdentifier d
|
||||
Nothing -> fail "invalid weekdate"
|
||||
|
||||
-- pDayOfWeek :: DayOfWeek -> Parse.Parsec String () DayOfWeek
|
||||
pDayOfWeek wd = do
|
||||
void $ Parse.try $ Parse.string $ take 3 $ show wd
|
||||
return wd
|
||||
|
||||
errm = "Invalid TermIdentifier: “" <> t <> "”"
|
||||
|
||||
termFromText t
|
||||
| Just (review shortened -> year) <- readMaybe $ Text.unpack t
|
||||
= Right TermIdentifier {..}
|
||||
| otherwise
|
||||
= Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number."
|
||||
|
||||
|
||||
daysPerYear :: Rational
|
||||
daysPerYear = 365 + (97 % 400)
|
||||
|
||||
@ -122,20 +93,20 @@ dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear)
|
||||
|
||||
-- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds
|
||||
termToRational :: TermIdentifier -> Rational
|
||||
termToRational = (dayOffset +) . (/ daysPerYear) . fromIntegral . fromEnum
|
||||
termToRational = fromInteger . year
|
||||
|
||||
termFromRational :: Rational -> TermIdentifier
|
||||
termFromRational = toEnum . round . (daysPerYear *) . subtract dayOffset
|
||||
termFromRational = TermIdentifier . floor
|
||||
|
||||
|
||||
{- -- For newtype Day, PersistField instance can be derived automatically
|
||||
instance PersistField TermIdentifier where
|
||||
toPersistValue = PersistRational . termToRational
|
||||
fromPersistValue (PersistRational t) = Right $ termFromRational t
|
||||
fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
|
||||
|
||||
instance PersistFieldSql TermIdentifier where
|
||||
sqlType _ = SqlNumeric 9 5 -- total significant digits; significant digits after decimal point
|
||||
-}
|
||||
sqlType _ = SqlNumeric 4 0 -- total significant digits; significant digits after decimal point
|
||||
|
||||
|
||||
instance ToHttpApiData TermIdentifier where
|
||||
toUrlPiece = termToText
|
||||
@ -167,15 +138,17 @@ data TermDay
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
-- See Handler.Term.validateTerm for term specification
|
||||
guessDay :: TermIdentifier
|
||||
-> TermDay
|
||||
-> Day
|
||||
guessDay TermIdentifier{..} TermDayLectureStart = getTermDay
|
||||
guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 getTermDay -- courses last only a week
|
||||
guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time
|
||||
where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart
|
||||
guessDay tid TermDayEnd = fromWeekDate year week 7 -- Sunday after lecture time
|
||||
where ( year, week, _) = toWeekDate $ addDays (7*3) $ guessDay tid TermDayLectureEnd
|
||||
guessDay TermIdentifier{..} TermDayStart = fromWeekDate year weeknr wday -- Monday of first calendar week, might be within previous year
|
||||
where weeknr = 1 -- 1st ISO8601 week
|
||||
wday = 1 -- Monday
|
||||
guessDay t TermDayLectureStart = guessDay t TermDayStart
|
||||
guessDay t TermDayEnd = pred $ guessDay (succ t) TermDayStart
|
||||
guessDay t TermDayLectureEnd = pred $ pred $ guessDay t TermDayEnd -- Friday of last calendar week, no lectures on Saturday/Sunday
|
||||
|
||||
|
||||
withinTerm :: Day -> TermIdentifier -> Bool
|
||||
withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd
|
||||
|
||||
@ -36,7 +36,7 @@ data Icon
|
||||
| IconProblem
|
||||
| IconVisible
|
||||
| IconInvisible
|
||||
| IconCourse
|
||||
-- | IconCourse -- not used, IconMenuCourse is currently only used
|
||||
| IconCourseFavouriteManual | IconCourseFavouriteAutomatic | IconCourseFavouriteOff
|
||||
| IconEnrolTrue
|
||||
| IconEnrolFalse
|
||||
@ -109,27 +109,27 @@ data Icon
|
||||
|
||||
iconText :: Icon -> Text
|
||||
iconText = \case
|
||||
IconNew -> "seedling"
|
||||
IconOK -> "check"
|
||||
IconNotOK -> "times"
|
||||
IconWarning -> "exclamation"
|
||||
IconProblem -> "bolt"
|
||||
IconVisible -> "eye"
|
||||
IconInvisible -> "eye-slash"
|
||||
IconCourse -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both
|
||||
IconCourseFavouriteManual -> "star"
|
||||
IconCourseFavouriteAutomatic -> "star-half-alt"
|
||||
IconCourseFavouriteOff -> "slash" -- TODO use FA regular style star for stacked icon
|
||||
IconEnrolTrue -> "user-plus"
|
||||
IconEnrolFalse -> "user-slash"
|
||||
IconPlanned -> "cog"
|
||||
IconAnnounce -> "bullhorn"
|
||||
IconExam -> "poll-h"
|
||||
IconExamRegisterTrue -> "calendar-check"
|
||||
IconExamRegisterFalse -> "calendar-times"
|
||||
IconExamAutoOccurrenceNudgeUp -> "user-plus"
|
||||
IconExamAutoOccurrenceNudgeDown -> "user-minus"
|
||||
IconExamAutoOccurrenceIgnore -> "users-slash"
|
||||
IconNew -> "seedling"
|
||||
IconOK -> "check"
|
||||
IconNotOK -> "times"
|
||||
IconWarning -> "exclamation"
|
||||
IconProblem -> "bolt"
|
||||
IconVisible -> "eye"
|
||||
IconInvisible -> "eye-slash"
|
||||
-- IconCourse -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both
|
||||
IconCourseFavouriteManual -> "star"
|
||||
IconCourseFavouriteAutomatic -> "star-half-alt"
|
||||
IconCourseFavouriteOff -> "slash" -- TODO use FA regular style star for stacked icon
|
||||
IconEnrolTrue -> "user-plus"
|
||||
IconEnrolFalse -> "user-slash"
|
||||
IconPlanned -> "cog"
|
||||
IconAnnounce -> "bullhorn"
|
||||
IconExam -> "poll-h"
|
||||
IconExamRegisterTrue -> "calendar-check"
|
||||
IconExamRegisterFalse -> "calendar-times"
|
||||
IconExamAutoOccurrenceNudgeUp -> "user-plus"
|
||||
IconExamAutoOccurrenceNudgeDown -> "user-minus"
|
||||
IconExamAutoOccurrenceIgnore -> "users-slash"
|
||||
IconExamAutoOccurrenceReconsider -> "users"
|
||||
IconCommentTrue -> "comment-alt"
|
||||
IconCommentFalse -> "comment-alt-slash"
|
||||
@ -166,11 +166,11 @@ iconText = \case
|
||||
IconMenuLogout -> "sign-out-alt"
|
||||
IconBreadcrumbsHome -> "home"
|
||||
IconMenuExtra -> "ellipsis-h"
|
||||
IconMenuCourseList -> "graduation-cap" -- "award" "diploma" "file-certificate"
|
||||
IconMenuCourseList -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both
|
||||
IconMenuCorrections -> "check"
|
||||
IconMenuExams -> "poll-h"
|
||||
IconMenuAdmin -> "screwdriver"
|
||||
IconMenuLms -> "graduation-cap"
|
||||
IconMenuLms -> "graduation-cap" -- "award" "diploma" "file-certificate"
|
||||
IconPageActionPrimaryExpand -> "bars"
|
||||
IconPageActionSecondary -> "ellipsis-h"
|
||||
IconBreadcrumbSeparator -> "angle-right"
|
||||
|
||||
@ -62,20 +62,20 @@ fillDb = do
|
||||
insert' = fmap (either entityKey id) . insertBy
|
||||
|
||||
addBDays = addBusinessDays Fraport -- holiday area to use
|
||||
currentTerm = TermIdentifier $ utctDay now
|
||||
currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now
|
||||
-- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm
|
||||
nextTerm n = TermIdentifier $ addBDays n $ getTermDay currentTerm
|
||||
nextTerm n = toEnum . (+n) $ fromEnum currentTerm
|
||||
|
||||
termTime :: TermIdentifier -- ^ Term
|
||||
-> TermDay -- ^ Relative to which day?
|
||||
-> Integer -- ^ Business Days Offset from Start/End of Term
|
||||
-> Integer -- ^ Week offset from TermDayStart/End of Term (shuld be negative for TermDayEnd)
|
||||
-> Maybe WeekDay -- ^ Move to weekday
|
||||
-> (Day -> UTCTime) -- ^ Add time to day
|
||||
-> UTCTime
|
||||
termTime gTid gTD gOff mbWeekDay = ($ utctDay)
|
||||
termTime gTid gTD weekOffset mbWeekDay = ($ tDay)
|
||||
where
|
||||
gDay = addBDays gOff $ guessDay gTid gTD
|
||||
utctDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay
|
||||
gDay = addDays (7* weekOffset) $ guessDay gTid gTD
|
||||
tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay
|
||||
|
||||
gkleen <- insert User
|
||||
{ userIdent = "G.Kleen@campus.lmu.de"
|
||||
@ -385,8 +385,8 @@ fillDb = do
|
||||
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
|
||||
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
|
||||
|
||||
let tmin = -8
|
||||
tmax = 29*6
|
||||
let tmin = -1
|
||||
tmax = 2
|
||||
trange = [tmin..tmax]
|
||||
dmin = guessDay (nextTerm tmin) TermDayStart
|
||||
dmax = guessDay (nextTerm tmax) TermDayEnd
|
||||
@ -404,7 +404,7 @@ fillDb = do
|
||||
, termLectureEnd = guessDay tid TermDayLectureEnd
|
||||
}
|
||||
repsert tk term
|
||||
insert_ $ TermActive tk (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing
|
||||
insert_ $ TermActive tk (toMidnight $ termStart term) (Just . beforeMidnight $ termEnd term) Nothing
|
||||
return tk
|
||||
|
||||
ifiAuthorshipStatement <- insertAuthorshipStatement I18n
|
||||
@ -650,16 +650,14 @@ fillDb = do
|
||||
-- Fahrschule F
|
||||
forM_ terms $ \tk -> do
|
||||
let tid = unTermKey tk
|
||||
jtt = (((Just .) .) .) . termTime tid
|
||||
weekDay = dayOfWeek $ getTermDay tid
|
||||
jtt = (((Just .) .) .) . termTime tid
|
||||
firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight
|
||||
secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight
|
||||
weekDay = dayOfWeek firstDay
|
||||
-- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight
|
||||
capacity = Just 8
|
||||
mkName = CI.mk . (<> termToText2 tid) . (<> "_")
|
||||
if weekDay `elem` [Friday, Saturday, Sunday]
|
||||
then return ()
|
||||
else do
|
||||
mkName = CI.mk
|
||||
do
|
||||
c <- insert' Course
|
||||
{ courseName = mkName "Vorfeldführerschein"
|
||||
, courseDescription = Just $ htmlToStoredMarkup [shamlet|
|
||||
|
||||
Loading…
Reference in New Issue
Block a user