Plan for MassInput-Controls being buttons

messages/uniworx/de.msg

@@ -611,4 +611,6 @@ 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
-MassInputUpdate: Formular aktualisieren
+
+MassInputAddDimension: Hinzufügen
+MassInputDeleteCell: Entfernen

src/Handler/Utils/Form/MassInput.hs

@@ -1,6 +1,8 @@
 module Handler.Utils.Form.MassInput
   ( massInput
-  , BoxDimension(..), IsBoxCoord(..), Liveliness(..)
+  , BoxDimension(..)
+  , IsBoxCoord(..), boxDimension
+  , Liveliness(..)
   ) where
 
 import Import
@@ -14,15 +16,23 @@ import Control.Lens hiding (universe)
 
 import Text.Blaze (Markup)
 
-import Data.List ((!!), elemIndex)
 import qualified Data.Text as Text
 
+import Data.List (genericLength, genericIndex)
+
 
 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
+
+boxDimension :: IsBoxCoord x => Natural -> Maybe (BoxDimension x)
+boxDimension n
+  | n < genericLength dims = Just $ genericIndex dims n
+  | otherwise = Nothing
+  where
+    dims = boxDimensions
   
 class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
   type BoxCoord a :: *
@@ -30,75 +40,55 @@ class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemi
   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
+data ButtonMassInput coord
   = MassInputAddDimension Natural
-  | MassInputDeleteCell x
-  | MassInputCell x Text
+  | MassInputDeleteCell coord
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-instance IsBoxCoord x => PathPiece (MassInputFieldName x) where
+instance PathPiece coord => PathPiece (ButtonMassInput coord) where
+  toPathPiece = \case
+    MassInputAddDimension n -> "add__" <> toPathPiece n
+    MassInputDeleteCell c -> "delete__" <> toPathPiece c
+  fromPathPiece t = addDim <|> delCell
+    where
+      addDim = do
+        nT <- stripPrefix "add__" t
+        MassInputAddDimension <$> fromPathPiece nT
+      delCell = do
+        coordT <- stripPrefix "delete__" t
+        MassInputDeleteCell <$> fromPathPiece coordT
+
+instance RenderMessage UniWorX (ButtonMassInput coord) where
+  renderMessage f ls = \case
+    MassInputAddDimension _ -> mr MsgMassInputAddDimension
+    MassInputDeleteCell _ -> mr MsgMassInputDeleteCell
+    where
+      mr = renderMessage f ls
+
+instance PathPiece coord => Button UniWorX (ButtonMassInput coord) where
+  btnValidate _ _ = False
+
+  btnClasses (MassInputAddDimension _) = [BCIsButton, BCDefault]
+  btnClasses (MassInputDeleteCell _) = [BCIsButton, BCWarning]
+
+
+data MassInputFieldName coord
+  = MassInputCell coord Text
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) 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
+  fromPathPiece t = 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.
+massInput :: forall handler cellData cellResult liveliness.
            ( 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
@@ -111,7 +101,6 @@ massInput :: forall handler cellData cellResult liveliness submit p.
                -> (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
+massInput mkAddWidget mkCellWidget FieldSettings{..} = do
   error "massInput: not implemented"

src/Import/NoFoundation.hs

@@ -61,6 +61,8 @@ import Database.Esqueleto.Instances as Import ()
 import Database.Persist.Sql.Instances as Import ()
 import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
 
+import Numeric.Natural.Instances as Import ()
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Numeric/Natural/Instances.hs

@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Numeric.Natural.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Numeric.Natural
+import Web.PathPieces
+
+instance PathPiece Natural where
+  toPathPiece = tshow
+  fromPathPiece = readMay