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/messages/uniworx/de.msg b/messages/uniworx/de.msg index 0b5ad6e65..2297642d8 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -680,3 +680,6 @@ DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde + +MassInputAddDimension: Hinzufügen +MassInputDeleteCell: Entfernen diff --git a/package.yaml b/package.yaml index 70a0a0c90..83b3b006e 100644 --- a/package.yaml +++ b/package.yaml @@ -114,6 +114,7 @@ dependencies: - memcached-binary - directory-tree - lifted-base + - lattices - hsass other-extensions: diff --git a/src/Foundation.hs b/src/Foundation.hs index e4f1ada8b..000f3f153 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -335,6 +335,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 3eab2f26c..9ef15cb84 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,8 +1,9 @@ module Handler.Admin where import Import -import Jobs import Handler.Utils +import Handler.Utils.Form.MassInput +import Jobs import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) import Control.Monad.Trans.Except @@ -11,6 +12,7 @@ import Control.Monad.Trans.Writer (mapWriterT) import Utils.Lens -- import Data.Time +import Data.Char (isDigit) import qualified Data.Text as Text -- import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 @@ -31,8 +33,6 @@ import qualified Handler.Utils.TermCandidates as Candidates -- import qualified Data.UUID.Cryptographic as UUID - - getAdminR :: Handler Html getAdminR = -- do siteLayoutMsg MsgAdminHeading $ do @@ -145,6 +145,61 @@ postAdminTestR = do
  • #{m} |] + + {- The following demonstrates the use of @massInput@. + + @massInput@ takes as arguments: + - A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?) + - Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required) + - An initial value to pre-fill the field with + + @massInput@ then returns an @MForm@ structured for easy downstream consumption of the result + -} + let + -- We define the fields of the configuration struct @MassInput@: + + -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell) + -- + -- 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 + -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique + -> FieldView UniWorX -- ^ Submit-Button for this add-widget + -> 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 -- Any old field; for demonstration + let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done + addRes'' = (\dat l -> (fromIntegral l, dat)) <$> addRes' -- Construct the callback to determine new cell position and data within @FormResult@ as required + return (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@ 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` + -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique + -> Form Int + mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell + (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData + return (intRes, toWidget csrf >> fvInput intView) + -- | How does the shape (`ListLength`) change if a certain cell is deleted? + deleteCell :: ListLength -- ^ Current shape + -> ListPosition -- ^ Coordinate to delete + -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions + deleteCell l pos + | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard` + | 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 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases) + + -- The actual call to @massInput@ is comparatively simple: + + ((miResult, (fvInput -> miForm)), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing + + let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] siteLayout locallyDefinedPageHeading $ do -- defaultLayout $ do @@ -155,6 +210,22 @@ postAdminTestR = do $(widgetFile "formPage") showDemoResult + [whamlet| +

    Mass-Input +
    + ^{miForm} + ^{submitButtonView} + $case miResult + $of FormMissing + $of FormFailure errs +
      + $forall err <- errs +
    • #{err} + $of FormSuccess res +

      + #{tshow res} + |] + getAdminErrMsgR, postAdminErrMsgR :: Handler Html getAdminErrMsgR = postAdminErrMsgR diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs new file mode 100644 index 000000000..8da523d3a --- /dev/null +++ b/src/Handler/Utils/Form/MassInput.hs @@ -0,0 +1,353 @@ +{-# 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)) -- ^ 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 + } + +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 = do + 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' + 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 = Set.fromList . mapMaybe (addedCoord . fst) $ Map.elems addResults + where + addedCoord res + | FormSuccess (Just mkResult) <- res + = Just . fst $ mkResult sentLiveliness + | otherwise = Nothing + 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 + | shapeChanged = FormMissing + | otherwise = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults + + 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{..}) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 1a6255df4..39de96dd7 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -61,6 +61,7 @@ import Database.Esqueleto.Instances as Import () import Database.Persist.Sql.Instances as Import () import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) +import Numeric.Natural.Instances as Import () import System.Random as Import (Random) import Control.Monad.Random.Class as Import (MonadRandom(..)) diff --git a/src/Numeric/Natural/Instances.hs b/src/Numeric/Natural/Instances.hs new file mode 100644 index 000000000..cb986f770 --- /dev/null +++ b/src/Numeric/Natural/Instances.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Numeric.Natural.Instances + ( + ) where + +import ClassyPrelude +import Numeric.Natural +import Web.PathPieces + +instance PathPiece Natural where + toPathPiece = tshow + fromPathPiece = readMay diff --git a/src/Utils.hs b/src/Utils.hs index 73efb5aa6..8c08d999c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -538,7 +538,7 @@ assertM f x = x >>= assertM' f assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m () assertM_ f x = guard . f =<< x -assertM' :: MonadPlus m => (a -> Bool) -> a -> m a +assertM' :: Alternative m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) -- Some Utility Functions from Agda.Utils.Monad @@ -591,6 +591,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 bf8243b69..c82f02226 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -145,8 +145,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 } @@ -250,6 +250,7 @@ identifyForm' resLens identVal form fragment = do identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget)) identifyForm = identifyForm' id + {- Hinweise zur Erinnerung: - identForm primär, wenn es mehr als ein Formular pro Handler gibt @@ -574,6 +575,12 @@ apreq f fs mx = formToAForm $ do mr <- getMessageRender over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx) +mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site) +mpreq f fs mx = do + mr <- getMessageRender + over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx) + wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a) wpreq f fs mx = mFormToWForm $ do diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 1443b259d..0abc9a8ee 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -80,6 +80,8 @@ makeLenses_ ''SheetType makePrisms ''AuthResult +makePrisms ''FormResult + makeLenses_ ''StudyFeatures makeLenses_ ''StudyDegree 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/cell.hamlet b/templates/widgets/massinput/cell.hamlet new file mode 100644 index 000000000..8a9654357 --- /dev/null +++ b/templates/widgets/massinput/cell.hamlet @@ -0,0 +1,3 @@ +^{cellWdgt} +$maybe delWdgt <- fmap fvInput deleteButton + ^{delWdgt} 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 }); + }); + }); +}); diff --git a/templates/widgets/massinput/row.hamlet b/templates/widgets/massinput/row.hamlet new file mode 100644 index 000000000..8c43c9896 --- /dev/null +++ b/templates/widgets/massinput/row.hamlet @@ -0,0 +1,7 @@ +
        toPathPiece dimIx}> + $forall (cellCoord, cell) <- cells +
      • + ^{cell} + $maybe add <- addWidget +
      • + ^{add}