{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Handler.Utils.Form.MassInput
  ( MassInput(..)
  , massInput
  , massInputList
  , BoxDimension(..)
  , IsBoxCoord(..), boxDimension
  , Liveliness(..)
  , ListLength(..), ListPosition(..), miDeleteList
  ) 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))


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)))


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
  , 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`
  }

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 ((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.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
    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' :: 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
  
  let
    fvLabel = toHtml $ mr fsLabel
    fvTooltip = toHtml . mr <$> fsTooltip
    fvInput = $(widgetFile "widgets/massinput/massinput")
    fvErrors = Nothing
    in return (result, FieldView{..})


-- | 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
            , miButtonAction
            }
  miSettings
  miRequired
  (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)