Improve term creation/editing

messages/uniworx/de.msg

@@ -44,6 +44,7 @@ TermStartDay: Erster Tag
 TermStartDayTooltip: Üblicherweise immer 1.April oder 1.Oktober
 TermEndDay: Letzter Tag
 TermEndDayTooltip: Üblicherweise immer 30.September oder 31.März
+TermHolidays: Feiertage
 TermLectureStart: Beginn Vorlesungen
 TermLectureEnd: Ende Vorlesungen
 TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen.

routes

@@ -59,7 +59,7 @@
 /term                      TermShowR         GET             !free
 /term/current              TermCurrentR      GET             !free
 /term/edit                 TermEditR         GET POST
-/term/#TermId/edit         TermEditExistR    GET
+/term/#TermId/edit         TermEditExistR    GET POST
 !/term/#TermId             TermCourseListR   GET             !free
 !/term/#TermId/#SchoolId   TermSchoolCourseListR  GET        !free
 

src/Handler/Course.hs

@@ -636,9 +636,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
         miDelete :: ListLength   -- ^ Current shape
                  -> ListPosition -- ^ Coordinate to delete
                  -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
-        miDelete l pos
-          | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
-          | otherwise = return Map.empty
+        miDelete = miDeleteList
 
         miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
         miAllowAdd _ _ _ = True

src/Handler/Term.hs

@@ -3,14 +3,16 @@ module Handler.Term where
 import Import
 import Handler.Utils
 import Handler.Utils.Table.Cells
+import Handler.Utils.Form.MassInput
 import qualified Data.Map as Map
 
--- import qualified Data.Text as T
-import Yesod.Form.Bootstrap3
--- import Colonnade hiding (bool)
+import Utils.Lens
 
 import qualified Database.Esqueleto as E
 
+import qualified Data.Set as Set
+  
+
 -- | Default start day of term for season,
 --   @True@: start of term, @False@: end of term
 defaultDay :: Bool -> Season -> Day
@@ -148,7 +150,7 @@ getTermShowR = do
         setTitleI MsgTermsHeading
         $(widgetFile "terms")
 
-getTermEditR :: Handler Html
+getTermEditR, postTermEditR :: Handler Html
 getTermEditR = do
   mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
   let template = case mbLastTerm of
@@ -164,18 +166,18 @@ getTermEditR = do
               , tftEnd   = Just $ defaultDay False seas & setYear yr'
               }
   termEditHandler template
-
-postTermEditR :: Handler Html
 postTermEditR = termEditHandler mempty
 
-getTermEditExistR :: TermId -> Handler Html
-getTermEditExistR tid = do
+getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
+getTermEditExistR = postTermEditExistR
+postTermEditExistR tid = do
   term <- runDB $ get tid
   termEditHandler $ termToTemplate term
 
 
 termEditHandler :: TermFormTemplate -> Handler Html
 termEditHandler term = do
+    Just eHandler <- getCurrentRoute
     ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
     case result of
       (FormSuccess res) -> do
@@ -194,7 +196,7 @@ termEditHandler term = do
     defaultLayout $ do
       setTitleI MsgTermEditHeading
       wrapForm formWidget def
-        { formAction = Just $ SomeRoute TermEditR
+        { formAction = Just $ SomeRoute eHandler
         , formEncoding = formEnctype
         }
 
@@ -247,14 +249,21 @@ termToTemplate (Just Term{..}) = TermFormTemplate
 newTermForm :: TermFormTemplate -> Form Term
 newTermForm template html = do
     mr <- getMessageRender
+    let
+      tidForm
+        | Just tid <- tftName template
+        = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
+        | otherwise
+        = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
+      holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (\_ -> "") (\_ -> Nothing) (fslI MsgTermHolidays) True (tftHolidays template) mempty
     (result, widget) <- flip (renderAForm FormStandard) html $ Term
-      <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
+      <$> tidForm
       <*> 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
+      <*> (Set.toList . Set.fromList <$> holidayForm)
       <*> areq dayField  (fslI MsgTermLectureStart) (tftLectureStart template)
       <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
-      <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (tftActive template)
+      <*> areq checkBoxField (fslI MsgTermActive) (tftActive template)
     return $ case result of
       FormSuccess termResult
         | errorMsgs <- validateTerm termResult

src/Handler/Utils/Form/MassInput.hs

@@ -3,10 +3,11 @@
 module Handler.Utils.Form.MassInput
   ( MassInput(..)
   , massInput
+  , massInputList
   , BoxDimension(..)
   , IsBoxCoord(..), boxDimension
   , Liveliness(..)
-  , ListLength(..), ListPosition(..)
+  , ListLength(..), ListPosition(..), miDeleteList
   ) where
 
 import Import
@@ -29,7 +30,6 @@ import Data.List (genericLength, genericIndex, iterate)
 
 import Control.Monad.Trans.Maybe
 import Control.Monad.Reader.Class (MonadReader(local))
-import Control.Monad.Fix
 
 
 data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
@@ -96,6 +96,13 @@ instance Liveliness ListLength where
           max' = Set.lookupMax ns
   liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
 
+
+miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
+miDeleteList l pos
+    -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
+  | l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
+  | otherwise = pure Map.empty
+
 data ButtonMassInput coord
   = MassInputAddDimension Natural coord
   | MassInputDeleteCell coord
@@ -205,7 +212,7 @@ massInput :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData
            , Liveliness liveliness
-           , MonadFix handler, MonadLogger handler
+           , MonadLogger handler
            )
           => MassInput handler liveliness cellData cellResult
           -> FieldSettings UniWorX
@@ -360,3 +367,29 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
     fvInput = $(widgetFile "widgets/massinput/massinput")
     fvErrors = Nothing
     in return (result, FieldView{..})
+
+
+-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
+massInputList :: forall handler cellResult.
+                 ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                 , MonadLogger handler
+                 )
+              => Field handler cellResult
+              -> (ListPosition -> FieldSettings UniWorX)
+              -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+              -> FieldSettings UniWorX
+              -> Bool
+              -> Maybe [cellResult]
+              -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
+massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
+  MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
+                return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn)
+            , miCell = \pos () iRes nudge csrf ->
+                over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
+            , miDelete = miDeleteList
+            , miAllowAdd = \_ _ _ -> True
+            , miButtonAction
+            }
+  miSettings
+  miRequired
+  (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)

src/Utils/Form.hs

@@ -108,6 +108,9 @@ addClasses = addAttrs "class"
 addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site
 addName nm fs = fs { fsName = Just $ toPathPiece nm }
 
+addId :: PathPiece p => p -> FieldSettings site -> FieldSettings site
+addId fid fs = fs { fsId = Just $ toPathPiece fid }
+
 addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
 addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }
 

templates/widgets/massinput/list/cell.hamlet

@@ -0,0 +1,3 @@
+$newline never
+#{csrf}
+^{fvInput}