From 332493f5501495dd684286417af5e9a5d15dd182 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 13 Mar 2019 09:25:00 +0100 Subject: [PATCH] View-Prototype of MassInput --- src/Handler/Utils/Form/MassInput.hs | 82 ++++++++++++++++++------- templates/widgets/massinput/cell.hamlet | 1 + templates/widgets/massinput/row.hamlet | 7 +++ 3 files changed, 68 insertions(+), 22 deletions(-) create mode 100644 templates/widgets/massinput/cell.hamlet create mode 100644 templates/widgets/massinput/row.hamlet diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index f89991736..b135e3a6c 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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 (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim +-- zeroDimension :: IsBoxCoord x => Natural -> x -> x +-- 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) -massInput _mkAddWidget mkCellWidget FieldSettings{..} initialResult = do + -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX) +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 <- Set.empty ^? liveCoords -> return iS + | Just iS <- initialShape -> 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 - 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" + + let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (BoxCoord liveliness, cellData), Widget)) + addForm = addForm' boxOrigin . zip [0..] + where + addForm' _ [] = return Map.empty + addForm' miCoord ((dimIx, _) : remDims) = do + let nudgeAddWidgetName :: Text -> Text + nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..} + dimRes <- traverse ($ mempty) $ mkAddWidget dimIx liveliness nudgeAddWidgetName + 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{..}) diff --git a/templates/widgets/massinput/cell.hamlet b/templates/widgets/massinput/cell.hamlet new file mode 100644 index 000000000..de6e44d7a --- /dev/null +++ b/templates/widgets/massinput/cell.hamlet @@ -0,0 +1 @@ +^{cellWdgt} diff --git a/templates/widgets/massinput/row.hamlet b/templates/widgets/massinput/row.hamlet new file mode 100644 index 000000000..8c43c9896 --- /dev/null +++ b/templates/widgets/massinput/row.hamlet @@ -0,0 +1,7 @@ +