124 lines
5.6 KiB
Haskell
124 lines
5.6 KiB
Haskell
module Handler.Utils.Form.Occurrences
|
|
( occurrencesAForm
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils.Form
|
|
import Handler.Utils.DateTime
|
|
|
|
import qualified Data.Set as Set
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
|
|
import Utils.Lens
|
|
|
|
|
|
data OccurrenceScheduleKind = ScheduleKindWeekly
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe OccurrenceScheduleKind
|
|
instance Finite OccurrenceScheduleKind
|
|
|
|
nullaryPathPiece ''OccurrenceScheduleKind $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''OccurrenceScheduleKind id
|
|
|
|
data OccurrenceExceptionKind = ExceptionKindOccur
|
|
| ExceptionKindNoOccur
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe OccurrenceExceptionKind
|
|
instance Finite OccurrenceExceptionKind
|
|
|
|
nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id
|
|
|
|
|
|
occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences
|
|
occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
|
|
Just cRoute <- getCurrentRoute
|
|
|
|
let
|
|
scheduled :: AForm Handler (Set OccurrenceSchedule)
|
|
scheduled = Set.fromList <$> massInputAccumA
|
|
miAdd'
|
|
miCell'
|
|
(\p -> Just . SomeRoute $ cRoute :#: p)
|
|
miLayout'
|
|
(miIdent' <> "__scheduled" :: Text)
|
|
(fslI MsgScheduleRegular & setTooltip MsgMassInputTip)
|
|
False
|
|
(Set.toList . occurrencesScheduled <$> mPrev)
|
|
where
|
|
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceSchedule] -> FormResult [OccurrenceSchedule])
|
|
miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/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 MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
|
|
<*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & 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' :: OccurrenceSchedule -> Widget
|
|
miCell' ScheduleWeekly{..} = do
|
|
scheduleStart' <- formatTime SelFormatTime scheduleStart
|
|
scheduleEnd' <- formatTime SelFormatTime scheduleEnd
|
|
$(widgetFile "widgets/occurrence/form/weekly")
|
|
|
|
miLayout' :: MassInputLayout ListLength OccurrenceSchedule ()
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/scheduled-layout")
|
|
|
|
exceptions :: AForm Handler (Set OccurrenceException)
|
|
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 . occurrencesExceptions <$> mPrev)
|
|
where
|
|
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceException] -> FormResult [OccurrenceException])
|
|
miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do
|
|
newExc <- multiActionW
|
|
(Map.fromList [ ( ExceptionKindOccur
|
|
, ExceptOccurr
|
|
<$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing
|
|
<*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
|
|
<*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing
|
|
)
|
|
, ( ExceptionKindNoOccur
|
|
, ExceptNoOccurr
|
|
<$> 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' :: OccurrenceException -> Widget
|
|
miCell' ExceptOccurr{..} = do
|
|
exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
|
|
exceptEnd' <- formatTime SelFormatTime exceptEnd
|
|
$(widgetFile "widgets/occurrence/form/except-occur")
|
|
miCell' ExceptNoOccurr{..} = do
|
|
exceptTime' <- formatTime SelFormatDateTime exceptTime
|
|
$(widgetFile "widgets/occurrence/form/except-no-occur")
|
|
|
|
miLayout' :: MassInputLayout ListLength OccurrenceException ()
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/except-layout")
|
|
|
|
aFormToWForm $ Occurrences
|
|
<$> scheduled
|
|
<*> exceptions
|