chore(terms): switched to years

src/Handler/LMS/Userlist.hs

@@ -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

src/Model/Types/DateTime.hs

@@ -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.Parsec as Parse (choice, parse, string, try)
-import qualified Text.ParserCombinators.Parsec.Number as ParseNum (nat)
+-- 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
+termFromText t
-
+  | Just (review shortened -> year) <- readMaybe $ Text.unpack t
--- Option 1: date in iso8601, i.e. YYYY-MM-DD
+  = Right TermIdentifier {..}
-termToText1 :: TermIdentifier -> Text
+  | otherwise 
-termToText1 = Text.pack . iso8601Show
+  = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." 
-
+  
-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 <> "”"
-
 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{..} TermDayStart = fromWeekDate year weeknr wday -- Monday of first calendar week, might be within previous year
-guessDay TermIdentifier{..} TermDayLectureEnd   = addDays 8 getTermDay -- courses last only a week
+  where weeknr = 1 -- 1st ISO8601 week
-guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time 
+        wday    = 1 -- Monday
-  where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart
+guessDay t TermDayLectureStart =               guessDay t TermDayStart
-guessDay tid TermDayEnd   = fromWeekDate year week 7 -- Sunday after lecture time
+guessDay t TermDayEnd          = pred $ guessDay (succ t) TermDayStart
-  where ( year, week, _) = toWeekDate $ addDays (7*3) $ guessDay tid TermDayLectureEnd
+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

src/Utils/Icon.hs

@@ -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"
+    IconNew                          -> "seedling"
-    IconOK                      -> "check"
+    IconOK                           -> "check"
-    IconNotOK                   -> "times"
+    IconNotOK                        -> "times"
-    IconWarning                 -> "exclamation"
+    IconWarning                      -> "exclamation"
-    IconProblem                 -> "bolt"
+    IconProblem                      -> "bolt"
-    IconVisible                 -> "eye"
+    IconVisible                      -> "eye"
-    IconInvisible               -> "eye-slash"
+    IconInvisible                    -> "eye-slash"
-    IconCourse                  -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both
+    -- IconCourse                       -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both
-    IconCourseFavouriteManual   -> "star"
+    IconCourseFavouriteManual        -> "star"
-    IconCourseFavouriteAutomatic -> "star-half-alt"
+    IconCourseFavouriteAutomatic     -> "star-half-alt"
-    IconCourseFavouriteOff      -> "slash" -- TODO use FA regular style star for stacked icon
+    IconCourseFavouriteOff           -> "slash" -- TODO use FA regular style star for stacked icon
-    IconEnrolTrue               -> "user-plus"
+    IconEnrolTrue                    -> "user-plus"
-    IconEnrolFalse              -> "user-slash"
+    IconEnrolFalse                   -> "user-slash"
-    IconPlanned                 -> "cog"
+    IconPlanned                      -> "cog"
-    IconAnnounce                -> "bullhorn"
+    IconAnnounce                     -> "bullhorn"
-    IconExam                    -> "poll-h"
+    IconExam                         -> "poll-h"
-    IconExamRegisterTrue        -> "calendar-check"
+    IconExamRegisterTrue             -> "calendar-check"
-    IconExamRegisterFalse       -> "calendar-times"
+    IconExamRegisterFalse            -> "calendar-times"
-    IconExamAutoOccurrenceNudgeUp -> "user-plus"
+    IconExamAutoOccurrenceNudgeUp    -> "user-plus"
-    IconExamAutoOccurrenceNudgeDown -> "user-minus"
+    IconExamAutoOccurrenceNudgeDown  -> "user-minus"
-    IconExamAutoOccurrenceIgnore -> "users-slash"
+    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"

test/Database/Fill.hs

@@ -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          
+        gDay = addDays (7* weekOffset) $ guessDay gTid gTD          
-        utctDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay         
+        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
+  let tmin   = -1
-      tmax   = 29*6
+      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         
+         jtt = (((Just .) .) .) . termTime tid                  
-         weekDay = dayOfWeek $ getTermDay 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) . (<> "_")
+         mkName = CI.mk 
-    if weekDay `elem` [Friday, Saturday, Sunday] 
+    do 
-      then return ()
-      else do 
         c <- insert' Course
           { courseName = mkName "Vorfeldführerschein"
           , courseDescription = Just $ htmlToStoredMarkup [shamlet|