-- | Text frontend running in a browser.
module Game.LambdaHack.Client.UI.Frontend.Dom
  (
#ifdef USE_BROWSER
-- to molify doctest, but don't break stylish-haskell parsing
   startup, frontendName
#endif
  ) where

#ifdef USE_BROWSER
import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import qualified Control.Monad.IO.Class as IO
import           Control.Monad.Trans.Reader (ask)
import           Data.IORef
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import           Data.Word (Word32)

import GHCJS.DOM (currentDocument, currentWindow)
import GHCJS.DOM.CSSStyleDeclaration (setProperty)
import GHCJS.DOM.Document (createElement, getBodyUnchecked)
import GHCJS.DOM.Element (Element (Element), setInnerHTML)
import GHCJS.DOM.ElementCSSInlineStyle (getStyle)
import GHCJS.DOM.EventM
  ( EventM
  , mouseAltKey
  , mouseButton
  , mouseCtrlKey
  , mouseMetaKey
  , mouseShiftKey
  , on
  , preventDefault
  , stopPropagation
  )
import GHCJS.DOM.GlobalEventHandlers (contextMenu, keyDown, mouseUp, wheel)
import GHCJS.DOM.HTMLCollection (itemUnsafe)
import GHCJS.DOM.HTMLElement (focus)
import GHCJS.DOM.HTMLTableElement
  (HTMLTableElement (HTMLTableElement), getRows, setCellPadding, setCellSpacing)
import GHCJS.DOM.HTMLTableRowElement
  (HTMLTableRowElement (HTMLTableRowElement), getCells)
import GHCJS.DOM.KeyboardEvent
  (getAltGraphKey, getAltKey, getCtrlKey, getKey, getMetaKey, getShiftKey)
import GHCJS.DOM.Node (appendChild_, replaceChild_, setTextContent)
import GHCJS.DOM.NonElementParentNode (getElementByIdUnsafe)
import GHCJS.DOM.RequestAnimationFrameCallback
import GHCJS.DOM.Types
  ( CSSStyleDeclaration
  , DOM
  , HTMLDivElement (HTMLDivElement)
  , HTMLTableCellElement (HTMLTableCellElement)
  , IsMouseEvent
  , JSString
  , Window
  , runDOM
  , unsafeCastTo
  )
import GHCJS.DOM.WheelEvent (getDeltaY)
import GHCJS.DOM.Window (requestAnimationFrame_)

import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.Frame
import           Game.LambdaHack.Client.UI.Frontend.Common
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.PointUI
import           Game.LambdaHack.Common.Area
import           Game.LambdaHack.Common.ClientOptions
import           Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import           Game.LambdaHack.Content.TileKind (floorSymbol)
import qualified Game.LambdaHack.Definition.Color as Color

-- | Session data maintained by the frontend.
data FrontendSession = FrontendSession
  { scurrentWindow :: Window
  , scharCells     :: V.Vector (HTMLTableCellElement, CSSStyleDeclaration)
  , spreviousFrame :: IORef SingleFrame
  }

-- | The name of the frontend.
frontendName :: String
frontendName = "browser"

-- | Starts the main program loop using the frontend input and output.
startup :: ScreenContent -> ClientOptions -> IO RawFrontend
startup coscreen soptions = do
  rfMVar <- newEmptyMVar
  flip runDOM undefined $ runWeb coscreen soptions rfMVar
  takeMVar rfMVar

runWeb :: ScreenContent -> ClientOptions -> MVar RawFrontend -> DOM ()
runWeb coscreen ClientOptions{..} rfMVar = do
  -- Init the document.
  Just doc <- currentDocument
  Just scurrentWindow <- currentWindow
  body <- getBodyUnchecked doc
  pageStyle <- getStyle body
  setProp pageStyle "background-color" (Color.colorToRGB Color.Black)
  setProp pageStyle "color" (Color.colorToRGB Color.AltWhite)
  -- Create the session record.
  divBlockRaw <- createElement doc ("div" :: Text)
  divBlock <- unsafeCastTo HTMLDivElement divBlockRaw
  let cell = "<td>\x00a0"
      row = "<tr>" ++ concat (replicate (rwidth coscreen) cell)
      rows = concat (replicate (rheight coscreen) row)
  tableElemRaw <- createElement doc ("table" :: Text)
  tableElem <- unsafeCastTo HTMLTableElement tableElemRaw
  -- Get rid of table spacing. Spurious hacks just in case.
  setCellPadding tableElem ("0" :: Text)
  setCellSpacing tableElem ("0" :: Text)
  appendChild_ divBlock tableElem
  setInnerHTML tableElem rows
  scharCells <- flattenTable coscreen tableElem
  spreviousFrame <- newIORef $ blankSingleFrame coscreen
  let sess = FrontendSession{..}
  rf <- IO.liftIO $ createRawFrontend coscreen (display sess) shutdown
  let readMod = do
        modCtrl <- ask >>= getCtrlKey
        modShift <- ask >>= getShiftKey
        modAlt <- ask >>= getAltKey
        modMeta <- ask >>= getMetaKey
        modAltG <- ask >>= getAltGraphKey
        return $! modifierTranslate modCtrl modShift (modAlt || modAltG) modMeta
  gameMap <- getElementByIdUnsafe doc ("gameMap" :: Text)
  divMap <- unsafeCastTo HTMLDivElement gameMap
  focus divMap
  void $ divMap `on` keyDown $ do
    keyId <- ask >>= getKey
    modifier <- readMod
--  This is currently broken at least for Shift-F1, etc., so won't be used:
--    keyLoc <- ask >>= getKeyLocation
--    let onKeyPad = case keyLoc of
--          3 {-KEY_LOCATION_NUMPAD-} -> True
--          _ -> False
    let key = K.keyTranslateWeb keyId (modifier == K.Shift)
        modifierNoShift = case modifier of  -- to prevent S-!, etc.
          K.Shift -> K.NoModifier
          K.ControlShift -> K.Control
          K.AltShift -> K.Alt
          _ -> modifier
    -- IO.liftIO $ do
    --   putStrLn $ "keyId: " ++ keyId
    --   putStrLn $ "key: " ++ K.showKey key
    --   putStrLn $ "modifier: " ++ show modifier
    when (key == K.Esc) $ IO.liftIO $ resetChanKey (fchanKey rf)
    IO.liftIO $ saveKMP rf modifierNoShift key (PointUI 0 0)
    -- Pass through C-+ and others, but disable special behaviour on Tab, etc.
    let browserKeys = "+-0tTnNdxcv"
    unless (modifier == K.Alt
            || modifier == K.Control && key `elem` map K.Char browserKeys
            || key == K.DeadKey) $ do  -- NumLock in particular
      preventDefault
      stopPropagation
  -- Handle mouseclicks, per-cell.
  let setupMouse i a =
        let Point{..} = punindex (rwidth coscreen) i
              -- abuse of convention in that @Point@ used for screen, not map
            pUI = squareToUI $ PointSquare px py
        in handleMouse rf a pUI
  V.imapM_ setupMouse scharCells
  -- Display at the end to avoid redraw. Replace "Please wait".
  pleaseWait <- getElementByIdUnsafe doc ("pleaseWait" :: Text)
  replaceChild_ gameMap divBlock pleaseWait
  IO.liftIO $ putMVar rfMVar rf
    -- send to client only after the whole webpage is set up
    -- because there is no @mainGUI@ to start accepting

shutdown :: IO ()
shutdown = return () -- nothing to clean up

setProp :: CSSStyleDeclaration -> JSString -> Text -> DOM ()
setProp style propRef propValue =
  setProperty style propRef propValue (Nothing :: Maybe JSString)

-- | Let each table cell handle mouse events inside.
handleMouse :: RawFrontend
            -> (HTMLTableCellElement, CSSStyleDeclaration) -> PointUI
            -> DOM ()
handleMouse rf (cell, _) pUI = do
  let readMod :: IsMouseEvent e => EventM HTMLTableCellElement e K.Modifier
      readMod = do
        modCtrl <- mouseCtrlKey
        modShift <- mouseShiftKey
        modAlt <- mouseAltKey
        modMeta <- mouseMetaKey
        return $! modifierTranslate modCtrl modShift modAlt modMeta
      saveWheel = do
        wheelY <- ask >>= getDeltaY
        modifier <- readMod
        let mkey = if | wheelY < -0.01 -> Just K.WheelNorth
                      | wheelY > 0.01 -> Just K.WheelSouth
                      | otherwise -> Nothing  -- probably a glitch
        maybe (return ())
              (\key -> IO.liftIO $ saveKMP rf modifier key pUI) mkey
      saveMouse = do
        -- <https://hackage.haskell.org/package/ghcjs-dom-0.2.1.0/docs/GHCJS-DOM-EventM.html>
        but <- mouseButton
        modifier <- readMod
        let key = case but of
              0 -> K.LeftButtonRelease
              1 -> K.MiddleButtonRelease
              2 -> K.RightButtonRelease  -- not handled in contextMenu
              _ -> K.LeftButtonRelease  -- any other is alternate left
        -- IO.liftIO $ putStrLn $
        --   "m: " ++ show but ++ show modifier ++ show pUI
        IO.liftIO $ saveKMP rf modifier key pUI
  void $ cell `on` wheel $ do
    saveWheel
    preventDefault
    stopPropagation
  void $ cell `on` contextMenu $ do
    preventDefault
    stopPropagation
  void $ cell `on` mouseUp $ do
    saveMouse
    preventDefault
    stopPropagation

-- | Get the list of all cells of an HTML table.
flattenTable :: ScreenContent
             -> HTMLTableElement
             -> DOM (V.Vector (HTMLTableCellElement, CSSStyleDeclaration))
flattenTable coscreen table = do
  rows <- getRows table
  let f y = do
        rowsItem <- itemUnsafe rows y
        unsafeCastTo HTMLTableRowElement rowsItem
  lrow <- mapM f [0 .. toEnum (rheight coscreen - 1)]
  let getC :: HTMLTableRowElement
           -> DOM [(HTMLTableCellElement, CSSStyleDeclaration)]
      getC row = do
        cells <- getCells row
        let g x = do
              cellsItem <- itemUnsafe cells x
              cell <- unsafeCastTo HTMLTableCellElement cellsItem
              style <- getStyle cell
              return (cell, style)
        mapM g [0 .. toEnum (rwidth coscreen - 1)]
  lrc <- mapM getC lrow
  return $! V.fromListN (rwidth coscreen * rheight coscreen) $ concat lrc

-- | Output to the screen via the frontend.
display :: FrontendSession  -- ^ frontend session data
        -> SingleFrame  -- ^ the screen frame to draw
        -> IO ()
display FrontendSession{..} !curFrame = flip runDOM undefined $ do
  let setChar :: Int -> (Word32, Word32) -> DOM Int
      setChar !i (!w, !wPrev) | w == wPrev = return $! i + 1
      setChar i (w, wPrev) = do
        let Point{..} = toEnum i
            Color.AttrChar{acAttr=Color.Attr{fg=fgRaw,bg}, acChar} =
              Color.attrCharFromW32 $ Color.AttrCharW32 w
            fg | even py && fgRaw == Color.White = Color.AltWhite
               | otherwise = fgRaw
            (!cell, !style) = scharCells V.! i
        if | acChar == ' ' -> setTextContent cell $ Just ("\x00a0" :: JSString)
           | acChar == floorSymbol && not (Color.isBright fg) ->
             setTextContent cell $ Just ("\x22C5" :: JSString)
           | otherwise -> setTextContent cell $ Just [acChar]
        setProp style "color" $ Color.colorToRGB fg
        let bgPrev = Color.bgFromW32 $ Color.AttrCharW32 wPrev
        when (bg /= bgPrev) $ do
          let background = if bg == Color.HighlightBackground
                           then "#251F1F"
                           else Color.colorToRGB Color.Black
          setProp style "background-color" background
          setProp style "border-color"
                        (Color.colorToRGB $ Color.highlightToColor bg)
        return $! i + 1
  !prevFrame <- readIORef spreviousFrame
  writeIORef spreviousFrame curFrame
  -- This continues asynchronously, if can't otherwise.
  callback <- newRequestAnimationFrameCallbackSync $ \_ ->
    U.foldM'_ setChar 0 $ U.zip (PointArray.avector $ singleArray curFrame)
                                (PointArray.avector $ singleArray prevFrame)
  -- This attempts to ensure no redraws while callback executes
  -- and a single redraw when it completes.
  requestAnimationFrame_ scurrentWindow callback
#endif