diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4f6f91a82..c638a4ba4 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -608,4 +608,5 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n " DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. -DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde \ No newline at end of file +DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde +MassInputUpdate: Formular aktualisieren diff --git a/package.yaml b/package.yaml index 46af6eab8..57b4b508d 100644 --- a/package.yaml +++ b/package.yaml @@ -114,6 +114,7 @@ dependencies: - memcached-binary - directory-tree - lifted-base + - lattices other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs new file mode 100644 index 000000000..36b7aea40 --- /dev/null +++ b/src/Handler/Utils/Form/MassInput.hs @@ -0,0 +1,117 @@ +module Handler.Utils.Form.MassInput + ( massInput + , BoxDimension(..), IsBoxCoord(..), Liveliness(..) + ) where + +import Import +import Utils.Form + +import Data.Aeson + +import Algebra.Lattice + +import Control.Lens hiding (universe) + +import Text.Blaze (Markup) + +import Data.List ((!!), elemIndex) +import qualified Data.Text as Text + + +data BoxDimension x = forall n. Enum n => BoxDimension (Lens' x n) + +class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where + boxDimensions :: [BoxDimension x] + boxOrigin :: x + +class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where + type BoxCoord a :: * + liveCoords :: Prism' (Set (BoxCoord a)) a + liveCoord :: BoxCoord a -> Prism' Bool a + + +data MassInputButton submit + = MassInputUpdate + | MassInputSubmit submit + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Bounded submit => Bounded (MassInputButton submit) where + minBound = MassInputUpdate + maxBound = MassInputSubmit maxBound + +instance (Eq submit, Finite submit) => Enum (MassInputButton submit) where + toEnum = (!!) universe + fromEnum = fromMaybe (error "fromEnum: value not found") . flip elemIndex universeF + +instance Finite submit => Universe (MassInputButton submit) where + universe = MassInputUpdate : map MassInputSubmit universeF +instance Finite submit => Finite (MassInputButton submit) + +instance PathPiece submit => PathPiece (MassInputButton submit) where + toPathPiece = \case + MassInputUpdate -> "update" + MassInputSubmit s -> "submit__" <> toPathPiece s + fromPathPiece t = inpUpdate <|> submit + where + inpUpdate = MassInputUpdate <$ guard (t == "update") + submit = do + submitT <- stripPrefix "submit__" t + MassInputSubmit <$> fromPathPiece submitT + +instance (Button UniWorX submit, Finite submit) => Button UniWorX (MassInputButton submit) where + label MassInputUpdate = [whamlet|_{MsgMassInputUpdate}|] + label (MassInputSubmit submit) = label submit + + btnValidate _ MassInputUpdate = False + btnValidate proxy (MassInputSubmit submit) = btnValidate proxy submit + + cssClass MassInputUpdate = BCDefault + cssClass (MassInputSubmit submit) = cssClass submit + + +data MassInputFieldName x + = MassInputAddDimension Natural + | MassInputDeleteCell x + | MassInputCell x Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance IsBoxCoord x => PathPiece (MassInputFieldName x) where + toPathPiece = \case + MassInputAddDimension dim -> "addField--" <> tshow dim + MassInputDeleteCell (toPathPiece -> coord) -> "delCell--" <> coord + MassInputCell (toPathPiece -> coord) name -> coord <> "__" <> name + + fromPathPiece t = addDimension <|> deleteCell <|> cell + where + addDimension = do + dim <- Text.stripPrefix "addField--" t >>= readMay + return $ MassInputAddDimension dim + deleteCell = do + coord <- Text.stripPrefix "delCell--" t >>= fromPathPiece + return $ MassInputDeleteCell coord + cell = do + (coordT, Text.stripPrefix "__" -> Just name) <- return $ Text.breakOn "__" t + coord <- fromPathPiece coordT + return $ MassInputCell coord name + +massInput :: forall handler cellData cellResult liveliness submit p. + ( MonadHandler handler, HandlerSite handler ~ UniWorX + , ToJSON cellData, FromJSON cellData + , Liveliness liveliness + , Button UniWorX submit, Finite submit + ) + => ( Natural -- ^ Zero-based dimension index + -> liveliness -- ^ Currently live positions + -> (Text -> Text) -- ^ Nudge deterministic field ids + -> (Markup -> MForm handler (FormResult (cellData, BoxCoord liveliness), Widget)) + ) -- ^ Generate a cell-addition widget + -> ( BoxCoord liveliness + -> cellData + -> (Text -> Text) -- ^ Nudge deterministic field ids + -> (Markup -> MForm handler (FormResult cellResult, Widget)) + ) -- ^ Cell-Widget + -> FieldSettings UniWorX + -> p submit + -> MForm handler (FormResult (Map (BoxCoord liveliness) cellResult), FieldView UniWorX) +massInput mkAddWidget mkCellWidget FieldSettings{..} _ = do + error "massInput: not implemented"