diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 591040b0b..dbe8cf42c 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -132,7 +132,19 @@ postAdminTestR = do
#{m}
|]
+
+ {- The following demonstrates the use of @massInput@.
+
+ @massInput@ takes as arguments:
+ - A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
+ - Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
+ - An initial value to pre-fill the field with
+
+ @massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
+ -}
let
+ -- We define the fields of the configuration struct @MassInput@:
+
-- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
--
-- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required)
@@ -142,10 +154,12 @@ postAdminTestR = do
-> FieldView UniWorX -- ^ Submit-Button for this add-widget
-> Maybe (Form (ListLength -> (ListPosition, Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cell and data needed to initialize cell
mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
- (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing
- let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes
- return ((\dat l -> (fromIntegral l, dat)) <$> addRes', toWidget csrf >> fvInput addView >> fvInput submitBtn)
+ (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
+ let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
+ addRes'' = (\dat l -> (fromIntegral l, dat)) <$> addRes' -- Construct the callback to determine new cell position and data within @FormResult@ as required
+ return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
+
-- | Make a single massInput-Cell
--
-- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
@@ -154,19 +168,21 @@ postAdminTestR = do
-> Maybe Int -- ^ Initial cell result from Argument to `massInput`
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
-> Form Int
- mkCellForm _pos initial previous nudge csrf = do
- (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ previous <|> Just initial
+ mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
+ (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
return (intRes, toWidget csrf >> fvInput intView)
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
deleteCell :: ListLength -- ^ Current shape
-> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
deleteCell l pos
- | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
+ | 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
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
- allowAdd _ _ l = l < 7
+ allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
+
+ -- The actual call to @massInput@ is comparatively simple:
((miResult, (fvInput -> miForm)), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index ad8cb2d2b..8da523d3a 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@@ -185,14 +185,19 @@ data MassInput handler liveliness cellData cellResult = MassInput
-> Natural -- Zero-based dimension index @dimIx@
-> (Text -> Text) -- Nudge deterministic field ids
-> FieldView UniWorX -- Submit button
- -> Maybe (Markup -> MForm handler (FormResult (liveliness -> (BoxCoord liveliness, cellData)), Widget))
+ -> Maybe (Markup -> MForm handler (FormResult (liveliness -> (BoxCoord liveliness, cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
, miCell :: BoxCoord liveliness -- Position
- -> cellData -- Initialisation data
- -> Maybe cellResult -- Previous result
+ -> cellData -- @cellData@ from @miAdd@
+ -> Maybe cellResult -- Initial result from Argument to @massInput@
-> (Text -> Text) -- Nudge deterministic field ids
- -> (Markup -> MForm handler (FormResult cellResult, Widget))
- , miDelete :: liveliness -> BoxCoord liveliness -> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness))
- , miAllowAdd :: BoxCoord liveliness -> Natural -> liveliness -> Bool
+ -> (Markup -> MForm handler (FormResult cellResult, Widget)) -- ^ Construct a singular cell
+ , miDelete :: liveliness
+ -> 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
}
massInput :: forall handler cellData cellResult liveliness.
@@ -206,7 +211,7 @@ massInput :: forall handler cellData cellResult liveliness.
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
-massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = mdo
+massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
let initialShape = fmap fst <$> initialResult
miName <- maybe newFormIdent return fsName
@@ -282,12 +287,12 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = mdo
| Just s <- addShape -> return s
| Just s <- delShape -> return s
| otherwise -> return sentShape'
-
- $logDebugS "massInput" [st|Current shape: #{tshow (map toPathPiece (Map.keys shape))}|]
+ liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
shapeId <- newIdent
let shapeInput = fieldView shapeField shapeId (toPathPiece shapeName) [] (Right shape) True
+
let
applyDelShapeUpdate :: Maybe (Env, FileEnv) -> Maybe (Env, FileEnv)
applyDelShapeUpdate prevEnv
@@ -300,18 +305,26 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = mdo
return $ toPathPiece cell{ miCoord = newCoord }
| otherwise = prevEnv
+ justAdded :: Set (BoxCoord liveliness)
+ justAdded = Set.fromList . mapMaybe (addedCoord . fst) $ Map.elems addResults
+ where
+ addedCoord res
+ | FormSuccess (Just mkResult) <- res
+ = Just . fst $ mkResult sentLiveliness
+ | otherwise = Nothing
+ restrictJustAdded :: BoxCoord liveliness -> Maybe a -> Maybe a
+ restrictJustAdded miCoord env = env <* guard (not $ Set.member miCoord justAdded)
+
cellResults <- flip Map.traverseWithKey shape $ \miCoord cData -> do
let
nudgeCellName :: Text -> Text
nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
- local (over _1 applyDelShapeUpdate) $ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
+ local (over _1 (applyDelShapeUpdate . restrictJustAdded miCoord)) $ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult))
result
| shapeChanged = FormMissing
| otherwise = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults
- liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
-
let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
miWidget' _ [] = mempty
miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =