diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index be30c01cf..ce8245b9d 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -29,6 +29,16 @@ InvalidInput: Eingaben bitte korrigieren. Term: Semester TermPlaceholder: W/S + vierstellige Jahreszahl +TermStartDay: Erster Tag +TermStartDayTooltip: Üblicherweise immer 1.April oder 1.Oktober +TermEndDay: Letzter Tag +TermEndDayTooltip: Üblicherweise immer 30.September oder 31.März +TermLectureStart: Beginn Vorlesungen +TermLectureEnd: Ende Vorlesungen +TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen. +TermActive: Aktiv + + SchoolListHeading: Übersicht über verwaltete Institute SchoolHeading school@SchoolName: Übersicht #{display school} diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 0c778343b..0f9da91a8 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -10,6 +10,13 @@ import Yesod.Form.Bootstrap3 import qualified Database.Esqueleto as E +-- | Default start day of term for season, +-- @True@: start of term, @False@: end of term +defaultDay :: Bool -> Season -> Day +defaultDay True Winter = fromGregorian 2020 10 1 +defaultDay False Winter = fromGregorian 2020 3 31 +defaultDay True Summer = fromGregorian 2020 4 1 +defaultDay False Summer = fromGregorian 2020 9 30 validateTerm :: Term -> [Text] @@ -120,7 +127,7 @@ getTermShowR = do , FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool) ) , ( "course" - , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are + , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are [] -> E.val True :: E.SqlExpr (E.Value Bool) cshs -> E.exists . E.from $ \course -> E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId @@ -137,20 +144,32 @@ getTermShowR = do $(widgetFile "terms") getTermEditR :: Handler Html -getTermEditR = - -- TODO: Defaults für Semester hier ermitteln und übergeben - termEditHandler Nothing +getTermEditR = do + mbLastTerm <- runDB $ selectFirst [] [Desc TermName] + let template = case mbLastTerm of + Nothing -> mempty + (Just (Entity { entityVal=Term{..} })) -> let + ntid = succ termName + seas = season ntid + yr = year ntid + yr' = if seas == Summer then yr else succ yr + in mempty + { tftName = Just $ ntid + , tftStart = Just $ defaultDay True seas & setYear yr + , tftEnd = Just $ defaultDay False seas & setYear yr' + } + termEditHandler template postTermEditR :: Handler Html -postTermEditR = termEditHandler Nothing +postTermEditR = termEditHandler mempty getTermEditExistR :: TermId -> Handler Html getTermEditExistR tid = do term <- runDB $ get tid - termEditHandler term + termEditHandler $ termToTemplate term -termEditHandler :: Maybe Term -> Handler Html +termEditHandler :: TermFormTemplate -> Handler Html termEditHandler term = do ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term case result of @@ -172,17 +191,63 @@ termEditHandler term = do setTitleI MsgTermEditHeading $(widgetFile "formPage") -newTermForm :: Maybe Term -> Form Term +data TermFormTemplate = TermFormTemplate + { tftName :: Maybe TermIdentifier + , tftStart :: Maybe Day + , tftEnd :: Maybe Day + , tftHolidays :: Maybe [Day] + , tftLectureStart :: Maybe Day + , tftLectureEnd :: Maybe Day + , tftActive :: Maybe Bool + } + +-- | TermFormTemplates form a pointwise-left biased Semigroup +instance Semigroup TermFormTemplate where + left <> right = TermFormTemplate + { tftName = tftName left <|> tftName right + , tftStart = tftStart left <|> tftStart right + , tftEnd = tftEnd left <|> tftEnd right + , tftHolidays = tftHolidays left <|> tftHolidays right + , tftLectureStart = tftLectureStart left <|> tftLectureStart right + , tftLectureEnd = tftLectureEnd left <|> tftLectureEnd right + , tftActive = tftActive left <|> tftActive right + } + +instance Monoid TermFormTemplate where + mappend = (<>) + mempty = TermFormTemplate + { tftName = Nothing + , tftStart = Nothing + , tftEnd = Nothing + , tftHolidays = Nothing + , tftLectureStart = Nothing + , tftLectureEnd = Nothing + , tftActive = Nothing + } + +termToTemplate ::Maybe Term -> TermFormTemplate +termToTemplate Nothing = mempty +termToTemplate (Just Term{..}) = TermFormTemplate + { tftName = Just termName + , tftStart = Just termStart + , tftEnd = Just termEnd + , tftHolidays = Just termHolidays + , tftLectureStart = Just termLectureStart + , tftLectureEnd = Just termLectureEnd + , tftActive = Just termActive + } + +newTermForm :: TermFormTemplate -> Form Term newTermForm template html = do mr <- getMessageRender (result, widget) <- flip (renderAForm FormStandard) html $ Term - <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (termName <$> template) - <*> areq dayField (fsl ("Erster Tag" :: Text)) (termStart <$> template) - <*> areq dayField (fsl ("Letzer Tag" :: Text)) (termEnd <$> template) + <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template) + <*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template) + <*> areq dayField (fslI MsgTermEndDay & setTooltip MsgTermEndDayTooltip) (tftEnd template) <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined - <*> areq dayField (fsl "Beginn Vorlesungen") (termLectureStart <$> template) - <*> areq dayField (fsl ("Ende Vorlesungen" :: Text)) (termLectureEnd <$> template) - <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (termActive <$> template) + <*> areq dayField (fslI MsgTermLectureStart) (tftLectureStart template) + <*> areq dayField (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template) + <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (tftActive template) <* submitButton return $ case result of FormSuccess termResult diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 6e4bbb027..1d31051fa 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -7,6 +7,7 @@ module Handler.Utils.DateTime , formatTimeMail , addOneWeek, addWeeks , weekDiff, weeksToAdd + , setYear ) where import Import @@ -21,6 +22,7 @@ import qualified Data.Time.Format as Time import Data.Set (Set) import qualified Data.Set as Set + utcToLocalTime :: UTCTime -> LocalTime utcToLocalTime = TZ.utcToLocalTimeTZ appTZ @@ -161,4 +163,7 @@ weeksToAdd old new = loop 0 old | otherwise = loop (succ n) (addOneWeek t) --- addOneTerm? -> Move Handler.Utils.DateTime +setYear :: Integer -> Day -> Day +setYear year date = fromGregorian year month day + where + (_,month,day) = toGregorian date \ No newline at end of file