#{err}
+ $of FormSuccess res
+
+ #{tshow res}
+ |]
+
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
getAdminErrMsgR = postAdminErrMsgR
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index b135e3a6c..3375f5a24 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@@ -1,20 +1,23 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Handler.Utils.Form.MassInput
- ( massInput
+ ( MassInput(..)
+ , massInput
, BoxDimension(..)
, IsBoxCoord(..), boxDimension
, Liveliness(..)
+ , ListLength(..), ListPosition(..)
) where
import Import
import Utils.Form
+import Utils.Lens
import Handler.Utils.Form (secretJsonField)
import Data.Aeson
import Algebra.Lattice
-import Control.Lens hiding (universe)
-
import Text.Blaze (Markup)
import qualified Data.Text as Text
@@ -23,6 +26,9 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.List (genericLength, genericIndex, iterate)
+import Control.Monad.Trans.Maybe
+import Control.Monad.Fix
+
data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
@@ -44,29 +50,71 @@ class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveline
type BoxCoord a :: *
liveCoords :: Prism' (Set (BoxCoord a)) a
liveCoord :: BoxCoord a -> Prism' Bool a
+ liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
+newtype ListLength = ListLength { unListLength :: Natural }
+ deriving newtype (Num, Integral, Real, Enum, PathPiece)
+ deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''ListLength
+
+instance JoinSemiLattice ListLength where
+ (\/) = max
+instance MeetSemiLattice ListLength where
+ (/\) = min
+instance Lattice ListLength
+instance BoundedJoinSemiLattice ListLength where
+ bottom = 0
+
+newtype ListPosition = ListPosition { unListPosition :: Natural }
+ deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSONKey, FromJSONKey)
+ deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''ListPosition
+
+instance IsBoxCoord ListPosition where
+ boxDimensions = [BoxDimension id]
+ boxOrigin = 0
+
+instance Liveliness ListLength where
+ type BoxCoord ListLength = ListPosition
+ liveCoords = prism' toSet fromSet
+ where
+ toSet n
+ | n > 0 = Set.fromList [0..pred (fromIntegral n)]
+ | otherwise = Set.empty
+
+ fromSet ns
+ | ns == maybe Set.empty (\n -> Set.fromList [0..n]) max'
+ = fmap (succ . fromIntegral) max' <|> Just 0
+ | otherwise
+ = Nothing
+ where
+ max' = Set.lookupMax ns
+ liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
+
data ButtonMassInput coord
- = MassInputAddDimension Natural
+ = MassInputAddDimension Natural coord
| MassInputDeleteCell coord
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance PathPiece coord => PathPiece (ButtonMassInput coord) where
toPathPiece = \case
- MassInputAddDimension n -> "add__" <> toPathPiece n
+ MassInputAddDimension n c -> "add__" <> toPathPiece n <> "__" <> toPathPiece c
MassInputDeleteCell c -> "delete__" <> toPathPiece c
fromPathPiece t = addDim <|> delCell
where
addDim = do
- nT <- stripPrefix "add__" t
- MassInputAddDimension <$> fromPathPiece nT
+ (dimT, Text.stripPrefix "__" -> Just coordT) <- Text.breakOn "__" <$> stripPrefix "add__" t
+ MassInputAddDimension <$> fromPathPiece dimT <*> fromPathPiece coordT
delCell = do
coordT <- stripPrefix "delete__" t
MassInputDeleteCell <$> fromPathPiece coordT
instance RenderMessage UniWorX (ButtonMassInput coord) where
renderMessage f ls = \case
- MassInputAddDimension _ -> mr MsgMassInputAddDimension
+ MassInputAddDimension _ _ -> mr MsgMassInputAddDimension
MassInputDeleteCell _ -> mr MsgMassInputDeleteCell
where
mr = renderMessage f ls
@@ -74,21 +122,25 @@ instance RenderMessage UniWorX (ButtonMassInput coord) where
instance PathPiece coord => Button UniWorX (ButtonMassInput coord) where
btnValidate _ _ = False
- btnClasses (MassInputAddDimension _) = [BCIsButton, BCDefault]
+ btnClasses (MassInputAddDimension _ _) = [BCIsButton, BCDefault]
btnClasses (MassInputDeleteCell _) = [BCIsButton, BCWarning]
data MassInputFieldName coord
= MassInputShape { miName :: Text }
| MassInputAddWidget { miName :: Text, miCoord :: coord, miAddWidgetField :: Text }
+ | MassInputAddButton { miName :: Text, miCoord :: coord }
+ | MassInputDeleteButton { miName :: Text, miCoord :: coord }
| MassInputCell { miName :: Text, miCoord :: coord, miCellField :: Text }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where
toPathPiece = \case
MassInputShape{..} -> [st|#{miName}__shape|]
- MassInputAddWidget{..} -> [st|#{miName}__#{toPathPiece miCoord}__#{miAddWidgetField}|]
- MassInputCell{..} -> [st|#{miName}__#{toPathPiece miCoord}__#{miCellField}|]
+ MassInputAddWidget{..} -> [st|#{miName}__add__#{toPathPiece miCoord}__fields__#{miAddWidgetField}|]
+ MassInputAddButton{..} -> [st|#{miName}__add__#{toPathPiece miCoord}__submit|]
+ MassInputDeleteButton{..} -> [st|#{miName}__delete__#{toPathPiece miCoord}|]
+ MassInputCell{..} -> [st|#{miName}__cells__#{toPathPiece miCoord}__#{miCellField}|]
fromPathPiece t = do
(miName, Text.stripPrefix "__" -> Just t') <- return $ Text.breakOn "__" t
@@ -97,11 +149,26 @@ instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where
guard $ t' == "shape"
return MassInputShape{..}
, do
- (coordT, Text.stripPrefix "__" -> Just miAddWidgetField) <- return $ Text.breakOn "__" t'
+ t'' <- Text.stripPrefix "add__" t'
+ (coordT, Text.stripPrefix "__" -> Just rest) <- return $ Text.breakOn "__" t''
+ miAddWidgetField <- Text.stripPrefix "fields__" rest
miCoord <- fromPathPiece coordT
return MassInputAddWidget{..}
, do
- (coordT, Text.stripPrefix "__" -> Just miCellField) <- return $ Text.breakOn "__" t'
+ t'' <- Text.stripPrefix "add__" t'
+ (coordT, Text.stripPrefix "__" -> Just ident) <- return $ Text.breakOn "__" t''
+ guard $ ident == "submit"
+ miCoord <- fromPathPiece coordT
+ return MassInputAddButton{..}
+ , do
+ t'' <- Text.stripPrefix "delete__" t'
+ (coordT, rest) <- return $ Text.breakOn "__" t''
+ guard $ Text.null rest
+ miCoord <- fromPathPiece coordT
+ return MassInputDeleteButton{..}
+ , do
+ t'' <- Text.stripPrefix "cells__" t'
+ (coordT, Text.stripPrefix "__" -> Just miCellField) <- return $ Text.breakOn "__" t''
miCoord <- fromPathPiece coordT
return MassInputCell{..}
]
@@ -111,49 +178,50 @@ data MassInputException = MassInputInvalidShape
instance Exception MassInputException
+data MassInput handler liveliness cellData cellResult = MassInput
+ { miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero)
+ -> Natural -- Zero-based dimension index @dimIx@
+ -> liveliness
+ -> (Text -> Text) -- Nudge deterministic field ids
+ -> FieldView UniWorX -- Submit button
+ -> Maybe (Markup -> MForm handler (FormResult (BoxCoord liveliness, cellData), Widget))
+ , miCell :: BoxCoord liveliness -- Position
+ -> cellData -- Initialisation data
+ -> Maybe cellResult -- Previous result
+ -> (Text -> Text) -- Nudge deterministic field ids
+ -> (Markup -> MForm handler (FormResult cellResult, Widget))
+ , miDelete :: liveliness -> BoxCoord liveliness -> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness))
+ }
+
massInput :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
+ , MonadFix handler, MonadLogger handler
)
- => ( Natural -- ^ Zero-based dimension index
- -> liveliness -- ^ Currently live positions
- -> (Text -> Text) -- ^ Nudge deterministic field ids
- -> Maybe (Markup -> MForm handler (FormResult (BoxCoord liveliness, cellData), Widget))
- ) -- ^ Generate a cell-addition widget
- -> ( BoxCoord liveliness
- -> cellData
- -> Maybe cellResult
- -> (Text -> Text) -- ^ Nudge deterministic field ids
- -> (Markup -> MForm handler (FormResult cellResult, Widget))
- ) -- ^ Cell-Widget
+ => MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
- -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX)
-massInput mkAddWidget mkCellWidget FieldSettings{..} fvRequired initialResult = do
+ -> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
+massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
let initialShape = fmap fst <$> initialResult
miName <- maybe newFormIdent return fsName
let
shapeName :: MassInputFieldName (BoxCoord liveliness)
shapeName = MassInputShape{..}
- (shape', _shapeWdgt) <- mreq secretJsonField ("" & addName shapeName) $ initialShape
- shape <- if
- | FormSuccess s <- shape' -> return s
+ shapeField = secretJsonField
+ sentShape <- runMaybeT $ do
+ ts <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askParams
+ fs <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askFiles
+ MaybeT $ either (const Nothing) id <$> lift (fieldParse shapeField ts fs)
+ sentShape' <- if
+ | Just s <- sentShape -> return s
| Just iS <- initialShape -> return iS
| Set.null $ review liveCoords (bottom :: liveliness) -> return Map.empty
| otherwise -> throwM MassInputInvalidShape
-
- cellResults <- flip Map.traverseWithKey shape $ \miCoord cData -> do
- let
- nudgeCellName :: Text -> Text
- nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
- (cData, ) <$> mkCellWidget miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
-
- liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords
- let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult))
- result = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults
+ sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (BoxCoord liveliness, cellData), Widget))
addForm = addForm' boxOrigin . zip [0..]
@@ -162,18 +230,66 @@ massInput mkAddWidget mkCellWidget FieldSettings{..} fvRequired initialResult =
addForm' miCoord ((dimIx, _) : remDims) = do
let nudgeAddWidgetName :: Text -> Text
nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
- dimRes <- traverse ($ mempty) $ mkAddWidget dimIx liveliness nudgeAddWidgetName
+ dimRes <- runMaybeT $ do
+ (btnRes, btnView) <- lift $ mpreq (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..}) Nothing
+ (addRes, addView) <- MaybeT . traverse ($ mempty) $ miAdd miCoord dimIx sentLiveliness nudgeAddWidgetName btnView
+ return (btnRes *> addRes, addView)
let dimRes' = maybe Map.empty (Map.singleton (dimIx, miCoord)) dimRes
case remDims of
[] -> return dimRes'
((_, BoxDimension dim) : _) -> do
let
- miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
+ miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord
dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
return $ dimRes' `Map.union` fold dimRess
addResults <- addForm boxDimensions
+ let addShape
+ | [FormSuccess (bCoord, cData)] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst addResults = Just $ Map.insert bCoord cData sentShape'
+ | otherwise = Nothing
+
+ addedShape <- if
+ | Just s <- addShape -> return s
+ | otherwise -> return sentShape'
+ addedLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet addedShape ^? liveCoords :: MForm handler liveliness
+
+ let
+ delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
+ delForm miCoord = do
+ (delRes, delView) <- lift $ mpreq (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..}) Nothing
+ $logDebugS "delForm" . tshow $ fmap toPathPiece delRes
+ shapeUpdate <- miDelete addedLiveliness miCoord
+ guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
+ return (shapeUpdate <$ delRes, delView)
+
+ delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
+ let delShape
+ | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = traverse (flip Map.lookup addedShape) shapeUpdate'
+ | otherwise = Nothing
+
+
+ shape <- if
+ | Just s <- delShape -> return s
+ | Just s <- addShape -> return s
+ | otherwise -> return sentShape'
+
+ shapeId <- newIdent
+ let
+ shapeInput = fieldView shapeField shapeId (toPathPiece shapeName) [] (Right shape) True
+
+ cellResults <- flip Map.traverseWithKey shape $ \miCoord cData -> do
+ let
+ nudgeCellName :: Text -> Text
+ nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
+ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
+ let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult))
+ result
+ | isJust addShape || isJust delShape = 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) =
@@ -182,6 +298,7 @@ massInput mkAddWidget mkCellWidget FieldSettings{..} fvRequired initialResult =
| [] <- remDims = do
coord <- coords
Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults
+ let deleteButton = snd <$> Map.lookup coord delResults
return (coord, $(widgetFile "widgets/massinput/cell"))
| otherwise =
[ (coord, miWidget coord remDims) | coord <- coords ]
@@ -194,6 +311,10 @@ massInput mkAddWidget mkCellWidget FieldSettings{..} fvRequired initialResult =
let
fvLabel = toHtml $ mr fsLabel
fvTooltip = toHtml . mr <$> fsTooltip
- fvInput = miWidget boxOrigin $ zip [0..] boxDimensions
+ fvInput = mconcat
+ [ toWidget csrf
+ , shapeInput
+ , miWidget boxOrigin $ zip [0..] boxDimensions
+ ]
fvErrors = Nothing
- return (result, FieldView{..})
+ in return (result, FieldView{..})
diff --git a/src/Utils.hs b/src/Utils.hs
index 4e2b5c6de..fa4ec109c 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -497,7 +497,7 @@ assertM f x = x >>= assertM' f
assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
assertM_ f x = guard . f =<< x
-assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
+assertM' :: Alternative m => (a -> Bool) -> a -> m a
assertM' f x = x <$ guard (f x)
-- Some Utility Functions from Agda.Utils.Monad
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index cb7daeb8e..049217701 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -249,6 +249,7 @@ identifyForm' resLens identVal form fragment = do
identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
identifyForm = identifyForm' id
+
{- Hinweise zur Erinnerung:
- identForm primär, wenn es mehr als ein Formular pro Handler gibt
@@ -573,6 +574,12 @@ apreq f fs mx = formToAForm $ do
mr <- getMessageRender
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
+mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+ => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
+mpreq f fs mx = do
+ mr <- getMessageRender
+ over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
+
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wpreq f fs mx = mFormToWForm $ do
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index b8ac05e63..dcb8f6590 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -80,6 +80,8 @@ makeLenses_ ''SheetType
makePrisms ''AuthResult
+makePrisms ''FormResult
+
-- makeClassy_ ''Load
diff --git a/templates/widgets/massinput/cell.hamlet b/templates/widgets/massinput/cell.hamlet
index de6e44d7a..8a9654357 100644
--- a/templates/widgets/massinput/cell.hamlet
+++ b/templates/widgets/massinput/cell.hamlet
@@ -1 +1,3 @@
^{cellWdgt}
+$maybe delWdgt <- fmap fvInput deleteButton
+ ^{delWdgt}