diff --git a/messages/uniworx/categories/I18n/de-de-formal.msg b/messages/uniworx/categories/I18n/de-de-formal.msg index e3300f6aa..37d97184e 100644 --- a/messages/uniworx/categories/I18n/de-de-formal.msg +++ b/messages/uniworx/categories/I18n/de-de-formal.msg @@ -1,11 +1,3 @@ -Quarter1st year@Integer: Erstes Quartal #{year} -Quarter2nd year@Integer: Zweites Quartal #{year} -Quarter3rd year@Integer: Drittes Quartal #{year} -Quarter4th year@Integer: Viertes Quartal #{year} -Quarter1stShort year@Integer: #{year}/Q1 -Quarter2ndShort year@Integer: #{year}/Q2 -Quarter3rdShort year@Integer: #{year}/Q3 -Quarter4thShort year@Integer: #{year}/Q4 CorByProportionOnly proportion@Rational: #{rationalToFixed3 proportion} Anteile CorByProportionIncludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile - Tutorium CorByProportionExcludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile + Tutorium diff --git a/messages/uniworx/categories/I18n/en-eu.msg b/messages/uniworx/categories/I18n/en-eu.msg index f18480470..e88bf6691 100644 --- a/messages/uniworx/categories/I18n/en-eu.msg +++ b/messages/uniworx/categories/I18n/en-eu.msg @@ -1,11 +1,3 @@ -Quarter1st year@Integer: First Quarter of #{year} -Quarter2nd year@Integer: Second Quarter of #{year} -Quarter3rd year@Integer: Third Quarter of #{year} -Quarter4th year@Integer: Last Quarter of #{year} -Quarter1stShort year@Integer: #{year}/Q1st -Quarter2ndShort year@Integer: #{year}/Q2nd -Quarter3rdShort year@Integer: #{year}/Q3rd -Quarter4thShort year@Integer: #{year}/Q4th CorByProportionOnly proportion: #{rationalToFixed3 proportion} parts CorByProportionIncludingTutorial proportion: #{rationalToFixed3 proportion} parts - tutorials CorByProportionExcludingTutorial proportion: #{rationalToFixed3 proportion} parts + tutorials diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 6f111b616..9378f3839 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -195,20 +195,10 @@ mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de" mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal" instance RenderMessage UniWorX TermIdentifier where - renderMessage foundation ls TermIdentifier{..} = case season of - Q1 -> renderMessage' $ MsgQuarter1st year - Q2 -> renderMessage' $ MsgQuarter2nd year - Q3 -> renderMessage' $ MsgQuarter3rd year - Q4 -> renderMessage' $ MsgQuarter4th year - where renderMessage' = renderMessage foundation ls + renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format instance RenderMessage UniWorX ShortTermIdentifier where - renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of - Q1 -> renderMessage' $ MsgQuarter1stShort year - Q2 -> renderMessage' $ MsgQuarter2ndShort year - Q3 -> renderMessage' $ MsgQuarter3rdShort year - Q4 -> renderMessage' $ MsgQuarter4thShort year - where renderMessage' = renderMessage foundation ls + renderMessage _foundation _ls (ShortTermIdentifier tid) = termToText tid -- TODO: implement shorttermidentifier properly instance RenderMessage UniWorX String where renderMessage f ls str = renderMessage f ls $ Text.pack str diff --git a/src/Handler/Allocation/Form.hs b/src/Handler/Allocation/Form.hs index 8b3ba800e..833d0464d 100644 --- a/src/Handler/Allocation/Form.hs +++ b/src/Handler/Allocation/Form.hs @@ -159,8 +159,7 @@ suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> ter newTerm <- MaybeT $ get tid Entity _ Allocation{..} <- MaybeT . getBy $ TermSchoolAllocationShort oldTid ssh ash - let dayOffset = (diffDays `on` termLectureStart) newTerm oldTerm - addTime = addLocalDays dayOffset + let addTime = addLocalDays $ (diffDays `on` termLectureStart) newTerm oldTerm return AllocationForm { afTerm = tid diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index c9a5e572d..b39286c65 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -435,7 +435,7 @@ getCourseNewR = do let newTemplate = courseToForm oldTemplate mempty mempty Nothing in return $ Just $ newTemplate { cfCourseId = Nothing - , cfTerm = TermKey $ TermIdentifier 0 Q1 -- invalid, will be ignored; undefined won't work due to strictness + , cfTerm = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness , cfRegFrom = Nothing , cfRegTo = Nothing , cfDeRegUntil = Nothing diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 45c820818..03b52a21f 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -25,8 +25,7 @@ import qualified Control.Monad.State.Class as State validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator TermForm m () validateTerm = do - TermForm{..} <- State.get - guardValidation MsgTermStartMustMatchName $ tfStart `withinTermYear` tfName + TermForm{..} <- State.get guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index c5f7324a4..ab7cf8bc7 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -12,11 +12,10 @@ module Model.Types.DateTime import Import.NoModel import qualified Data.Text as Text -import qualified Data.CaseInsensitive as CI import Data.Either.Combinators (maybeToRight) -import Text.Read (readMaybe) import Data.Time.Calendar.WeekDate +import Data.Time.Format.ISO8601 import Database.Persist.Sql @@ -26,45 +25,13 @@ import Data.Aeson.Types as Aeson ---- --- Terms, Seaons, anything loosely related to time +-- Terms and anything loosely related to time -data Season = Q1 | Q2 | Q3 | Q4 - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) - deriving anyclass (Binary, Universe, Finite, NFData) - -numSeasons :: Int -- to be flexible -numSeasons = succ $ fromEnum(maxBound::Season) - -seasonFromText' :: Text -> Either Text Season -seasonFromText' t = maybeToRight errmsg (readMaybe $ Text.unpack $ Text.toUpper t) - where - errmsg = "Invalid season: ‘" <> tshow t <> "’" - -seasonFromText :: Text -> Either Text Season -seasonFromText t - | Just (q, ne) <- Text.uncons t - , q ~= 'Q' - , Just (n, e) <- Text.uncons ne - , Text.null e = case n of '1' -> Right Q1 - '2' -> Right Q2 - '3' -> Right Q3 - '4' -> Right Q4 - _ -> Left $ "Invalid quarter number: ‘" <> tshow t <> "’" - | otherwise = Left $ "Invalid season: ‘" <> tshow t <> "’" - where - (~=) :: Char -> Char -> Bool - (~=) = (==) `on` CI.mk - -data TermIdentifier = TermIdentifier - { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' - , season :: Season - } deriving (Show, Read, Eq, Ord, Generic, Typeable) - deriving anyclass (Binary, NFData) - -instance Enum TermIdentifier where - -- ^ Do not use for conversion – Enumeration only - toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` numSeasons in TermIdentifier{..} - fromEnum TermIdentifier{..} = fromInteger year * numSeasons + fromEnum season +newtype TermIdentifier = TermIdentifier { tday :: Day } + deriving (Show, Read, Eq, Ord, Generic, Typeable, Enum) + deriving newtype (Binary, ISO8601) + deriving anyclass (NFData) + -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Typeable, Enum, Binary, NFData) -- Conversion TermId <-> TermIdentifier:: -- from_TermId_to_TermIdentifier = unTermKey @@ -94,32 +61,34 @@ shortened = iso shorten expand , year < $currentYear + 50 = year `mod` 100 | otherwise = year +-- Option 1: date in iso8601 termToText :: TermIdentifier -> Text -termToText TermIdentifier{..} = Text.pack $ show (year ^. shortened) ++ show season +termToText = Text.pack . iso8601Show -- also see Hander.Utils.tidFromText termFromText :: Text -> Either Text TermIdentifier -termFromText t - | (ys,s) <- Text.break (~= 'Q') t - , Right season <- seasonFromText s - , Just (review shortened -> year) <- readMaybe $ Text.unpack ys - = Right TermIdentifier{..} - | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number - where - (~=) :: Char -> Char -> Bool - (~=) = (==) `on` CI.mk +termFromText t = maybeToRight errm $ iso8601ParseM $ Text.unpack t + where + errm = "Invalid TermIdentifier: “" <> t <> "”" -termToRational :: TermIdentifier -> Rational -termToRational TermIdentifier{..} = toRational year + seasonOffset - where - seasonOffset = fromIntegral (fromEnum season) % fromIntegral numSeasons +-- Option 2: show as WeekNr-DayOfWeek-Year, e.g. 22Mon2021? + +daysPerYear :: Rational +daysPerYear = 365 + (97 % 400) + +dayOffset :: Rational +dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear) + where + dayzero = toEnum 0 + yearzero = fst3 $ toGregorian dayzero + diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 + +-- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . tday´´ holds +termToRational :: TermIdentifier -> Rational +termToRational = (dayOffset +) . (/ daysPerYear) . fromIntegral . fromEnum termFromRational :: Rational -> TermIdentifier -termFromRational n = TermIdentifier{..} - where - year = floor n - remainder = n - fromInteger (floor n) -- properFraction problematic for negative year values - season = toEnum $ floor $ remainder * fromIntegral numSeasons +termFromRational = toEnum . round . (daysPerYear *) . subtract dayOffset instance PersistField TermIdentifier where toPersistValue = PersistRational . termToRational @@ -162,26 +131,16 @@ data TermDay 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 TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter - where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayStart -guessDay tid TermDayLectureEnd = fromWeekDate year weekStart 5 -- Friday of last week within Quarter - where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd +guessDay TermIdentifier{..} TermDayLectureStart = tday +guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 tday -- courses last only a week +guessDay tid TermDayStart = fromWeekDate year weekStart 1 -- Monday before lecture time + where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureStart +guessDay tid TermDayEnd = fromWeekDate year weekStart 7 -- Sunday after lecture time + where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureEnd withinTerm :: Day -> TermIdentifier -> Bool 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 - timeYear = fst3 $ toGregorian time - termYear = year term - data OccurrenceSchedule = ScheduleWeekly { scheduleDayOfWeek :: WeekDay diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 7f4e705ed..7c606a858 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -46,20 +46,24 @@ import qualified Data.Text.Lazy as LT import Text.Blaze.Html.Renderer.Text (renderHtml) +{- +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31 + -- arbitrary = ModifiedJulianDay <$> choose (15020, 2973483) -- 1900-01-1 to 9999-12-31 + shrink day = let + (y, m, d) = toGregorian day + dayShrink = [fromGregorian y m (d - 1) | d > 1] + monthShrink = [fromGregorian y (m - 1) d | m > 1] + yearShrink = [fromGregorian (y - 1) m d | y > 2000] + in dayShrink ++ monthShrink ++ yearShrink - -instance Arbitrary Season where - arbitrary = genericArbitrary - shrink = genericShrink -instance CoArbitrary Season -instance Function Season +instance CoArbitrary Day where + coarbitrary (ModifiedJulianDay d) = coarbitrary d +-} instance Arbitrary TermIdentifier where - arbitrary = do - season <- arbitrary - year <- arbitrary `suchThat` (\y -> abs y >= 100) - return $ TermIdentifier{..} - shrink = filter ((\y -> abs y >= 100) . year) . genericShrink + arbitrary = TermIdentifier <$> arbitrary + shrink = fmap TermIdentifier . shrink . tday instance CoArbitrary TermIdentifier instance Function TermIdentifier @@ -460,14 +464,11 @@ spec = do describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ - \term -> termFromText (termToText term) == Right term - it "works for some examples" . mapM_ termExample $ - [ (TermIdentifier 2017 Q2, "17Q2") - , (TermIdentifier 1995 Q4, "95Q4") - , (TermIdentifier 3068 Q1, "3068Q1") - ] - it "has compatbile encoding/decoding to/from Rational" . property $ + \term -> termFromText (termToText term) == Right term + it "has compatible encoding/decoding to/from Rational" . property $ \term -> termFromRational (termToRational term) == term + it "has human readable year encoding to Rational" . property $ + \term -> truncate (termToRational term) == fst3 $ toGregorian $ tday term describe "Pseudonym" $ do it "has sufficient vocabulary" $ (length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym)))