Start on implementation

src/Handler/Utils/Form/MassInput.hs

@@ -7,6 +7,7 @@ module Handler.Utils.Form.MassInput
 
 import Import
 import Utils.Form
+import Handler.Utils.Form (secretJsonField)
 
 import Data.Aeson
 
@@ -18,23 +19,28 @@ import Text.Blaze (Markup)
 
 import qualified Data.Text as Text
 
+import qualified Data.Set as Set
+import qualified Data.Map as Map
 import Data.List (genericLength, genericIndex)
 
 
-data BoxDimension x = forall n. Enum n => BoxDimension (Lens' x n)
+data BoxDimension x = forall n. (Enum n, Num 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 :: IsBoxCoord x => Natural -> BoxDimension x
 boxDimension n
-  | n < genericLength dims = Just $ genericIndex dims n
+  | n < genericLength dims = genericIndex dims n
-  | otherwise = Nothing
+  | otherwise = error "boxDimension: insufficient dimensions"
   where
     dims = boxDimensions
+
+zeroDimension :: IsBoxCoord x => Natural -> x -> x
+zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
   
-class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
+class (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
@@ -73,17 +79,37 @@ instance PathPiece coord => Button UniWorX (ButtonMassInput coord) where
 
 
 data MassInputFieldName coord
-  = MassInputCell coord Text
+  = MassInputShape { miName :: Text }
+  | MassInputAddWidget { miName :: Text, miCoord :: coord, miAddWidgetField :: Text }
+  | MassInputCell { miName :: Text, miCoord :: coord, miCellField :: Text }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where
   toPathPiece = \case
-    MassInputCell (toPathPiece -> coord) name -> coord <> "__" <> name
+    MassInputShape{..} -> [st|#{miName}__shape|]
+    MassInputAddWidget{..} -> [st|#{miName}__#{toPathPiece miCoord}__#{miAddWidgetField}|]
+    MassInputCell{..} -> [st|#{miName}__#{toPathPiece miCoord}__#{miCellField}|]
 
   fromPathPiece t = do
-    (coordT, Text.stripPrefix "__" -> Just name) <- return $ Text.breakOn "__" t
+    (miName, Text.stripPrefix "__" -> Just t') <- return $ Text.breakOn "__" t
-    coord <- fromPathPiece coordT
+    choice
-    return $ MassInputCell coord name
+      [ do
+          guard $ t' == "shape"
+          return MassInputShape{..}
+      , do
+          (coordT, Text.stripPrefix "__" -> Just miCellField) <- return $ Text.breakOn "__" t'
+          miCoord <- fromPathPiece coordT
+          return MassInputAddWidget{..}
+      , do
+          (coordT, Text.stripPrefix "__" -> Just miCellField) <- return $ Text.breakOn "__" t'
+          miCoord <- fromPathPiece coordT
+          return MassInputCell{..}
+      ]
+
+data MassInputException = MassInputInvalidShape
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Exception MassInputException
 
 massInput :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
@@ -93,14 +119,43 @@ massInput :: forall handler cellData cellResult liveliness.
           => (    Natural -- ^ Zero-based dimension index
                -> liveliness -- ^ Currently live positions
                -> (Text -> Text) -- ^ Nudge deterministic field ids 
-               -> (Markup -> MForm handler (FormResult (cellData, BoxCoord liveliness), Widget))
+               -> (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
           -> FieldSettings UniWorX
-          -> MForm handler (FormResult (Map (BoxCoord liveliness) cellResult), FieldView UniWorX)
+          -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-massInput mkAddWidget mkCellWidget FieldSettings{..} = do
+          -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), Widget)
-  error "massInput: not implemented"
+massInput _mkAddWidget mkCellWidget FieldSettings{..} initialResult = do
+  miName <- maybe newFormIdent return fsName
+  let
+    shapeName :: MassInputFieldName (BoxCoord liveliness)
+    shapeName = MassInputShape{..}
+  (shape', _shapeWdgt) <- mreq secretJsonField ("" & addName shapeName) $ fmap fst <$> initialResult
+  shape <- if
+    | FormSuccess s <- shape' -> return s
+    | Just (fmap fst -> iS) <- initialResult -> return iS
+    | Just iS <- Set.empty ^? liveCoords -> return iS
+    | otherwise -> throwM MassInputInvalidShape
+  cellResults <- forM shape $ \(miCoord, cData) -> do
+    let
+      nudgeCellName :: Text -> Text
+      nudgeCellName miCellField = toPathPiece MassInputCell{..}
+    (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
+      miWidget :: [BoxDimension (BoxCoord liveliness)] -> Widget
+      miWidget = miWidget' nudgeAddWidgetName 0 liveliness
+      nudgeAddWidgetName :: Text -> Text
+      nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
+  return (result, miWidget boxDimensions)
+  where
+    miWidget' :: (Text -> Text) -> Natural -> liveliness -> [BoxDimension (BoxCoord liveliness)] -> Widget
+    miWidget' nudge dimIx liveliness [] = mempty
+    miWidget' nudge dimIx liveliness (BoxDimension dim : remDims)
+      = error "not implemented"

src/Utils.hs

@@ -508,6 +508,12 @@ mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
 mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
 mconcatForM = flip mconcatMapM
 
+-----------------
+-- Alternative --
+-----------------
+
+choice :: forall f mono a. (Alternative f, MonoFoldable mono, Element mono ~ f a) => mono -> f a
+choice = foldr (<|>) empty
 
 --------------
 -- Sessions --

src/Utils/Form.hs

@@ -108,8 +108,8 @@ addClass = addAttr "class"
 addClasses :: [Text] -> FieldSettings site -> FieldSettings site
 addClasses = addAttrs "class"
 
-addName :: Text -> FieldSettings site -> FieldSettings site
+addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site
-addName nm fs = fs { fsName = Just nm }
+addName nm fs = fs { fsName = Just $ toPathPiece nm }
 
 addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
 addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }