Feature complete MassInput

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

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)

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
               <li>#{err}
         $of FormSuccess res
-          <pre>
+          <p style="white-space:pre-wrap; font-family:monospace;">
             #{tshow res}
     |]
 

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{..})

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);
+      },
+    };
+  }
 })();

templates/widgets/massinput/massinput.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<div .massinput ##{fvId}>
+  #{csrf}
+  ^{shapeInput}
+  ^{miWidget}

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 });
+    });
+  });
+});