341 lines
15 KiB
Haskell
341 lines
15 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module Handler.Utils.Form.MassInput
|
|
( MassInput(..)
|
|
, massInput
|
|
, BoxDimension(..)
|
|
, IsBoxCoord(..), boxDimension
|
|
, Liveliness(..)
|
|
, ListLength(..), ListPosition(..)
|
|
) where
|
|
|
|
import Import
|
|
import Utils.Form
|
|
import Utils.Lens
|
|
import Handler.Utils.Form (secretJsonField)
|
|
|
|
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.Map as Map
|
|
import qualified Data.Foldable as Fold
|
|
import Data.List (genericLength, genericIndex, iterate)
|
|
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.Reader.Class (MonadReader(local))
|
|
import Control.Monad.Fix
|
|
|
|
|
|
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 -> BoxDimension x
|
|
boxDimension n
|
|
| 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 (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
|
|
liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
|
|
|
|
|
|
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, ToJSONKey, FromJSONKey)
|
|
deriving (Eq, Ord, Generic, Typeable, Read, Show)
|
|
|
|
makeWrapped ''ListPosition
|
|
|
|
instance IsBoxCoord ListPosition where
|
|
boxDimensions = [BoxDimension id]
|
|
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 0) (1 <$ guard (n == 0)))
|
|
|
|
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 (liveliness -> (BoxCoord liveliness, cellData)), Widget))
|
|
, miCell :: BoxCoord liveliness -- Position
|
|
-> cellData -- Initialisation data
|
|
-> Maybe cellResult -- Previous result
|
|
-> (Text -> Text) -- Nudge deterministic field ids
|
|
-> (Markup -> MForm handler (FormResult cellResult, Widget))
|
|
, miDelete :: liveliness -> BoxCoord liveliness -> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness))
|
|
, miAllowAdd :: BoxCoord liveliness -> Natural -> liveliness -> Bool
|
|
}
|
|
|
|
massInput :: forall handler cellData cellResult liveliness.
|
|
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
|
, ToJSON cellData, FromJSON cellData
|
|
, Liveliness liveliness
|
|
, MonadFix handler, 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 = mdo
|
|
let initialShape = fmap fst <$> initialResult
|
|
|
|
miName <- maybe newFormIdent return fsName
|
|
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 (liveliness -> (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{..}) Nothing
|
|
let btnRes
|
|
| FormSuccess Nothing <- btnRes' = FormMissing
|
|
| FormSuccess (Just x) <- btnRes' = FormSuccess x
|
|
| otherwise = error "Value of btnRes should only be inspected if FormSuccess" <$ btnRes'
|
|
addRes' <- over (mapped . _Just . _1) (btnRes *>) . 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) $ iterate (over dim succ) miCoord
|
|
dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
|
|
return $ dimRes' `Map.union` fold dimRess
|
|
|
|
addResults <- addForm boxDimensions
|
|
let addShape
|
|
| [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
|
|
= Just $ maybe id (uncurry Map.insert) (mkResult sentLiveliness <$ 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 $ mpreq (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..}) Nothing
|
|
-- $logDebugS "delForm" . tshow $ fmap toPathPiece delRes
|
|
shapeUpdate <- miDelete addedLiveliness miCoord
|
|
guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
|
|
return (shapeUpdate <$ 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'
|
|
|
|
$logDebugS "massInput" [st|Current shape: #{tshow (map toPathPiece (Map.keys shape))}|]
|
|
|
|
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
|
|
|
|
cellResults <- flip Map.traverseWithKey shape $ \miCoord cData -> do
|
|
let
|
|
nudgeCellName :: Text -> Text
|
|
nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
|
|
local (over _1 applyDelShapeUpdate) $ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
|
|
let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult))
|
|
result
|
|
| shapeChanged = FormMissing
|
|
| otherwise = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults
|
|
|
|
liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
|
|
|
|
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
|
|
let deleteButton = snd <$> Map.lookup coord delResults
|
|
return (coord, $(widgetFile "widgets/massinput/cell"))
|
|
| otherwise =
|
|
[ (coord, miWidget' coord remDims) | coord <- coords ]
|
|
addWidget = (\(_, mWgt) -> mWgt <* guard (miAllowAdd miCoord dimIx liveliness)) =<< Map.lookup (dimIx, miCoord) addResults
|
|
in $(widgetFile "widgets/massinput/row")
|
|
|
|
miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
fvId <- maybe newIdent return fsId
|
|
|
|
let
|
|
fvLabel = toHtml $ mr fsLabel
|
|
fvTooltip = toHtml . mr <$> fsTooltip
|
|
fvInput = $(widgetFile "widgets/massinput/massinput")
|
|
fvErrors = Nothing
|
|
in return (result, FieldView{..})
|