#{tshow res} |] + + i18nIdent <- newIdent + let i18nForm' = wrapForm i18nWidget FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ AdminTestR :#: i18nIdent + , formEncoding = i18nEnc + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just i18nIdent + } + [whamlet| +
+ #{toYAML res}
+ |]
[whamlet|
diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs
index 5973c7043..519efbb1d 100644
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@@ -136,8 +136,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
-> return (termsSetField [cfTerm cform], [cfTerm cform])
_allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
- let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
- miAdd _ _ nudge btn = Just $ \csrf -> do
+ let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+ miAdd _ _ _ nudge btn = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let addRes'' = addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
@@ -165,9 +165,6 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
miDelete = miDeleteList
- miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
- miAllowAdd _ _ _ = True
-
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
miAddEmpty _ _ _ = Set.empty
diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs
index 7c7dd5b00..cbb5a71b0 100644
--- a/src/Handler/Sheet/Form.hs
+++ b/src/Handler/Sheet/Form.hs
@@ -210,10 +210,11 @@ correctorForm loads' = wFormToAForm $ do
miAdd :: ListPosition
-> Natural
+ -> ListLength
-> (Text -> Text)
-> FieldView UniWorX
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
- miAdd _ _ nudge submitView = Just $ \csrf -> do
+ miAdd _ _ _ nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just previousCorrectors) (fslpI MsgSheetCorrector (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
| existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
@@ -254,12 +255,6 @@ correctorForm loads' = wFormToAForm $ do
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
miDelete = miDeleteList
- miAllowAdd :: ListPosition
- -> Natural
- -> ListLength
- -> Bool
- miAllowAdd _ _ _ = True
-
miAddEmpty :: ListPosition
-> Natural
-> ListLength
diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs
index c0c003dc3..bb4e29217 100644
--- a/src/Handler/Submission/Helper.hs
+++ b/src/Handler/Submission/Helper.hs
@@ -154,10 +154,11 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
let
miAdd :: ListPosition
-> Natural
+ -> ListLength
-> (Text -> Text)
-> FieldView UniWorX
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
- miAdd _ _ nudge btn = Just $ \csrf -> do
+ miAdd dim pos liveliness nudge btn = guardOn (miAllowAdd dim pos liveliness) $ \csrf -> do
MsgRenderer mr <- getMsgRenderer
(addRes, addView) <- mpreq (addField uid) (addFieldSettings mr & addName (nudge "emails")) Nothing
let addRes' = addRes <&> \newData oldData -> if
diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs
index 1377ab621..ca32a1b71 100644
--- a/src/Handler/Utils/Communication.hs
+++ b/src/Handler/Utils/Communication.hs
@@ -146,12 +146,12 @@ commR CommunicationRoute{..} = do
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
where
- miAdd (BoundedPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
+ miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing
let
addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails
return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
- miAdd _ _ _ _ = Nothing
+ miAdd _ _ _ _ _ = Nothing
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index a43dd4403..8ecee5e33 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
module Handler.Utils.Form
( module Handler.Utils.Form
, module Handler.Utils.Form.MassInput
@@ -60,7 +62,7 @@ import Data.Aeson.Text (encodeToLazyText)
import qualified Text.Email.Validate as Email
import Data.Text.Lens (unpacked)
-import Text.Blaze (toMarkup)
+import Text.Blaze (toMarkup, Markup)
import Handler.Utils.Form.MassInput
@@ -73,6 +75,8 @@ import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Yaml as Yaml
import Control.Monad.Catch.Pure (runCatch)
+
+import qualified Data.List.NonEmpty as NonEmpty
{-# ANN module ("HLint: ignore Use const" :: String) #-}
@@ -696,7 +700,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
, $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
)
- miAdd _ _ nudge submitView = Just $ \csrf -> do
+ miAdd _ _ _ nudge submitView = Just $ \csrf -> do
(formRes, formWidget) <- sFileForm nudge Nothing csrf
let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add")
addRes' = formRes <&> \fileRes oldRess ->
@@ -707,7 +711,6 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
sFileForm nudge (Just initFile) csrf
miDelete :: MassInputDelete ListLength
miDelete = miDeleteList
- miAllowAdd _ _ _ = True
miAddEmpty _ _ _ = Set.empty
miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
@@ -2345,3 +2348,152 @@ roomReferenceForm' noneOpt fs mPrev = multiActionAOpts opts opts' fs $ fmap clas
<$> roomRefLink'
<*> roomRefInstructions'
return $ Just <$> res
+
+newtype I18nLangs = I18nLangs { unI18nLangs :: Set I18nLang }
+ deriving newtype (ToJSON, FromJSON, MonoFoldable, Semigroup, Monoid, Lattice, BoundedJoinSemiLattice)
+ deriving (Eq, Ord, Generic, Typeable, Read, Show)
+type instance Element I18nLangs = I18nLang
+
+newtype I18nLang = I18nLang { unI18nLang :: Lang }
+ deriving newtype (PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
+ deriving (Eq, Generic, Typeable, Read, Show)
+
+instance Ord I18nLang where
+ compare = mconcat
+ [ comparing $ NTop . flip elemIndex (toList appLanguages) . unI18nLang
+ , comparing $ T.splitOn "-" . unI18nLang
+ ]
+
+makeWrapped ''I18nLangs
+makeWrapped ''I18nLang
+
+instance IsBoxCoord I18nLang where
+ boxDimensions = [BoxDimension _Wrapped]
+ boxOrigin = _Wrapped # NonEmpty.head appLanguages
+
+instance Liveliness I18nLangs where
+ type BoxCoord I18nLangs = I18nLang
+ liveCoords = from _Wrapped
+
+i18nLangMap :: Prism' (Map I18nLang a) (I18n a)
+i18nLangMap = prism' toLangMap fromLangMap
+ where
+ -- ugh.
+ toLangMap I18n{..} = Map.mapKeys I18nLang $ if
+ | Just fLang <- i18nFallbackLang
+ -> Map.insert fLang i18nFallback i18nTranslations
+ | missing : _ <- sortOn langSortProj . toList $ setOf folded appLanguages `Set.difference` Map.keysSet i18nTranslations
+ -> Map.insert missing i18nFallback i18nTranslations
+ | otherwise
+ -> Map.insert (NonEmpty.head appLanguages) i18nFallback i18nTranslations
+ fromLangMap lMap = do
+ (Just -> i18nFallbackLang, i18nFallback) : i18nTranslations' <- return
+ $ Map.toList lMap
+ & over (traverse . _1) (view _Wrapped)
+ & sortOn (views _1 langSortProj)
+ let i18nTranslations = Map.fromList i18nTranslations'
+ return I18n{..}
+
+ langSortProj = NTop . flip elemIndex (toList appLanguages)
+
+i18nForm :: forall a ident handler.
+ ( PathPiece ident
+ , MonadHandler handler, HandlerSite handler ~ UniWorX
+ , MonadThrow handler
+ )
+ => ((Text -> Text) -> Maybe a -> (Markup -> MForm handler (FormResult a, Widget)))
+ -> Bool -- ^ Allow only languages from `appLanguages`?
+ -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+ -> ident
+ -> FieldSettings UniWorX
+ -> Bool
+ -> Maybe (I18n a)
+ -> (Markup -> MForm handler (FormResult (I18n a), FieldView UniWorX))
+i18nForm strForm onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev' csrf'
+ = fmap (over _1 massageFormResult) . ($ csrf') . massInput MassInput{..} fSettings fRequired $ fmap ((), ) . review i18nLangMap <$> mPrev'
+ where
+ massageFormResult :: FormResult (Map I18nLang ((), a)) -> FormResult (I18n a)
+ massageFormResult = \case
+ FormSuccess xs
+ | Just xs' <- preview i18nLangMap $ map (view _2) xs
+ -> FormSuccess xs'
+ | otherwise
+ -> FormMissing
+ FormFailure errs -> FormFailure errs
+ FormMissing -> FormMissing
+
+ miAdd :: I18nLang -> Natural -> I18nLangs
+ -> (Text -> Text) -> FieldView UniWorX
+ -> Maybe (Markup -> MForm handler (FormResult (Map I18nLang () -> FormResult (Map I18nLang ())), Widget))
+ miAdd _pos _dimIx liveliness nudge submitBtn = guardOn (not $ onlyAppLanguages && null (missingLangs liveliness)) $ \csrf -> do
+ let langField' :: Field Handler Lang
+ langField'
+ | onlyAppLanguages = selectField langOpts
+ | otherwise = textField
+ & addDatalist langOpts
+ & cfStrip
+ & checkBool langCheck MsgInvalidLangFormat
+ where
+ langOpts = do
+ MsgRenderer mr <- getMsgRenderer
+ let mkOption l = Option
+ { optionDisplay = mr $ MsgLanguage l
+ , optionInternalValue = l
+ , optionExternalValue = l
+ }
+ return OptionList
+ { olOptions = map (views _Wrapped mkOption) $ missingLangs liveliness
+ , olReadExternal = if
+ | onlyAppLanguages -> assertM' (`elem` toList appLanguages)
+ | otherwise -> Just
+ }
+ langCheck (T.splitOn "-" -> lParts)
+ = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
+ && not (null lParts)
+
+ (langRes, langView) <- mpopt (hoistField liftHandler langField' & isoField _Unwrapped) (def & addName (nudge "lang")) $ missingLangs liveliness ^? _head
+
+ MsgRenderer mr <- getMsgRenderer
+ let res = langRes <&> \newLang oldLangs -> if
+ | newLang `Map.member` oldLangs -> FormFailure . pure . mr . MsgI18nFormLanguageAlreadyExists $ newLang ^. _Wrapped
+ | otherwise -> pure $ Map.singleton newLang ()
+
+ return (res, $(widgetFile "widgets/i18n-form/add"))
+ where
+ missingLangs liveliness' = Set.toAscList $ setOf (folded . re _Wrapped) appLanguages `Set.difference` view _Wrapped liveliness'
+
+ miCell :: I18nLang -> () -> Maybe a
+ -> (Text -> Text)
+ -> (Markup -> MForm handler (FormResult a, Widget))
+ miCell _ _ mPrev nudge csrf = do
+ (strRes, strView) <- strForm nudge mPrev csrf
+ return (strRes, $(widgetFile "widgets/i18n-form/cell"))
+
+ miDelete :: Map I18nLang ()
+ -> I18nLang
+ -> MaybeT (MForm handler) (Map I18nLang I18nLang)
+ miDelete liveliness' coord = return . Map.delete coord . Map.fromSet id $ Map.keysSet liveliness'
+
+ miAddEmpty :: I18nLang
+ -> Natural
+ -> I18nLangs
+ -> Set I18nLang
+ miAddEmpty _ _ _ = Set.empty
+
+ miLayout :: MassInputLayout I18nLangs () a
+ miLayout (I18nLangs langs) _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/i18n-form/layout")
+
+i18nField :: forall a ident handler.
+ ( PathPiece ident
+ , MonadHandler handler, HandlerSite handler ~ UniWorX
+ , MonadThrow handler
+ )
+ => Field handler a
+ -> Bool -- ^ Allow only languages from `appLanguages`?
+ -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+ -> ident
+ -> FieldSettings UniWorX
+ -> Bool
+ -> Maybe (I18n a)
+ -> (Markup -> MForm handler (FormResult (I18n a), FieldView UniWorX))
+i18nField strField = i18nForm $ \nudge mPrev csrf -> over _2 ((toWidget csrf <>) . fvWidget) <$> mpreq strField (def & addName (nudge "string")) mPrev
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index 526ee5d9b..8de2c3a36 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@@ -35,6 +35,9 @@ import Text.Hamlet (hamletFile)
import Algebra.Lattice.Ordered (Ordered(..))
+import Control.Monad.Trans.RWS.Lazy (evalRWST)
+import qualified Control.Monad.State.Class as State
+
{-# ANN module ("HLint: ignore Use const" :: String) #-}
@@ -244,10 +247,11 @@ data MassInputException = MassInputInvalidShape
instance Exception MassInputException
data MassInput handler liveliness cellData cellResult = forall i. PathPiece i => MassInput
- { miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero)
- -> Natural -- Zero-based dimension index @dimIx@
- -> (Text -> Text) -- Nudge deterministic field ids
- -> FieldView UniWorX -- Submit button
+ { miAdd :: BoxCoord liveliness -- ^ Position (dimensions after @dimIx@ are zero)
+ -> Natural -- ^ Zero-based dimension index @dimIx@
+ -> liveliness -- ^ Previous liveliness
+ -> (Text -> Text) -- ^ Nudge deterministic field ids
+ -> FieldView UniWorX -- ^ Submit button
-> Maybe (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
, miCell :: BoxCoord liveliness -- Position
-> cellData -- @cellData@ from @miAdd@
@@ -257,10 +261,6 @@ data MassInput handler liveliness cellData cellResult = forall i. PathPiece i =>
, miDelete :: Map (BoxCoord liveliness) cellData
-> BoxCoord liveliness
-> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants
- , miAllowAdd :: BoxCoord liveliness
- -> Natural
- -> liveliness
- -> Bool -- ^ Decide whether an addition-operation should be permitted
, miAddEmpty :: BoxCoord liveliness
-> Natural
-> liveliness
@@ -315,74 +315,88 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
| otherwise -> throwM MassInputInvalidShape
sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
- let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
- addForm = addForm' boxOrigin [] . zip [0..]
- where
- addForm' _ _ [] = return Map.empty
- addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
- let nudgeAddWidgetName :: Text -> Text
- nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
- (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
- let btnRes = do
- Just x <- btnRes'
- return x
- wBtnRes res = do
- guard $ isn't _FormMissing btnRes
- res
- miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
- addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
- addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
- let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
- case remDims of
- [] -> return dimRes'
- ((_, BoxDimension dim) : _) -> do
- let miCoords
- = Set.union (miAddEmpty miCoord dimIx sentLiveliness)
- . Set.map (\c -> miCoord & dim .~ (c ^. dim))
- . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
- $ review liveCoords sentLiveliness
- dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
- return $ dimRes' `Map.union` fold dimRess
+ let runTwice :: (Maybe res -> MForm handler res) -> MForm handler res
+ runTwice act = do
+ r <- ask
+ s <- State.get
+ res1 <- fmap (view _1) . lift $ evalRWST (act Nothing) r s
+ local (_1 .~ Nothing) . act $ Just res1
+ replaceWithFirst :: forall k x y. Ord k => Maybe (Map k (x, y)) -> Map k (x, y) -> Map k (x, y)
+ replaceWithFirst Nothing xs = xs
+ replaceWithFirst (Just f) s = Map.unionWith (\(f1, _f2) (_s1, s2) -> (f1, s2)) f s
+
+ (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged) <- runTwice $ \mPrev -> do
+ let sentLiveliness' = maybe sentLiveliness (view _2) mPrev
- addResults <- addForm boxDimensions
- let
- addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
- addResults' = flip Map.mapWithKey (fst <$> addResults) $ \(dimIx, miCoord) -> \case
- FormSuccess (Just mkResult)
- | miAllowAdd miCoord dimIx sentLiveliness -> Just <$> mkResult sentShape'
+ let addForm :: MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
+ addForm = addForm' boxOrigin [] $ zip [0..] boxDimensions
+ where
+ addForm' _ _ [] = return Map.empty
+ addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
+ let nudgeAddWidgetName :: Text -> Text
+ nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
+ (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
+ let btnRes = do
+ Just x <- btnRes'
+ return x
+ wBtnRes res = do
+ guard $ isn't _FormMissing btnRes
+ res
+ miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx sentLiveliness' nudgeAddWidgetName btnView
+ addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
+ addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
+ let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
+ case remDims of
+ [] -> return dimRes'
+ ((_, BoxDimension dim) : _) -> do
+ let miCoords
+ = Set.union (miAddEmpty miCoord dimIx sentLiveliness')
+ . Set.map (\c -> miCoord & dim .~ (c ^. dim))
+ . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
+ $ review liveCoords sentLiveliness'
+ dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
+ return $ dimRes' `Map.union` fold dimRess
+
+ addResults <- replaceWithFirst (view _4 <$> mPrev) <$> addForm
+ let
+ addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
+ addResults' = fmap (view _1) addResults <&> \case
+ FormSuccess (Just mkShape) -> Just <$> mkShape sentShape'
other -> Nothing <$ other
- let addShape
- | [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
- = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape' <* guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
- | otherwise = Nothing
+ let addShape
+ | [FormSuccess (Just mkResult)] <- Map.elems . Map.filter (is $ _FormSuccess . _Just) $ view _1 <$> addResults
+ = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape') sentShape'
+ | otherwise = Nothing
- addedShape <- if
- | Just s <- addShape -> return s
- | otherwise -> return sentShape'
+ addedShape <- if
+ | Just s <- addShape -> return s
+ | otherwise -> return sentShape'
- let
- delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
- delForm miCoord = do
- (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
- shapeUpdate <- miDelete addedShape miCoord
- guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
- return (shapeUpdate <$ assertM (is _Just) delRes, delView)
+ let
+ delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
+ delForm miCoord = do
+ (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
+ shapeUpdate <- miDelete addedShape miCoord
+ guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
+ return (shapeUpdate <$ assertM (is _Just) delRes, delView)
- delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
- let
- delShapeUpdate
- | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
- | otherwise = Nothing
- delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
+ delResults <- fmap (replaceWithFirst (view _6 <$> mPrev) . Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
+ let
+ delShapeUpdate
+ | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
+ | otherwise = Nothing
+ delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
- let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
+ let shapeChanged = Fold.any (hasn't $ _1 . _FormMissing) addResults || Fold.any (has $ _1 . _FormSuccess) delResults
- shape <- if
- | Just s <- addShape -> return s
- | Just s <- delShape -> return s
- | otherwise -> return sentShape'
- liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
+ shape <- if
+ | Just s <- addShape -> return s
+ | Just s <- delShape -> return s
+ | otherwise -> return sentShape'
+ liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
+
+ return (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged)
shapeId <- newIdent
let shapeInput = fieldView shapeField shapeId (toPathPiece shapeName) [] (Right shape) True
@@ -424,7 +438,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
(fmap (view _1 &&& view (_2 . _1)) cellResults)
(fmap (view $ _2 . _2) cellResults)
(fmap (view _2) delResults)
- (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
+ (Map.mapMaybe (view _2) addResults)
MsgRenderer mr <- getMsgRenderer
@@ -489,12 +503,11 @@ massInputList :: forall handler cellResult ident msg.
-> Maybe [cellResult]
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
- MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
+ MassInput { miAdd = \_ _ _ _ submitBtn -> Just $ \csrf ->
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
, miCell = \pos () iRes nudge csrf ->
over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
, miDelete = miDeleteList
- , miAllowAdd = \_ _ _ -> True
, miAddEmpty = \_ _ _ -> Set.empty
, miButtonAction
, miLayout = listMiLayout
@@ -541,10 +554,10 @@ massInputAccum :: forall handler cellData ident.
massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
= over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> mPrev) csrf
where
- miAdd :: ListPosition -> Natural
+ miAdd :: ListPosition -> Natural -> ListLength
-> (Text -> Text) -> FieldView UniWorX
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
- miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
+ miAdd _pos _dim _liveliness nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
@@ -559,8 +572,6 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
miDelete :: MassInputDelete ListLength
miDelete = miDeleteList
- miAllowAdd _ _ _ = True
-
miAddEmpty _ _ _ = Set.empty
massInputAccumA :: forall handler cellData ident.
@@ -619,10 +630,10 @@ massInputAccumEdit :: forall handler cellData ident.
massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
= over (_1 . mapped) (map snd . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (\x -> (x, x)) <$> mPrev) csrf
where
- miAdd :: ListPosition -> Natural
+ miAdd :: ListPosition -> Natural -> ListLength
-> (Text -> Text) -> FieldView UniWorX
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
- miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
+ miAdd _pos _dim _liveliness nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
@@ -637,8 +648,6 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
miDelete :: MassInputDelete ListLength
miDelete = miDeleteList
- miAllowAdd _ _ _ = True
-
miAddEmpty _ _ _ = Set.empty
massInputAccumEditA :: forall handler cellData ident.
diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs
index ce8168f4d..873f158c2 100644
--- a/src/Handler/Utils/Workflow/EdgeForm.hs
+++ b/src/Handler/Utils/Workflow/EdgeForm.hs
@@ -527,10 +527,11 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec
miAdd :: ListPosition
-> Natural
+ -> ListLength
-> (Text -> Text)
-> FieldView UniWorX
-> Maybe (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))), Widget))
- miAdd _pos _dim nudge submitView = Just $ over (mapped . _1 . _FormSuccess) tweakRes . miForm nudge (Left submitView)
+ miAdd pos dim liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ over (mapped . _1 . _FormSuccess) tweakRes . miForm nudge (Left submitView)
where tweakRes :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))
-> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
-> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))
diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs
index c363241e0..08bce4f4d 100644
--- a/src/Model/Types/Markup.hs
+++ b/src/Model/Types/Markup.hs
@@ -3,6 +3,7 @@ module Model.Types.Markup
, StoredMarkup(..)
, htmlToStoredMarkup, plaintextToStoredMarkup, preEscapedToStoredMarkup
, esqueletoMarkupOutput
+ , I18nStoredMarkup
) where
import Import.NoModel
@@ -133,3 +134,5 @@ instance PersistField StoredMarkup where
toPersistValue = PersistLiteralEscaped . LBS.toStrict . Aeson.encode
instance PersistFieldSql StoredMarkup where
sqlType _ = SqlOther "jsonb"
+
+type I18nStoredMarkup = I18n StoredMarkup
diff --git a/src/Utils.hs b/src/Utils.hs
index caa059f5e..0b255f9e1 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -613,6 +613,9 @@ mapFromSetM = (sequenceA .) . Map.fromSet
mapFilterM :: (Monad m, Ord k) => (v -> m Bool) -> Map k v -> m (Map k v)
mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . assertMM (lift . f) . hoistMaybe)) (Map.keys m)
+_MapUnit :: Iso' (Map k ()) (Set k)
+_MapUnit = iso Map.keysSet $ Map.fromSet (const ())
+
---------------
-- Functions --
---------------
diff --git a/templates/widgets/i18n-form/add.hamlet b/templates/widgets/i18n-form/add.hamlet
new file mode 100644
index 000000000..6e6e02f4f
--- /dev/null
+++ b/templates/widgets/i18n-form/add.hamlet
@@ -0,0 +1,12 @@
+$newline never
+
+
+