diff --git a/clean.sh b/clean.sh new file mode 100755 index 000000000..2c9c71212 --- /dev/null +++ b/clean.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash + +case $1 in + "") + exec -- stack clean + ;; + *) + target=".stack-work-${1}" + if [[ ! -d "${target}" ]]; then + printf "%s does not exist or is no directory\n" "${target}" >&2 + exit 1 + fi + if [[ -e .stack-work-clean ]]; then + printf ".stack-work-clean exists\n" >&2 + exit 1 + fi + + move-back() { + mv -v .stack-work "${target}" + [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work + } + + mv -v .stack-work .stack-work-clean + mv -v "${target}" .stack-work + trap move-back EXIT + + stack clean + ;; +esac diff --git a/src/Foundation.hs b/src/Foundation.hs index 70ad9da14..bfe7ad225 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -307,6 +307,7 @@ data instance ButtonClass UniWorX | BCWarning | BCDanger | BCLink + | BCMassInputAdd | BCMassInputDelete deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe (ButtonClass UniWorX) instance Finite (ButtonClass UniWorX) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a79faabb9..591040b0b 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -135,23 +135,20 @@ postAdminTestR = do let -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell) -- - -- This /needs/ to use @nudge@ (for deterministic field naming) and to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required) + -- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required) mkAddForm :: ListPosition -- ^ Approximate position of the add-widget -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3 - -> ListLength -- ^ Liveliness -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique -> FieldView UniWorX -- ^ Submit-Button for this add-widget - -> Maybe (Form (ListPosition, Int)) -- ^ Nothing if no further cells should be added; returns index of new cell and data needed to initialize cell - mkAddForm 0 0 listLength nudge submitBtn - | listLength >= 7 = Nothing - | otherwise = Just $ \csrf -> do - (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing - let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes - return ((fromIntegral listLength, ) <$> addRes', toWidget csrf >> fvInput addView >> fvInput submitBtn) - mkAddForm _pos _dim _ _ _ = error "Dimension and Position is always 0 for our 1-dimensional form" + -> Maybe (Form (ListLength -> (ListPosition, Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cell and data needed to initialize cell + mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do + (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing + let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes + return ((\dat l -> (fromIntegral l, dat)) <$> addRes', toWidget csrf >> fvInput addView >> fvInput submitBtn) + mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form" -- | Make a single massInput-Cell -- - -- This /needs/ to use @nudge@ for deterministic field naming + -- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted) mkCellForm :: ListPosition -- ^ Position of this cell -> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@) -> Maybe Int -- ^ Initial cell result from Argument to `massInput` @@ -167,8 +164,11 @@ postAdminTestR = do deleteCell l pos | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] | otherwise = return Map.empty + -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition) + allowAdd :: ListPosition -> Natural -> ListLength -> Bool + allowAdd _ _ l = l < 7 - ((miResult, (fvInput -> miForm)), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell) "" True Nothing + ((miResult, (fvInput -> miForm)), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] @@ -193,7 +193,7 @@ postAdminTestR = do $forall err <- errs
  • #{err} $of FormSuccess res -
    +          

    #{tshow res} |] diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 3375f5a24..ad8cb2d2b 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -24,9 +24,11 @@ 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 @@ -122,8 +124,8 @@ instance RenderMessage UniWorX (ButtonMassInput coord) where instance PathPiece coord => Button UniWorX (ButtonMassInput coord) where btnValidate _ _ = False - btnClasses (MassInputAddDimension _ _) = [BCIsButton, BCDefault] - btnClasses (MassInputDeleteCell _) = [BCIsButton, BCWarning] + btnClasses (MassInputAddDimension _ _) = [BCIsButton, BCDefault, BCMassInputAdd] + btnClasses (MassInputDeleteCell _) = [BCIsButton, BCWarning, BCMassInputDelete] data MassInputFieldName coord @@ -181,16 +183,16 @@ 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@ - -> liveliness -> (Text -> Text) -- Nudge deterministic field ids -> FieldView UniWorX -- Submit button - -> Maybe (Markup -> MForm handler (FormResult (BoxCoord liveliness, cellData), Widget)) + -> 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. @@ -204,7 +206,7 @@ massInput :: forall handler cellData cellResult liveliness. -> 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 +massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = mdo let initialShape = fmap fst <$> initialResult miName <- maybe newFormIdent return fsName @@ -223,18 +225,21 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do | 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 (BoxCoord liveliness, cellData), Widget)) + 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{..} - dimRes <- runMaybeT $ do - (btnRes, btnView) <- lift $ mpreq (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..}) Nothing - (addRes, addView) <- MaybeT . traverse ($ mempty) $ miAdd miCoord dimIx sentLiveliness nudgeAddWidgetName btnView - return (btnRes *> addRes, addView) - let dimRes' = maybe Map.empty (Map.singleton (dimIx, miCoord)) dimRes + (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 @@ -245,7 +250,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do addResults <- addForm boxDimensions let addShape - | [FormSuccess (bCoord, cData)] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst addResults = Just $ Map.insert bCoord cData sentShape' + | [((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 @@ -257,42 +263,58 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do 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 + -- $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 delShape - | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = traverse (flip Map.lookup addedShape) shapeUpdate' + 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 <- delShape -> return s | 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 - shapeInput = fieldView shapeField shapeId (toPathPiece shapeName) [] (Right shape) True + 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)) - (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty + 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 - | isJust addShape || isJust delShape = FormMissing + | 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 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 @@ -301,20 +323,18 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do let deleteButton = snd <$> Map.lookup coord delResults return (coord, $(widgetFile "widgets/massinput/cell")) | otherwise = - [ (coord, miWidget coord remDims) | coord <- coords ] - addWidget = snd <$> Map.lookup (dimIx, miCoord) addResults + [ (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 = mconcat - [ toWidget csrf - , shapeInput - , miWidget boxOrigin $ zip [0..] boxDimensions - ] + fvInput = $(widgetFile "widgets/massinput/massinput") fvErrors = Nothing in return (result, FieldView{..}) diff --git a/static/js/utils/inputs.js b/static/js/utils/inputs.js index 68425b5ba..fd4ad906e 100644 --- a/static/js/utils/inputs.js +++ b/static/js/utils/inputs.js @@ -229,4 +229,30 @@ }; } + // Override implicit submit (pressing enter) behaviour to trigger a specified submit button instead of the default + window.utils.implicitSubmit = function(input, options) { + var submit = options.submit; + + console.log('implicitSubmit', input, submit); + + if (!submit) { + throw new Error('window.utils.implicitSubmit(input, options) needs to be passed a submit element via options'); + } + + var doSubmit = function(event) { + if (event.keyCode == 13) { + event.preventDefault(); + submit.click(); + } + }; + + input.addEventListener('keypress', doSubmit); + + return { + scope: input, + destroy: function() { + input.removeEventListener('keypress', doSubmit); + }, + }; + } })(); diff --git a/templates/widgets/massinput/massinput.hamlet b/templates/widgets/massinput/massinput.hamlet new file mode 100644 index 000000000..3dde7384d --- /dev/null +++ b/templates/widgets/massinput/massinput.hamlet @@ -0,0 +1,5 @@ +$newline never +

    + #{csrf} + ^{shapeInput} + ^{miWidget} diff --git a/templates/widgets/massinput/massinput.julius b/templates/widgets/massinput/massinput.julius new file mode 100644 index 000000000..219636e59 --- /dev/null +++ b/templates/widgets/massinput/massinput.julius @@ -0,0 +1,21 @@ +document.addEventListener('DOMContentLoaded', function() { + var form = document.getElementById(#{String fvId}).closest('form'); + + + var formSubmit = form.querySelector('input[type=submit], button[type=submit]:not(.btn-mass-input-add):not(.btn-mass-input-delete)'); + var cellInputs = Array.from(form.querySelectorAll('.massinput--cell input:not([type=hidden])')); + + cellInputs.forEach(function(input) { + window.utils.setup('implicitSubmit', input, { submit: formSubmit }); + }); + + + Array.from(form.querySelectorAll('.massinput--add')).forEach(function(wrapper) { + var addSubmit = wrapper.querySelector('.btn-mass-input-add'); + var addInputs = Array.from(wrapper.querySelectorAll('input:not([type=hidden]):not(.btn-mass-input-add)')); + + addInputs.forEach(function(input) { + window.utils.setup('implicitSubmit', input, { submit: addSubmit }); + }); + }); +});