{-# 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))
  , miCell :: BoxCoord liveliness -- Position
           -> cellData -- Initialisation data
           -> Maybe cellResult -- Previous result
           -> (Text -> Text) -- Nudge deterministic field ids
           -> (Markup -> MForm handler (FormResult cellResult, Widget))
  , miDelete :: liveliness -> BoxCoord liveliness -> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness))
  , miAllowAdd :: BoxCoord liveliness -> Natural -> liveliness -> Bool
  }

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 = mdo
  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'

  $logDebugS "massInput" [st|Current shape: #{tshow (map toPathPiece (Map.keys shape))}|]

  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

  cellResults <- flip Map.traverseWithKey shape $ \miCoord cData -> do
    let
      nudgeCellName :: Text -> Text
      nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
    local (over _1 applyDelShapeUpdate) $ (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

  liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness

  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{..})