From c0edc87926cecb7f306e128b6c515accd717943f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 27 Feb 2019 13:07:22 +0100 Subject: [PATCH] Start on implementation --- src/Handler/Utils/Form/MassInput.hs | 83 ++++++++++++++++++++++++----- src/Utils.hs | 6 +++ src/Utils/Form.hs | 4 +- 3 files changed, 77 insertions(+), 16 deletions(-) diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index c24770b61..f89991736 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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 - | otherwise = Nothing + | n < genericLength dims = genericIndex dims n + | 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 - coord <- fromPathPiece coordT - return $ MassInputCell coord name + (miName, Text.stripPrefix "__" -> Just t') <- return $ Text.breakOn "__" t + choice + [ 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) -massInput mkAddWidget mkCellWidget FieldSettings{..} = do - error "massInput: not implemented" + -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult)) + -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), Widget) +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" diff --git a/src/Utils.hs b/src/Utils.hs index 2990778dc..ed9e0ea57 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 6fab13a32..0a2487eec 100644 --- a/src/Utils/Form.hs +++ b/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 nm fs = fs { fsName = Just nm } +addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site +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 }