diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5e3b77421..5ecb2a00e 100644 --- a/messages/uniworx/de.msg +++ b/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. diff --git a/routes b/routes index e2bf2976b..f76fd47b7 100644 --- a/routes +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index dc5d3fcaf..fd7ae019e 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 31ab90653..6fbfa6c9e 100644 --- a/src/Handler/Term.hs +++ b/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 diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 6b9e35f1b..d1c403ec7 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 4ebf3d1bb..0d055bbf4 100644 --- a/src/Utils/Form.hs +++ b/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 } diff --git a/templates/widgets/massinput/list/cell.hamlet b/templates/widgets/massinput/list/cell.hamlet new file mode 100644 index 000000000..36caeb9ff --- /dev/null +++ b/templates/widgets/massinput/list/cell.hamlet @@ -0,0 +1,3 @@ +$newline never +#{csrf} +^{fvInput}