Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

src/Handler/Utils/Form/MassInput.hs

@@ -9,6 +9,7 @@ module Handler.Utils.Form.MassInput
   , massInputA, massInputW
   , massInputList
   , massInputAccum, massInputAccumA, massInputAccumW
+  , massInputAccumEdit, massInputAccumEditA, massInputAccumEditW
   , ListLength(..), ListPosition(..), miDeleteList
   , EnumLiveliness(..), EnumPosition(..)
   , MapLiveliness(..)
@@ -565,6 +566,83 @@ massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq
   = mFormToWForm $ massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
 
   
+-- | Wrapper around `massInput` for the common case, that we just want a list of data with existing data modified the same way as new data is added
+massInputAccumEdit :: forall handler cellData ident.
+                      ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                      , MonadLogger handler
+                      , ToJSON cellData, FromJSON cellData
+                      , PathPiece ident
+                      )
+                   => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+                   -> ((Text -> Text) -> cellData          -> (Markup -> MForm handler (FormResult cellData, Widget)))
+                   -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+                   -> MassInputLayout ListLength cellData cellData
+                   -> ident
+                   -> FieldSettings UniWorX
+                   -> Bool
+                   -> Maybe [cellData]
+                   -> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX))
+massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
+  = over (_1 . mapped) (map snd . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (\x -> (x, x)) <$> mPrev) csrf
+  where
+    miAdd :: ListPosition -> Natural
+          -> (Text -> Text) -> FieldView UniWorX
+          -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
+    miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
+
+    doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
+    doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
+      where
+        prevElems = Map.elems prevData
+        startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
+
+    miCell :: ListPosition -> cellData -> Maybe cellData -> (Text -> Text)
+           -> (Markup -> MForm handler (FormResult cellData, Widget))
+    miCell _pos dat _mPrev nudge = miCell' nudge dat
+
+    miDelete = miDeleteList
+
+    miAllowAdd _ _ _ = True
+
+    miAddEmpty _ _ _ = Set.empty
+
+massInputAccumEditA :: forall handler cellData ident.
+                       ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                       , MonadLogger handler
+                       , ToJSON cellData, FromJSON cellData
+                       , PathPiece ident
+                       )
+                    => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+                    -> ((Text -> Text) -> cellData          -> (Markup -> MForm handler (FormResult cellData, Widget)))
+                    -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+                    -> MassInputLayout ListLength cellData cellData
+                    -> ident
+                    -> FieldSettings UniWorX
+                    -> Bool
+                    -> Maybe [cellData]
+                    -> AForm handler [cellData]
+massInputAccumEditA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
+  = formToAForm $ over _2 pure <$> massInputAccumEdit miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
+
+massInputAccumEditW :: forall handler cellData ident.
+                       ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                       , MonadLogger handler
+                       , ToJSON cellData, FromJSON cellData
+                       , PathPiece ident
+                       )
+                    => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+                    -> ((Text -> Text) -> cellData          -> (Markup -> MForm handler (FormResult cellData, Widget)))
+                    -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+                    -> MassInputLayout ListLength cellData cellData
+                    -> ident
+                    -> FieldSettings UniWorX
+                    -> Bool
+                    -> Maybe [cellData]
+                    -> WForm handler (FormResult [cellData])
+massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
+  = mFormToWForm $ massInputAccumEdit miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
+
+
 massInputA :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData

src/Handler/Utils/Table/Pagination.hs

@@ -13,6 +13,7 @@ module Handler.Utils.Table.Pagination
   , PagesizeLimit(..)
   , PaginationSettings(..), PaginationInput(..), piIsUnset
   , PSValidator(..)
+  , defaultPagesize
   , defaultFilter, defaultSorting
   , restrictFilter, restrictSorting
   , ToSortable(..), Sortable(..)
@@ -314,6 +315,13 @@ defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> inje
       Just _  -> id
       Nothing -> set (_2._psSorting) psSorting
 
+defaultPagesize :: PagesizeLimit -> PSValidator m x -> PSValidator m x
+defaultPagesize psLimit (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
+  where
+    injectDefault x = case x >>= piLimit of
+      Just _  -> id
+      Nothing -> set (_2._psLimit) psLimit
+
 restrictFilter :: (FilterKey -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
 restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
   where