Initial work on MassInput

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
+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

package.yaml

@@ -114,6 +114,7 @@ dependencies:
   - memcached-binary
   - directory-tree
   - lifted-base
+  - lattices
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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"