482 lines
22 KiB
Haskell
482 lines
22 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module Handler.Utils.Form.MassInput
|
|
( MassInput(..)
|
|
, defaultMiLayout
|
|
, massInput
|
|
, module Handler.Utils.Form.MassInput.Liveliness
|
|
, massInputA
|
|
, massInputList
|
|
, ListLength(..), ListPosition(..), miDeleteList
|
|
, EnumLiveliness(..), EnumPosition(..)
|
|
, MapLiveliness(..)
|
|
) where
|
|
|
|
import Import
|
|
import Utils.Form
|
|
import Utils.Lens
|
|
import Handler.Utils.Form (secretJsonField)
|
|
import Handler.Utils.Form.MassInput.Liveliness
|
|
import Handler.Utils.Form.MassInput.TH
|
|
|
|
import Data.Aeson
|
|
|
|
import Algebra.Lattice
|
|
|
|
import Text.Blaze (Markup)
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.IntSet as IntSet
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Foldable as Fold
|
|
|
|
import Control.Monad.Reader.Class (MonadReader(local))
|
|
|
|
|
|
$(mapM tupleBoxCoord [2..4])
|
|
|
|
|
|
newtype ListLength = ListLength { unListLength :: Natural }
|
|
deriving newtype (Num, Integral, Real, Enum, PathPiece)
|
|
deriving (Eq, Ord, Generic, Typeable, Read, Show)
|
|
|
|
makeWrapped ''ListLength
|
|
|
|
instance JoinSemiLattice ListLength where
|
|
(\/) = max
|
|
instance MeetSemiLattice ListLength where
|
|
(/\) = min
|
|
instance Lattice ListLength
|
|
instance BoundedJoinSemiLattice ListLength where
|
|
bottom = 0
|
|
|
|
newtype ListPosition = ListPosition { unListPosition :: Natural }
|
|
deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
|
|
deriving (Eq, Ord, Generic, Typeable, Read, Show)
|
|
|
|
makeWrapped ''ListPosition
|
|
|
|
instance IsBoxCoord ListPosition where
|
|
boxDimensions = [BoxDimension _Wrapped]
|
|
boxOrigin = 0
|
|
|
|
instance Liveliness ListLength where
|
|
type BoxCoord ListLength = ListPosition
|
|
liveCoords = prism' toSet fromSet
|
|
where
|
|
toSet n
|
|
| n > 0 = Set.fromList [0..pred (fromIntegral n)]
|
|
| otherwise = Set.empty
|
|
|
|
fromSet ns
|
|
| ns == maybe Set.empty (\n -> Set.fromList [0..n]) max'
|
|
= fmap (succ . fromIntegral) max' <|> Just 0
|
|
| otherwise
|
|
= Nothing
|
|
where
|
|
max' = Set.lookupMax ns
|
|
liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just bottom) (1 <$ guard (n == 0)))
|
|
|
|
|
|
newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet }
|
|
deriving (Eq, Ord, Generic, Typeable, Read, Show)
|
|
|
|
makeWrapped ''EnumLiveliness
|
|
|
|
instance JoinSemiLattice (EnumLiveliness enum) where
|
|
(EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b
|
|
instance MeetSemiLattice (EnumLiveliness enum) where
|
|
(EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b
|
|
instance Lattice (EnumLiveliness enum)
|
|
instance BoundedJoinSemiLattice (EnumLiveliness enum) where
|
|
bottom = EnumLiveliness IntSet.empty
|
|
instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where
|
|
top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound]
|
|
instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum)
|
|
|
|
|
|
newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
|
|
deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
|
|
deriving (Eq, Ord, Generic, Typeable, Read, Show)
|
|
|
|
makeWrapped ''EnumPosition
|
|
|
|
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
|
|
boxDimensions = [BoxDimension _Wrapped]
|
|
boxOrigin = minBound
|
|
|
|
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where
|
|
type BoxCoord (EnumLiveliness enum) = EnumPosition enum
|
|
liveCoords = iso fromSet toSet
|
|
where
|
|
toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness
|
|
fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList
|
|
|
|
|
|
newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l1) l2 }
|
|
deriving (Generic, Typeable)
|
|
|
|
makeWrapped ''MapLiveliness
|
|
|
|
deriving instance (Ord (BoxCoord l1), JoinSemiLattice l2) => JoinSemiLattice (MapLiveliness l1 l2)
|
|
deriving instance (Ord (BoxCoord l1), MeetSemiLattice l2) => MeetSemiLattice (MapLiveliness l1 l2)
|
|
deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
|
|
deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
|
|
deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
|
|
deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedLattice l2) => BoundedLattice (MapLiveliness l1 l2)
|
|
deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
|
|
deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
|
|
deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
|
|
deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2)
|
|
|
|
instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where
|
|
type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2)
|
|
liveCoords = prism'
|
|
(Set.fromList . concatMap (\(k, v) -> (k, ) <$> Set.toAscList (review liveCoords v)) . Map.toAscList . unMapLiveliness)
|
|
(\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
|
|
|
|
|
|
|
|
miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
|
|
miDeleteList l pos
|
|
-- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
|
|
| l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
|
|
| otherwise = pure Map.empty
|
|
|
|
data ButtonMassInput coord
|
|
= MassInputAddDimension Natural coord
|
|
| MassInputDeleteCell coord
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance PathPiece coord => PathPiece (ButtonMassInput coord) where
|
|
toPathPiece = \case
|
|
MassInputAddDimension n c -> "add__" <> toPathPiece n <> "__" <> toPathPiece c
|
|
MassInputDeleteCell c -> "delete__" <> toPathPiece c
|
|
fromPathPiece t = addDim <|> delCell
|
|
where
|
|
addDim = do
|
|
(dimT, Text.stripPrefix "__" -> Just coordT) <- Text.breakOn "__" <$> stripPrefix "add__" t
|
|
MassInputAddDimension <$> fromPathPiece dimT <*> fromPathPiece coordT
|
|
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, BCMassInputAdd]
|
|
btnClasses (MassInputDeleteCell _) = [BCIsButton, BCWarning, BCMassInputDelete]
|
|
|
|
|
|
data MassInputFieldName coord
|
|
= MassInputShape { miName :: Text }
|
|
| MassInputAddWidget { miName :: Text, miCoord :: coord, miAddWidgetField :: Text }
|
|
| MassInputAddButton { miName :: Text, miCoord :: coord }
|
|
| MassInputDeleteButton { miName :: Text, miCoord :: coord }
|
|
| MassInputCell { miName :: Text, miCoord :: coord, miCellField :: Text }
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where
|
|
toPathPiece = \case
|
|
MassInputShape{..} -> [st|#{miName}__shape|]
|
|
MassInputAddWidget{..} -> [st|#{miName}__add__#{toPathPiece miCoord}__fields__#{miAddWidgetField}|]
|
|
MassInputAddButton{..} -> [st|#{miName}__add__#{toPathPiece miCoord}__submit|]
|
|
MassInputDeleteButton{..} -> [st|#{miName}__delete__#{toPathPiece miCoord}|]
|
|
MassInputCell{..} -> [st|#{miName}__cells__#{toPathPiece miCoord}__#{miCellField}|]
|
|
|
|
fromPathPiece t = do
|
|
(miName, Text.stripPrefix "__" -> Just t') <- return $ Text.breakOn "__" t
|
|
choice
|
|
[ do
|
|
guard $ t' == "shape"
|
|
return MassInputShape{..}
|
|
, do
|
|
t'' <- Text.stripPrefix "add__" t'
|
|
(coordT, Text.stripPrefix "__" -> Just rest) <- return $ Text.breakOn "__" t''
|
|
miAddWidgetField <- Text.stripPrefix "fields__" rest
|
|
miCoord <- fromPathPiece coordT
|
|
return MassInputAddWidget{..}
|
|
, do
|
|
t'' <- Text.stripPrefix "add__" t'
|
|
(coordT, Text.stripPrefix "__" -> Just ident) <- return $ Text.breakOn "__" t''
|
|
guard $ ident == "submit"
|
|
miCoord <- fromPathPiece coordT
|
|
return MassInputAddButton{..}
|
|
, do
|
|
t'' <- Text.stripPrefix "delete__" t'
|
|
(coordT, rest) <- return $ Text.breakOn "__" t''
|
|
guard $ Text.null rest
|
|
miCoord <- fromPathPiece coordT
|
|
return MassInputDeleteButton{..}
|
|
, do
|
|
t'' <- Text.stripPrefix "cells__" t'
|
|
(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
|
|
|
|
data MassInput handler liveliness cellData cellResult = MassInput
|
|
{ miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero)
|
|
-> Natural -- Zero-based dimension index @dimIx@
|
|
-> (Text -> Text) -- Nudge deterministic field ids
|
|
-> FieldView UniWorX -- Submit button
|
|
-> Maybe (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
|
|
, miCell :: BoxCoord liveliness -- Position
|
|
-> cellData -- @cellData@ from @miAdd@
|
|
-> Maybe cellResult -- Initial result from Argument to @massInput@
|
|
-> (Text -> Text) -- Nudge deterministic field ids
|
|
-> (Markup -> MForm handler (FormResult cellResult, Widget)) -- ^ Construct a singular cell
|
|
, miDelete :: liveliness
|
|
-> BoxCoord liveliness
|
|
-> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants
|
|
, miAllowAdd :: BoxCoord liveliness
|
|
-> Natural
|
|
-> liveliness
|
|
-> Bool -- ^ Decide whether an addition-operation should be permitted
|
|
, miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
|
|
, miLayout :: liveliness
|
|
-> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
|
|
-> Map (BoxCoord liveliness) Widget -- ^ Cell Widgets
|
|
-> Map (BoxCoord liveliness) (FieldView UniWorX) -- ^ Delete buttons
|
|
-> Map (Natural, BoxCoord liveliness) Widget -- ^ Addition forms
|
|
-> Widget
|
|
}
|
|
|
|
massInput :: forall handler cellData cellResult liveliness.
|
|
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
|
, ToJSON cellData, FromJSON cellData
|
|
, Liveliness liveliness
|
|
, MonadLogger handler
|
|
)
|
|
=> MassInput handler liveliness cellData cellResult
|
|
-> FieldSettings UniWorX
|
|
-> Bool -- ^ Required?
|
|
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
|
|
-> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
|
|
massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
|
|
let initialShape = fmap fst <$> initialResult
|
|
|
|
miName <- maybe newFormIdent return fsName
|
|
fvId <- maybe newIdent return fsId
|
|
miAction <- traverse toTextUrl $ miButtonAction fvId
|
|
let addFormAction = maybe id (addAttr "formaction") miAction
|
|
|
|
let
|
|
shapeName :: MassInputFieldName (BoxCoord liveliness)
|
|
shapeName = MassInputShape{..}
|
|
shapeField = secretJsonField
|
|
sentShape <- runMaybeT $ do
|
|
ts <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askParams
|
|
fs <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askFiles
|
|
MaybeT $ either (const Nothing) id <$> lift (fieldParse shapeField ts fs)
|
|
sentShape' <- if
|
|
| Just s <- sentShape -> return s
|
|
| Just iS <- initialShape -> return iS
|
|
| Set.null $ review liveCoords (bottom :: liveliness) -> return Map.empty
|
|
| otherwise -> throwM MassInputInvalidShape
|
|
sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
|
|
|
|
let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
|
|
addForm = addForm' boxOrigin . zip [0..]
|
|
where
|
|
addForm' _ [] = return Map.empty
|
|
addForm' miCoord ((dimIx, _) : remDims) = do
|
|
let nudgeAddWidgetName :: Text -> Text
|
|
nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
|
|
(btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
|
|
let btnRes = do
|
|
Just x <- btnRes'
|
|
return x
|
|
wBtnRes res = do
|
|
guard $ isn't _FormMissing btnRes
|
|
res
|
|
addRes' <- over (mapped . _Just . _1) wBtnRes . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $
|
|
miAdd miCoord dimIx nudgeAddWidgetName btnView
|
|
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
|
|
case remDims of
|
|
[] -> return dimRes'
|
|
((_, BoxDimension dim) : _) -> do
|
|
let
|
|
miCoords
|
|
= Set.fromList
|
|
. takeWhile (\c -> review (liveCoord c) sentLiveliness)
|
|
$ set dim <$> enumFrom (miCoord ^. dim) <*> pure miCoord
|
|
dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
|
|
return $ dimRes' `Map.union` fold dimRess
|
|
|
|
addResults <- addForm boxDimensions
|
|
let
|
|
addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
|
|
addResults' = flip Map.mapWithKey (fst <$> addResults) $ \(dimIx, miCoord) -> \case
|
|
FormSuccess (Just mkResult)
|
|
| miAllowAdd miCoord dimIx sentLiveliness -> Just <$> mkResult sentShape'
|
|
other -> Nothing <$ other
|
|
let addShape
|
|
| [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
|
|
= Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape' <* guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
|
|
| otherwise = Nothing
|
|
|
|
addedShape <- if
|
|
| Just s <- addShape -> return s
|
|
| otherwise -> return sentShape'
|
|
addedLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet addedShape ^? liveCoords :: MForm handler liveliness
|
|
|
|
let
|
|
delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
|
|
delForm miCoord = do
|
|
(delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
|
|
shapeUpdate <- miDelete addedLiveliness miCoord
|
|
guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
|
|
return (shapeUpdate <$ assertM (is _Just) delRes, delView)
|
|
|
|
delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
|
|
let
|
|
delShapeUpdate
|
|
| [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
|
|
| otherwise = Nothing
|
|
delShape = traverse (flip Map.lookup addedShape) =<< delShapeUpdate
|
|
|
|
|
|
let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
|
|
|
|
shape <- if
|
|
| Just s <- addShape -> return s
|
|
| Just s <- delShape -> return s
|
|
| otherwise -> return sentShape'
|
|
liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
|
|
|
|
shapeId <- newIdent
|
|
let shapeInput = fieldView shapeField shapeId (toPathPiece shapeName) [] (Right shape) True
|
|
|
|
|
|
let
|
|
applyDelShapeUpdate :: Maybe (Env, FileEnv) -> Maybe (Env, FileEnv)
|
|
applyDelShapeUpdate prevEnv
|
|
| Just delShapeUpdate' <- delShapeUpdate
|
|
, Just (env, fEnv) <- prevEnv
|
|
= let reverseUpdate = Map.fromList . map swap $ Map.toList delShapeUpdate'
|
|
in Just . (, fEnv) . flip (Map.mapKeysWith mappend) env $ \k -> fromMaybe k $ do
|
|
cell@MassInputCell{miCoord} <- fromPathPiece k
|
|
newCoord <- Map.lookup miCoord reverseUpdate
|
|
return $ toPathPiece cell{ miCoord = newCoord }
|
|
| otherwise = prevEnv
|
|
|
|
justAdded :: Set (BoxCoord liveliness)
|
|
justAdded = Map.keysSet shape Set.\\ Map.keysSet sentShape'
|
|
|
|
restrictJustAdded :: BoxCoord liveliness -> Maybe a -> Maybe a
|
|
restrictJustAdded miCoord env = env <* guard (not $ Set.member miCoord justAdded)
|
|
|
|
cellResults <- flip Map.traverseWithKey shape $ \miCoord cData -> do
|
|
let
|
|
nudgeCellName :: Text -> Text
|
|
nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
|
|
local (over _1 (applyDelShapeUpdate . restrictJustAdded miCoord)) $ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
|
|
let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult))
|
|
result = do
|
|
FormSuccess () <|> void (asum $ Map.elems addResults')
|
|
FormSuccess () <|> void (asum . Map.elems $ fst <$> delResults)
|
|
guard $ not shapeChanged
|
|
for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult
|
|
|
|
let miWidget
|
|
= miLayout
|
|
liveliness
|
|
(fmap (view _1 &&& view (_2 . _1)) cellResults)
|
|
(fmap (view $ _2 . _2) cellResults)
|
|
(fmap (view _2) delResults)
|
|
(Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
let
|
|
fvLabel = toHtml $ mr fsLabel
|
|
fvTooltip = toHtml . mr <$> fsTooltip
|
|
fvInput = $(widgetFile "widgets/massinput/massinput")
|
|
fvErrors = Nothing
|
|
in return (result, FieldView{..})
|
|
|
|
defaultMiLayout :: forall liveliness cellData cellResult.
|
|
Liveliness liveliness
|
|
=> liveliness
|
|
-> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
|
|
-> Map (BoxCoord liveliness) Widget
|
|
-> Map (BoxCoord liveliness) (FieldView UniWorX)
|
|
-> Map (Natural, BoxCoord liveliness) Widget
|
|
-> Widget
|
|
-- | Generic `miLayout` using recursively nested lists
|
|
defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions
|
|
where
|
|
miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
|
|
miWidget' _ _ [] = mempty
|
|
miWidget' miCoord pDims (dim'@(dimIx, BoxDimension dim) : remDims) =
|
|
let coords = Set.toList . Set.map (\c -> miCoord & dim .~ (c ^. dim)) . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims ]) $ review liveCoords liveliness
|
|
cells
|
|
| [] <- remDims = do
|
|
coord <- coords
|
|
Just cellWdgt <- return $ Map.lookup coord cellResults
|
|
let deleteButton = Map.lookup coord delResults
|
|
return (coord, $(widgetFile "widgets/massinput/cell"))
|
|
| otherwise =
|
|
[ (coord, miWidget' coord (pDims `snoc` dim') remDims) | coord <- coords ]
|
|
addWidget = Map.lookup (dimIx, miCoord) addResults
|
|
in $(widgetFile "widgets/massinput/row")
|
|
|
|
|
|
-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
|
|
massInputList :: forall handler cellResult.
|
|
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
|
, MonadLogger handler
|
|
)
|
|
=> Field handler cellResult
|
|
-> (ListPosition -> FieldSettings UniWorX)
|
|
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
|
|
-> FieldSettings UniWorX
|
|
-> Bool
|
|
-> Maybe [cellResult]
|
|
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
|
|
massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
|
|
MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
|
|
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn)
|
|
, miCell = \pos () iRes nudge csrf ->
|
|
over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
|
|
, miDelete = miDeleteList
|
|
, miAllowAdd = \_ _ _ -> True
|
|
, miButtonAction
|
|
, miLayout = \lLength _ cellWdgts delButtons addWdgts
|
|
-> $(widgetFile "widgets/massinput/list/layout")
|
|
}
|
|
miSettings
|
|
miRequired
|
|
(Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
|
|
|
|
massInputA :: forall handler cellData cellResult liveliness.
|
|
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
|
, ToJSON cellData, FromJSON cellData
|
|
, Liveliness liveliness
|
|
, MonadLogger handler
|
|
)
|
|
=> MassInput handler liveliness cellData cellResult
|
|
-> FieldSettings UniWorX
|
|
-> Bool -- ^ Required?
|
|
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
|
|
-> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
|
|
massInputA mi fs fvRequired initialResult = formToAForm $
|
|
over _2 pure <$> massInput mi fs fvRequired initialResult mempty
|