125 lines
5.6 KiB
Haskell
125 lines
5.6 KiB
Haskell
module Handler.Utils.Form.Occurences
|
|
( occurencesAForm
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils.Form
|
|
import Handler.Utils.Form.MassInput
|
|
import Handler.Utils.DateTime
|
|
|
|
import qualified Data.Set as Set
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
|
|
import Utils.Lens
|
|
|
|
|
|
data OccurenceScheduleKind = ScheduleKindWeekly
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe OccurenceScheduleKind
|
|
instance Finite OccurenceScheduleKind
|
|
|
|
nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''OccurenceScheduleKind id
|
|
|
|
data OccurenceExceptionKind = ExceptionKindOccur
|
|
| ExceptionKindNoOccur
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe OccurenceExceptionKind
|
|
instance Finite OccurenceExceptionKind
|
|
|
|
nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''OccurenceExceptionKind id
|
|
|
|
|
|
occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences
|
|
occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
|
|
Just cRoute <- getCurrentRoute
|
|
|
|
let
|
|
scheduled :: AForm Handler (Set OccurenceSchedule)
|
|
scheduled = Set.fromList <$> massInputAccumA
|
|
miAdd'
|
|
miCell'
|
|
(\p -> Just . SomeRoute $ cRoute :#: p)
|
|
miLayout'
|
|
(miIdent' <> "__scheduled" :: Text)
|
|
(fslI MsgScheduleRegular & setTooltip MsgMassInputTip)
|
|
False
|
|
(Set.toList . occurencesScheduled <$> mPrev)
|
|
where
|
|
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceSchedule] -> FormResult [OccurenceSchedule])
|
|
miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do
|
|
newSched <- multiActionW
|
|
(Map.fromList [ ( ScheduleKindWeekly
|
|
, ScheduleWeekly
|
|
<$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing
|
|
<*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing
|
|
<*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing
|
|
)
|
|
]
|
|
) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return $ newSched <&> \newSched' oldScheds -> if
|
|
| newSched' `elem` oldScheds -> FormFailure [mr MsgScheduleExists]
|
|
| otherwise -> FormSuccess $ pure newSched'
|
|
|
|
miCell' :: OccurenceSchedule -> Widget
|
|
miCell' ScheduleWeekly{..} = do
|
|
scheduleStart' <- formatTime SelFormatTime scheduleStart
|
|
scheduleEnd' <- formatTime SelFormatTime scheduleEnd
|
|
$(widgetFile "widgets/occurence/form/weekly")
|
|
|
|
miLayout' :: MassInputLayout ListLength OccurenceSchedule ()
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout")
|
|
|
|
exceptions :: AForm Handler (Set OccurenceException)
|
|
exceptions = Set.fromList <$> massInputAccumA
|
|
miAdd'
|
|
miCell'
|
|
(\p -> Just . SomeRoute $ cRoute :#: p)
|
|
miLayout'
|
|
(miIdent' <> "__exceptions" :: Text)
|
|
(fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip]))
|
|
False
|
|
(Set.toList . occurencesExceptions <$> mPrev)
|
|
where
|
|
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceException] -> FormResult [OccurenceException])
|
|
miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do
|
|
newExc <- multiActionW
|
|
(Map.fromList [ ( ExceptionKindOccur
|
|
, ExceptOccur
|
|
<$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing
|
|
<*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing
|
|
<*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing
|
|
)
|
|
, ( ExceptionKindNoOccur
|
|
, ExceptNoOccur
|
|
<$> apreq localTimeField (fslI MsgExceptionNoOccurAt & addName (nudge "no-occur-time")) Nothing
|
|
)
|
|
]
|
|
) (fslI MsgExceptionKind & addName (nudge "kind")) Nothing
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return $ newExc <&> \newExc' oldExcs -> if
|
|
| newExc' `elem` oldExcs -> FormFailure [mr MsgExceptionExists]
|
|
| otherwise -> FormSuccess $ pure newExc'
|
|
|
|
|
|
miCell' :: OccurenceException -> Widget
|
|
miCell' ExceptOccur{..} = do
|
|
exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
|
|
exceptEnd' <- formatTime SelFormatTime exceptEnd
|
|
$(widgetFile "widgets/occurence/form/except-occur")
|
|
miCell' ExceptNoOccur{..} = do
|
|
exceptTime' <- formatTime SelFormatDateTime exceptTime
|
|
$(widgetFile "widgets/occurence/form/except-no-occur")
|
|
|
|
miLayout' :: MassInputLayout ListLength OccurenceException ()
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout")
|
|
|
|
aFormToWForm $ Occurences
|
|
<$> scheduled
|
|
<*> exceptions
|