{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Handler.Utils.Form.MassInput
  ( MassInput(..), MassInputLayout
  , defaultMiLayout, listMiLayout
  , massInput
  , module Handler.Utils.Form.MassInput.Liveliness
  , massInputA, massInputW
  , massInputList
  , massInputAccum, massInputAccumA
  , ListLength(..), ListPosition(..), miDeleteList
  , EnumLiveliness(..), EnumPosition(..)
  , MapLiveliness(..)
  ) where

import Import
import Utils.Form
import Utils.Lens
import Handler.Utils.Form (secretJsonField)
import Handler.Utils.Form.MassInput.Liveliness
import Handler.Utils.Form.MassInput.TH

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.IntSet as IntSet
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Foldable as Fold

import Control.Monad.Reader.Class (MonadReader(local))

import Text.Hamlet (hamletFile)


$(mapM tupleBoxCoord [2..4])


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, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
  deriving (Eq, Ord, Generic, Typeable, Read, Show)

makeWrapped ''ListPosition

instance IsBoxCoord ListPosition where
  boxDimensions = [BoxDimension _Wrapped]
  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 bottom) (1 <$ guard (n == 0)))


newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet }
  deriving (Eq, Ord, Generic, Typeable, Read, Show)

makeWrapped ''EnumLiveliness

instance JoinSemiLattice (EnumLiveliness enum) where
  (EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b
instance MeetSemiLattice (EnumLiveliness enum) where
  (EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b
instance Lattice (EnumLiveliness enum)
instance BoundedJoinSemiLattice (EnumLiveliness enum) where
  bottom = EnumLiveliness IntSet.empty
instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where
  top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound]
instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum)


newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
  deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
  deriving (Eq, Ord, Generic, Typeable, Read, Show)

makeWrapped ''EnumPosition

instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
  boxDimensions = [BoxDimension _Wrapped]
  boxOrigin = minBound

instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where
  type BoxCoord (EnumLiveliness enum) = EnumPosition enum
  liveCoords = iso fromSet toSet
    where
      toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness
      fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList


newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l1) l2 }
  deriving (Generic, Typeable)

makeWrapped ''MapLiveliness

deriving instance (Ord (BoxCoord l1), JoinSemiLattice l2) => JoinSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), MeetSemiLattice l2) => MeetSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedLattice l2) => BoundedLattice (MapLiveliness l1 l2)
deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2)

instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where
  type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2)
  liveCoords = prism'
    (Set.fromList . concatMap (\(k, v) -> (k, ) <$> Set.toAscList (review liveCoords v)) . Map.toAscList . unMapLiveliness)
    (\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)



miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
miDeleteList l pos
    -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
  | l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
  | otherwise = pure Map.empty

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 (Map (BoxCoord liveliness) cellData -> FormResult (Map (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
  , miAddEmpty :: BoxCoord liveliness
               -> Natural
               -> liveliness
               -> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets
  , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
  , miLayout :: MassInputLayout liveliness cellData cellResult
  }

type MassInputLayout liveliness cellData cellResult
  =    liveliness
    -> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
    -> Map (BoxCoord liveliness) Widget -- Cell Widgets
    -> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
    -> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
    -> Widget

massInput :: forall handler cellData cellResult liveliness.
           ( MonadHandler handler, HandlerSite handler ~ UniWorX
           , ToJSON cellData, FromJSON cellData
           , Liveliness liveliness
           , 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
  fvId <- maybe newIdent return fsId
  miAction <- traverse toTextUrl $ miButtonAction fvId
  let addFormAction = maybe id (addAttr "formaction") miAction

  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 (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
      addForm = addForm' boxOrigin [] . zip [0..]
        where
          addForm' _ _ [] = return Map.empty
          addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
            let nudgeAddWidgetName :: Text -> Text
                nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
            (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
            let btnRes = do
                  Just x <- btnRes'
                  return x
                wBtnRes res = do
                  guard $ isn't _FormMissing btnRes
                  res
            addRes' <- over (mapped . _Just . _1) wBtnRes . 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.union (miAddEmpty miCoord dimIx sentLiveliness)
                      . Set.map (\c -> miCoord & dim .~ (c ^. dim))
                      . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
                      $ review liveCoords sentLiveliness
                dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
                return $ dimRes' `Map.union` fold dimRess

  addResults <- addForm boxDimensions
  let
    addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
    addResults' = flip Map.mapWithKey (fst <$> addResults) $ \(dimIx, miCoord) -> \case
        FormSuccess (Just mkResult)
          | miAllowAdd miCoord dimIx sentLiveliness -> Just <$> mkResult sentShape'
        other -> Nothing <$ other
  let addShape
        | [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
        = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape' <* 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 $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
      shapeUpdate <- miDelete addedLiveliness miCoord
      guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
      return (shapeUpdate <$ assertM (is _Just) 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 = Map.keysSet shape Set.\\ Map.keysSet sentShape'

    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 = do
        FormSuccess () <|> void (asum $ Map.elems addResults')
        FormSuccess () <|> void (asum . Map.elems $ fst <$> delResults)
        guard $ not shapeChanged
        for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult

  let miWidget
        = miLayout
          liveliness
          (fmap (view _1 &&& view (_2 . _1)) cellResults)
          (fmap (view $ _2 . _2) cellResults)
          (fmap (view _2) delResults)
          (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)

  MsgRenderer mr <- getMsgRenderer

  whenM (hasCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do
    PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone")
    ur <- getUrlRenderParams

    sendResponse $ $(hamletFile "templates/widgets/massinput/massinput-standalone-wrapper.hamlet") ur

  let
    fvLabel = toHtml $ mr fsLabel
    fvTooltip = toHtml . mr <$> fsTooltip
    fvInput = $(widgetFile "widgets/massinput/massinput")
    fvErrors = Nothing
    in return (result, FieldView{..})

defaultMiLayout :: forall liveliness cellData cellResult.
                   Liveliness liveliness
                => MassInputLayout liveliness cellData cellResult
-- | Generic `miLayout` using recursively nested lists
defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions
  where
    miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
    miWidget' _ _ [] = mempty
    miWidget' miCoord pDims (dim'@(dimIx, BoxDimension dim) : remDims) =
      let coords = Set.toList . Set.map (\c -> miCoord & dim .~ (c ^. dim)) . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims ]) $ review liveCoords liveliness
          cells
            | [] <- remDims = do
                coord <- coords
                Just cellWdgt <- return $ Map.lookup coord cellResults 
                let deleteButton = Map.lookup coord delResults
                return (coord, $(widgetFile "widgets/massinput/cell"))
            | otherwise =
                [ (coord, miWidget' coord (pDims `snoc` dim') remDims) | coord <- coords ]
          addWidget = Map.lookup (dimIx, miCoord) addResults
       in $(widgetFile "widgets/massinput/row")

listMiLayout :: MassInputLayout ListLength cellData cellResult
listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/list/layout")


-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
massInputList :: forall handler cellResult.
                 ( MonadHandler handler, HandlerSite handler ~ UniWorX
                 , MonadLogger handler
                 )
              => Field handler cellResult
              -> (ListPosition -> FieldSettings UniWorX)
              -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
              -> FieldSettings UniWorX
              -> Bool
              -> Maybe [cellResult]
              -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
  MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
                return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn)
            , miCell = \pos () iRes nudge csrf ->
                over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
            , miDelete = miDeleteList
            , miAllowAdd = \_ _ _ -> True
            , miAddEmpty = \_ _ _ -> Set.empty
            , miButtonAction
            , miLayout = listMiLayout
            }
  miSettings
  miRequired
  (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)

-- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
massInputAccum :: forall handler cellData.
                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
                  , MonadLogger handler
                  , ToJSON cellData, FromJSON cellData
                  )
               => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
               -> (cellData -> Widget)
               -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
               -> MassInputLayout ListLength cellData ()
               -> FieldSettings UniWorX
               -> Bool
               -> Maybe [cellData]
               -> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX))
massInputAccum miAdd' miCell' miButtonAction miLayout fSettings fRequired mPrev csrf
  = over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> 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 () -> (Text -> Text)
           -> (Markup -> MForm handler (FormResult (), Widget))
    miCell _pos dat _mPrev _nudge csrf' = return (FormSuccess (), toWidget csrf' <> miCell' dat)

    miDelete = miDeleteList

    miAllowAdd _ _ _ = True

    miAddEmpty _ _ _ = Set.empty

massInputAccumA :: forall handler cellData.
                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
                  , MonadLogger handler
                  , ToJSON cellData, FromJSON cellData
                  )
               => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
               -> (cellData -> Widget)
               -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
               -> MassInputLayout ListLength cellData ()
               -> FieldSettings UniWorX
               -> Bool
               -> Maybe [cellData]
               -> AForm handler [cellData]
massInputAccumA miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev
  = formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev mempty


massInputA :: forall handler cellData cellResult liveliness.
           ( MonadHandler handler, HandlerSite handler ~ UniWorX
           , ToJSON cellData, FromJSON cellData
           , Liveliness liveliness
           , MonadLogger handler
           )
          => MassInput handler liveliness cellData cellResult
          -> FieldSettings UniWorX
          -> Bool -- ^ Required?
          -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
          -> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
massInputA  mi fs fvRequired initialResult = formToAForm $
  over _2 pure <$> massInput mi fs fvRequired initialResult mempty

massInputW :: forall handler cellData cellResult liveliness.
           ( MonadHandler handler, HandlerSite handler ~ UniWorX
           , ToJSON cellData, FromJSON cellData
           , Liveliness liveliness
           , MonadLogger handler
           )
          => MassInput handler liveliness cellData cellResult
          -> FieldSettings UniWorX
          -> Bool -- ^ Required?
          -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
          -> WForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)))
massInputW mi fs fvRequired initialResult = mFormToWForm $
  massInput mi fs fvRequired initialResult mempty