refactor(term): terms are now the day the lecture starts

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

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

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
+  renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format
-    Q1 -> renderMessage' $ MsgQuarter1st year
-    Q2 -> renderMessage' $ MsgQuarter2nd year
-    Q3 -> renderMessage' $ MsgQuarter3rd year
-    Q4 -> renderMessage' $ MsgQuarter4th year
-    where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX ShortTermIdentifier where
-  renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
+  renderMessage _foundation _ls (ShortTermIdentifier tid) = termToText tid -- TODO: implement shorttermidentifier properly
-    Q1 -> renderMessage' $ MsgQuarter1stShort year
-    Q2 -> renderMessage' $ MsgQuarter2ndShort year
-    Q3 -> renderMessage' $ MsgQuarter3rdShort year
-    Q4 -> renderMessage' $ MsgQuarter4thShort year
-    where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX String where
   renderMessage f ls str = renderMessage f ls $ Text.pack str

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
+  let addTime = addLocalDays $ (diffDays `on` termLectureStart) newTerm oldTerm      
-      addTime = addLocalDays dayOffset
 
   return AllocationForm
     { afTerm = tid

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

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
+  TermForm{..} <- State.get  
-  guardValidation MsgTermStartMustMatchName $ tfStart `withinTermYear` tfName
   guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
   guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
   guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart

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
+newtype TermIdentifier = TermIdentifier { tday :: Day }
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
+    deriving (Show, Read, Eq, Ord, Generic, Typeable, Enum)     
-  deriving anyclass (Binary, Universe, Finite, NFData)
+    deriving newtype (Binary, ISO8601)
-
+    deriving anyclass (NFData)
-numSeasons :: Int -- to be flexible
+    -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Typeable, Enum, Binary, NFData)
-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
 
 -- 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
+termFromText t = maybeToRight errm $ iso8601ParseM $ Text.unpack t
-  | (ys,s) <- Text.break (~= 'Q') t
+  where 
-  , Right season <- seasonFromText s
+      errm = "Invalid TermIdentifier: “" <> t <> "”"
-  , 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
 
-termToRational :: TermIdentifier -> Rational
+-- Option 2: show as WeekNr-DayOfWeek-Year, e.g. 22Mon2021?
-termToRational TermIdentifier{..} = toRational year + seasonOffset
+
-  where
+daysPerYear :: Rational
-    seasonOffset = fromIntegral (fromEnum season) % fromIntegral numSeasons
+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{..}
+termFromRational = toEnum . round . (daysPerYear *) . subtract dayOffset
-  where
-    year = floor n 
-    remainder = n - fromInteger (floor n)  -- properFraction problematic for negative year values 
-    season = toEnum $ floor $ remainder * fromIntegral numSeasons
 
 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{..} TermDayLectureStart =           tday
-guessDay TermIdentifier{ year, season = Q2 } TermDayStart  = fromGregorian year  4  1
+guessDay TermIdentifier{..} TermDayLectureEnd   = addDays 8 tday -- courses last only a week
-guessDay TermIdentifier{ year, season = Q3 } TermDayStart  = fromGregorian year  7  1
+guessDay tid TermDayStart = fromWeekDate year weekStart 1 -- Monday before lecture time 
-guessDay TermIdentifier{ year, season = Q4 } TermDayStart  = fromGregorian year 10  1
+  where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureStart
-guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart
+guessDay tid TermDayEnd   = fromWeekDate year weekStart 7 -- Sunday after lecture time
-guessDay tid TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter
+  where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureEnd
-  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
 
 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

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 CoArbitrary Day where
-instance Arbitrary Season where
+    coarbitrary (ModifiedJulianDay d) = coarbitrary d
-  arbitrary = genericArbitrary
+-}
-  shrink = genericShrink
-instance CoArbitrary Season
-instance Function Season
 
 instance Arbitrary TermIdentifier where
-  arbitrary = do
+  arbitrary = TermIdentifier <$> arbitrary    
-    season <- arbitrary
+  shrink = fmap TermIdentifier . shrink . tday 
-    year <- arbitrary `suchThat` (\y -> abs y >= 100)
-    return $ TermIdentifier{..}
-  shrink = filter ((\y -> abs y >= 100) . year) . genericShrink
 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
+      \term -> termFromText (termToText term) == Right term      
-    it "works for some examples" . mapM_ termExample $
+    it "has compatible encoding/decoding to/from Rational" . property $
-      [ (TermIdentifier 2017 Q2, "17Q2")
-      , (TermIdentifier 1995 Q4, "95Q4")
-      , (TermIdentifier 3068 Q1, "3068Q1")
-      ]
-    it "has compatbile 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)))