{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-record-updates #-} -- tupleBoxCoord
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}

module Handler.Utils.Form.MassInput
  ( MassInput(..), MassInputLayout, MassInputDelete
  , defaultMiLayout, listMiLayout
  , massInput
  , module Handler.Utils.Form.MassInput.Liveliness
  , massInputA, massInputW
  , massInputList, massInputListA
  , massInputAccum, massInputAccumA, massInputAccumW
  , massInputAccumEdit, massInputAccumEditA, massInputAccumEditW
  , ListLength(..), ListPosition(..), miDeleteList
  , EnumLiveliness(..), EnumPosition(..)
  , MapLiveliness(..)
  , LowerBounded(..), BoundedLiveliness(..), BoundedPosition(..)
  ) where

import Import
import Utils.Form
import Handler.Utils.Form.MassInput.Liveliness
import Handler.Utils.Form.MassInput.TH

import Text.Blaze (Markup, toMarkup)

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 Text.Hamlet (hamletFile)

import Algebra.Lattice.Ordered (Ordered(..))

import Control.Monad.Trans.RWS.Lazy (evalRWST)
import qualified Control.Monad.State.Class as State

{-# ANN module ("HLint: ignore Use const" :: String) #-}


$(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

deriving via Ordered ListLength 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)
  deriving newtype (Lattice, BoundedJoinSemiLattice)

makeWrapped ''EnumLiveliness


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 (Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey 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, Ord enum) => Liveliness (EnumLiveliness enum) where
  type BoxCoord (EnumLiveliness enum) = EnumPosition enum
  liveCoords = iso fromSet toSet
    where
      toSet :: EnumLiveliness enum -> Set (EnumPosition enum)
      toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness
      fromSet :: Set (EnumPosition enum) -> EnumLiveliness enum
      fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList


class Ord coord => LowerBounded coord where
  minBound' :: coord

newtype BoundedLiveliness coord = BoundedLiveliness { unBoundedLiveliness :: Set coord }
  deriving (Eq, Ord, Generic, Typeable, Read, Show)
  deriving newtype (Lattice, BoundedJoinSemiLattice, BoundedMeetSemiLattice)
makeWrapped ''BoundedLiveliness

newtype BoundedPosition coord = BoundedPosition { unBoundedPosition :: coord }
  deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey, LowerBounded)
  deriving (Eq, Ord, Generic, Typeable, Read, Show)
makeWrapped ''BoundedPosition

instance (LowerBounded coord, PathPiece coord, ToJSON coord, FromJSON coord, ToJSONKey coord, FromJSONKey coord, Ord coord) => IsBoxCoord (BoundedPosition coord) where
  boxDimensions = [BoxDimension _Wrapped]
  boxOrigin = minBound'

instance (LowerBounded coord, PathPiece coord, ToJSON coord, FromJSON coord, ToJSONKey coord, FromJSONKey coord, Ord coord) => Liveliness (BoundedLiveliness coord) where
  type BoxCoord (BoundedLiveliness coord) = BoundedPosition coord
  liveCoords = iso (Set.mapMonotonic $ view _Wrapped) (Set.mapMonotonic $ view _Unwrapped) . _Unwrapped


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

makeWrapped ''MapLiveliness

deriving newtype instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
deriving newtype instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
deriving newtype instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
deriving newtype instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
deriving newtype instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
deriving newtype instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
deriving newtype 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)


type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> BoxCoord liveliness -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))


miDeleteList :: MassInputDelete ListLength
miDeleteList dat pos
    -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
  | Just l <- preview liveCoords $ Map.keysSet dat :: Maybe ListLength
  , 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 = forall i. PathPiece i => MassInput
  { miAdd :: BoxCoord liveliness -- ^ Position (dimensions after @dimIx@ are zero)
          -> Natural -- ^ Zero-based dimension index @dimIx@
          -> liveliness -- ^ Previous liveliness
          -> (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 :: Map (BoxCoord liveliness) cellData
             -> 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
  , 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
  , miIdent :: i
  }

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

-- | Multiple multi-layerd input fields
--   May short-circuit a handler if the frontend only asks for the content, i.e. handler actions after calls to massInput may not happen at all.
massInput :: forall handler cellData cellResult liveliness.
           ( MonadHandler handler, HandlerSite handler ~ UniWorX
           , ToJSON cellData, FromJSON cellData
           , Liveliness liveliness
           , MonadThrow 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{ miIdent = toPathPiece -> miIdent, ..} 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 :: Field handler (Map (BoxCoord liveliness) cellData)
    shapeField = secretJsonField
  sentShape <- runMaybeT $ do
    ts <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askParams
    fs <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askFiles
    MaybeT $ preview (_Right . _Just) <$> 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 runTwice :: (Maybe res -> MForm handler res) -> MForm handler res
      runTwice act = do
        r <- ask
        s <- State.get
        res1 <- fmap (view _1) . lift $ evalRWST (act Nothing) r s 
        local (_1 .~ Nothing) . act $ Just res1
      replaceWithFirst :: forall k x y. Ord k => Maybe (Map k (x, y)) -> Map k (x, y) -> Map k (x, y)
      replaceWithFirst Nothing xs = xs
      replaceWithFirst (Just f) s = Map.unionWith (\(f1, _f2) (_s1, s2) -> (f1, s2)) f s
 
  (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged) <- runTwice $ \mPrev -> do
    let sentLiveliness' = maybe sentLiveliness (view _2) mPrev

    let addForm :: MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
        addForm = addForm' boxOrigin [] $ zip [0..] boxDimensions
          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
                  miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx sentLiveliness' nudgeAddWidgetName btnView
              addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
              addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
              let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . 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 <- replaceWithFirst (view _4 <$> mPrev) <$> addForm
    let
      addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
      addResults' = fmap (view _1) addResults <&> \case
        FormSuccess (Just mkShape) -> Just <$> mkShape sentShape'
        other -> Nothing <$ other
    let addShape
          | [FormSuccess (Just mkResult)] <- Map.elems . Map.filter (is $ _FormSuccess . _Just) $ view _1 <$> addResults
          = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape') sentShape'
          | otherwise = Nothing

    addedShape <- if
      | Just s <- addShape -> return s
      | otherwise -> return sentShape'

    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 addedShape miCoord
        guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
        return (shapeUpdate <$ assertM (is _Just) delRes, delView)

    delResults <- fmap (replaceWithFirst (view _6 <$> mPrev) . 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 (`Map.lookup` addedShape) =<< delShapeUpdate


    let shapeChanged = Fold.any (hasn't $ _1 . _FormMissing) addResults || Fold.any (has $ _1 . _FormSuccess) 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

    return (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged)

  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.mapMaybe (view _2) addResults)

  MsgRenderer mr <- getMsgRenderer

  whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandler $ do
    PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone")
    ur <- getUrlRenderParams

    case result of
      FormFailure errs -> forM_ errs $ addMessage Error . toHtml -- Error messages get collected by middleware and added as header to response
      _other           -> return () -- Completely ignore non-error results; we'll short circuit below

    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 = case result of
      FormFailure errs | not $ null errs -> Just . mconcat . intersperse [shamlet|<br />|] $ map toMarkup errs
      _other -> 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 ident msg.
                 ( MonadHandler handler, HandlerSite handler ~ UniWorX
                 , MonadThrow handler
                 , PathPiece ident
                 , RenderMessage UniWorX msg
                 )
              => Field handler cellResult
              -> (ListPosition -> FieldSettings UniWorX)
              -> msg
              -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
              -> ident
              -> FieldSettings UniWorX
              -> Bool
              -> Maybe [cellResult]
              -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
massInputList field fieldSettings onMissing miButtonAction miIdent 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 . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
            , miCell = \pos () iRes nudge csrf ->
                over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
            , miDelete = miDeleteList
            , miAddEmpty = \_ _ _ -> Set.empty
            , miButtonAction
            , miLayout = listMiLayout
            , miIdent
            }
  miSettings
  miRequired
  (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)

massInputListA :: forall handler cellResult ident msg.
                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
                  , MonadThrow handler
                  , PathPiece ident
                  , RenderMessage UniWorX msg
                  )
               => Field handler cellResult
               -> (ListPosition -> FieldSettings UniWorX)
               -> msg
               -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
               -> ident
               -> FieldSettings UniWorX
               -> Bool
               -> Maybe [cellResult]
               -> AForm handler [cellResult]
massInputListA field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = formToAForm . fmap (over _2 pure) $ massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult mempty


-- | 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 ident.
                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
                  , MonadThrow handler
                  , ToJSON cellData, FromJSON cellData
                  , PathPiece ident
                  )
               => ((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 ()
               -> ident
               -> FieldSettings UniWorX
               -> Bool
               -> Maybe [cellData]
               -> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX))
massInputAccum miAdd' miCell' miButtonAction miLayout miIdent 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 -> ListLength
          -> (Text -> Text) -> FieldView UniWorX
          -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
    miAdd _pos _dim _liveliness nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)

    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 :: MassInputDelete ListLength
    miDelete = miDeleteList

    miAddEmpty _ _ _ = Set.empty

massInputAccumA :: forall handler cellData ident.
                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
                  , MonadThrow handler
                  , ToJSON cellData, FromJSON cellData
                  , PathPiece ident
                  )
               => ((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 ()
               -> ident
               -> FieldSettings UniWorX
               -> Bool
               -> Maybe [cellData]
               -> AForm handler [cellData]
massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
  = formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty

massInputAccumW :: forall handler cellData ident.
                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
                  , MonadThrow handler
                  , ToJSON cellData, FromJSON cellData
                  , PathPiece ident
                  )
               => ((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 ()
               -> ident
               -> FieldSettings UniWorX
               -> Bool
               -> Maybe [cellData]
               -> WForm handler (FormResult [cellData])
massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
  = 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
                      , MonadThrow 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 -> ListLength
          -> (Text -> Text) -> FieldView UniWorX
          -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
    miAdd _pos _dim _liveliness nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)

    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 $ fromMaybe dat mPrev'

    miDelete :: MassInputDelete ListLength
    miDelete = miDeleteList

    miAddEmpty _ _ _ = Set.empty

massInputAccumEditA :: forall handler cellData ident.
                       ( MonadHandler handler, HandlerSite handler ~ UniWorX
                       , MonadThrow 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
                       , MonadThrow 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
           , Liveliness liveliness
           , MonadThrow 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
           , MonadThrow 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