View-Prototype of MassInput

src/Handler/Utils/Form/MassInput.hs

@@ -21,7 +21,7 @@ import qualified Data.Text as Text
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
-import Data.List (genericLength, genericIndex)
+import Data.List (genericLength, genericIndex, iterate)
 
 
 data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
@@ -37,8 +37,8 @@ boxDimension n
   where
     dims = boxDimensions
 
-zeroDimension :: IsBoxCoord x => Natural -> x -> x
+-- zeroDimension :: IsBoxCoord x => Natural -> x -> x
-zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
+-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
   
 class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
   type BoxCoord a :: *
@@ -97,7 +97,7 @@ instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where
           guard $ t' == "shape"
           return MassInputShape{..}
       , do
-          (coordT, Text.stripPrefix "__" -> Just miCellField) <- return $ Text.breakOn "__" t'
+          (coordT, Text.stripPrefix "__" -> Just miAddWidgetField) <- return $ Text.breakOn "__" t'
           miCoord <- fromPathPiece coordT
           return MassInputAddWidget{..}
       , do
@@ -119,7 +119,7 @@ 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 (BoxCoord liveliness, cellData), Widget))
+               -> Maybe (Markup -> MForm handler (FormResult (BoxCoord liveliness, cellData), Widget))
              ) -- ^ Generate a cell-addition widget
           -> (    BoxCoord liveliness
                -> cellData
@@ -128,34 +128,72 @@ massInput :: forall handler cellData cellResult liveliness.
                -> (Markup -> MForm handler (FormResult cellResult, Widget))
              ) -- ^ Cell-Widget
           -> FieldSettings UniWorX
+          -> Bool -- ^ Required?
           -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-          -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), Widget)
+          -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX)
-massInput _mkAddWidget mkCellWidget FieldSettings{..} initialResult = do
+massInput mkAddWidget mkCellWidget FieldSettings{..} fvRequired initialResult = do
+  let initialShape = fmap fst <$> initialResult
+  
   miName <- maybe newFormIdent return fsName
   let
     shapeName :: MassInputFieldName (BoxCoord liveliness)
     shapeName = MassInputShape{..}
-  (shape', _shapeWdgt) <- mreq secretJsonField ("" & addName shapeName) $ fmap fst <$> initialResult
+  (shape', _shapeWdgt) <- mreq secretJsonField ("" & addName shapeName) $ initialShape 
   shape <- if
     | FormSuccess s <- shape' -> return s
-    | Just (fmap fst -> iS) <- initialResult -> return iS
+    | Just iS <- initialShape -> return iS
-    | Just iS <- Set.empty ^? liveCoords -> return iS
+    | Set.null $ review liveCoords (bottom :: liveliness) -> return Map.empty
     | otherwise -> throwM MassInputInvalidShape
-  cellResults <- forM shape $ \(miCoord, cData) -> do
+
+  cellResults <- flip Map.traverseWithKey shape $ \miCoord cData -> do
     let
       nudgeCellName :: Text -> Text
-      nudgeCellName miCellField = toPathPiece MassInputCell{..}
+      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
-      miWidget :: [BoxDimension (BoxCoord liveliness)] -> Widget
+
-      miWidget = miWidget' nudgeAddWidgetName 0 liveliness
+  let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (BoxCoord liveliness, cellData), Widget))
-      nudgeAddWidgetName :: Text -> Text
+      addForm = addForm' boxOrigin . zip [0..]
-      nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
+        where
-  return (result, miWidget boxDimensions)
+          addForm' _ [] = return Map.empty
-  where
+          addForm' miCoord ((dimIx, _) : remDims) = do
-    miWidget' :: (Text -> Text) -> Natural -> liveliness -> [BoxDimension (BoxCoord liveliness)] -> Widget
+            let nudgeAddWidgetName :: Text -> Text
-    miWidget' nudge dimIx liveliness [] = mempty
+                nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
-    miWidget' nudge dimIx liveliness (BoxDimension dim : remDims)
+            dimRes <- traverse ($ mempty) $ mkAddWidget dimIx liveliness nudgeAddWidgetName
-      = error "not implemented"
+            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
+                dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
+                return $ dimRes' `Map.union` fold dimRess
+
+  addResults <- addForm boxDimensions
+  
+  let miWidget :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
+      miWidget _ [] = mempty
+      miWidget miCoord ((dimIx, BoxDimension dim) : remDims) =
+        let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
+            cells
+              | [] <- remDims = do
+                  coord <- coords
+                  Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults 
+                  return (coord, $(widgetFile "widgets/massinput/cell"))
+              | otherwise =
+                  [ (coord, miWidget coord remDims) | coord <- coords ]
+            addWidget = snd <$> Map.lookup (dimIx, miCoord) addResults
+         in $(widgetFile "widgets/massinput/row")
+
+  MsgRenderer mr <- getMsgRenderer
+  fvId <- maybe newIdent return fsId
+  
+  let
+    fvLabel = toHtml $ mr fsLabel
+    fvTooltip = toHtml . mr <$> fsTooltip
+    fvInput = miWidget boxOrigin $ zip [0..] boxDimensions
+    fvErrors = Nothing
+  return (result, FieldView{..})

templates/widgets/massinput/cell.hamlet

@@ -0,0 +1 @@
+^{cellWdgt}

templates/widgets/massinput/row.hamlet

@@ -0,0 +1,7 @@
+<ul .massinput--row .#{"massinput--dim" <> toPathPiece dimIx}>
+  $forall (cellCoord, cell) <- cells
+    <li .massinput--cell data-massinput-coord=#{toPathPiece cellCoord}>
+      ^{cell}
+  $maybe add <- addWidget
+    <li .massinput--add>
+      ^{add}