Two-digit years

messages/de.msg

@@ -12,7 +12,7 @@ DeRegUntil: Abmeldungen bis
 SummerTerm year@Integer: Sommersemester #{display year}
 WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
 SummerTermShort year@Integer: SoSe #{display year}
-WinterTermShort year@Integer: WiSe #{display year}/#{display $ succ year}
+WinterTermShort year@Integer: WiSe #{display year}/#{display $ mod (succ year) 100}
 PSLimitNonPositive: “pagesize” muss größer als null sein
 Page n@Int64: #{display n}
 

src/Foundation.hs

@@ -177,6 +177,15 @@ instance RenderMessage UniWorX TermIdentifier where
     Winter -> renderMessage' $ MsgWinterTerm year
     where renderMessage' = renderMessage foundation ls
 
+newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
+  deriving (Eq, Ord, Read, Show)
+
+instance RenderMessage UniWorX ShortTermIdentifier where
+  renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
+    Summer -> renderMessage' $ MsgSummerTermShort year
+    Winter -> renderMessage' $ MsgWinterTermShort year
+    where renderMessage' = renderMessage foundation ls
+
 instance RenderMessage UniWorX String where
   renderMessage f ls str = renderMessage f ls $ Text.pack str
 
@@ -657,7 +666,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb TermCurrentR           = return ("Aktuell"   , Just TermShowR)
   breadcrumb TermEditR              = return ("Neu"       , Just TermCurrentR)
   breadcrumb (TermEditExistR tid)   = return ("Editieren" , Just $ TermCourseListR tid)
-  breadcrumb (TermCourseListR term) = return (display term, Just TermShowR)
+  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
 
   breadcrumb  CourseListR                 = return ("Kurs"     , Just HomeR)
   breadcrumb  CourseNewR                  = return ("Neu"      , Just CourseListR)

src/Handler/Term.hs

@@ -44,7 +44,7 @@ getTermShowR = do
       let colonnadeTerms = widgetColonnade $ mconcat
             [ sortable Nothing "Kürzel" $
                 anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
-                            (\(Entity tid _, _) -> [whamlet|#{display tid}|])
+                            (\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|])
             , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
                 cell $ formatTime SelFormatDate termLectureStart >>= toWidget
             , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->

src/Model/Types.hs

@@ -14,6 +14,7 @@ module Model.Types where
 
 import ClassyPrelude
 import Utils
+import Control.Lens
 
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -204,17 +205,35 @@ data TermIdentifier = TermIdentifier
 -- from_TermId_to_TermIdentifier = unTermKey
 -- from_TermIdentifier_to_TermId = TermKey
 
-instance DisplayAble TermIdentifier where
+shortened :: Iso' Integer Integer
-  display = termToText
+shortened = iso shorten expand
+  where
+    century = ($currentYear `div` 100) * 100
+    expand year
+      | 0 <= year
+      , year < 100 = let
+          options = [ expanded | offset <- [-1, 0, 1]
+                               , let century' = century + offset * 100
+                                     expanded = century' + year
+                               , $currentYear - 50 <= expanded
+                               , expanded < $currentYear + 50
+                               ]
+          in case options of
+               [unique] -> unique
+               failed   -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
+      | otherwise = year
+    shorten year
+      | $currentYear - 50 <= year
+      , year < $currentYear + 50 = year `mod` 100
+      | otherwise = year
 
---TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls
 termToText :: TermIdentifier -> Text
-termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year
+termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
 
 termFromText :: Text -> Either Text TermIdentifier
 termFromText t
   | (s:ys) <- Text.unpack t
-  , Just year <- readMaybe ys
+  , Just (review shortened -> year) <- readMaybe ys
   , Right season <- seasonFromChar s
   = Right TermIdentifier{..}
   | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"

src/Utils/DateTime.hs

@@ -9,6 +9,7 @@
 module Utils.DateTime
   ( timeLocaleMap
   , TimeLocale(..)
+  , currentYear
   , module Data.Time.Zones
   , module Data.Time.Zones.TH
   ) where
@@ -55,3 +56,9 @@ timeLocaleMap extra@((_, defLocale):_) = do
     localeExp = lift <=< runIO . getLocale . Just
   
   letE [localeMap'] (varE localeMap)
+
+currentYear :: ExpQ
+currentYear = do
+  now <- runIO getCurrentTime
+  let (year, _, _) = toGregorian $ utctDay now
+  [e|year|]