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) =