refactor(term): terms are now the day the lecture starts
This commit is contained in:
Steffen Jost
parent
426af0f183
commit
6728106cd5
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user