diff --git a/messages/de.msg b/messages/de.msg index 2104013c8..8b271d82e 100644 --- a/messages/de.msg +++ b/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} diff --git a/src/Foundation.hs b/src/Foundation.hs index 51d839610..b8f8fe169 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 89547f436..20f12eaa3 100644 --- a/src/Handler/Term.hs +++ b/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{..},_) -> diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 2d62a610b..bf035c79c 100644 --- a/src/Model/Types.hs +++ b/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 - display = termToText +shortened :: Iso' Integer Integer +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 <> "”" diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 23c08df08..cb9135120 100644 --- a/src/Utils/DateTime.hs +++ b/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|]