Convenience New Term implemented

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}
 

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 =
+getTermEditR = do
-  -- TODO: Defaults für Semester hier ermitteln und übergeben
+  mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
-  termEditHandler Nothing
+  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 termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
-      <*> areq dayField  (fsl ("Erster Tag" :: Text)) (termStart <$> template)
+      <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
-      <*> areq dayField  (fsl ("Letzer Tag" :: Text)) (termEnd   <$> 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  (fslI MsgTermLectureStart) (tftLectureStart template)
-      <*> areq dayField  (fsl ("Ende Vorlesungen" :: Text)) (termLectureEnd   <$> template)
+      <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
-      <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (termActive <$> template)
+      <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (tftActive template)
       <*  submitButton
     return $ case result of
       FormSuccess termResult

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