--------------------------------------------------------------------------------
-- |
-- module:    Dialog.RunWebkitGtk3
-- copyright: (c) 2015 Nikita Churaev
-- license:   BSD3
--------------------------------------------------------------------------------

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------

module Dialog.RunWebkitGtk3 (
  runDialogUsingWebkitGtk3
) where

--------------------------------------------------------------------------------

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Exception (SomeException, finally, catch)
import Control.Concurrent (forkIO, forkOS)
import Control.Concurrent.MVar (
    MVar, newMVar, newEmptyMVar, readMVar, swapMVar, takeMVar, putMVar,
    tryReadMVar, tryTakeMVar)
import Data.Maybe (isNothing)
import Data.Monoid ((<>))
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import System.FilePath ((</>))
import System.Glib.Attributes (AttrOp ((:=)))
import Web.Browser (openBrowser)
import Paths_dialog (getDataFileName)
import Dialog.Internal
import Dialog.EncodeJSON
import qualified Data.Text.Lazy as TL
import qualified System.Glib.Attributes as GA
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.WebKit.WebView as WV
import qualified Graphics.UI.Gtk.WebKit.NetworkRequest as NR
import qualified Graphics.UI.Gtk.WebKit.WebPolicyDecision as WPD
import qualified Graphics.UI.Gtk.WebKit.DOM.Document as Document
import qualified Graphics.UI.Gtk.WebKit.DOM.HTMLElement as HTMLElement
import qualified Graphics.UI.Gtk.WebKit.DOM.Element as Element
import qualified Graphics.UI.Gtk.WebKit.DOM.EventM as EventM

--------------------------------------------------------------------------------

data Message =
  Ready |
  AskLineAnswer String

--------------------------------------------------------------------------------

data SharedState = SharedState {
    shrWindow :: Gtk.Window,
    shrWebView :: WV.WebView,
    shrWakeUpDialog :: MVar (),
    shrExitRequested :: MVar (),
    shrNoRunningDialog :: MVar ()
  }

--------------------------------------------------------------------------------

runDialogUsingWebkitGtk3 :: MonadIO m => DialogIO () -> m ()
runDialogUsingWebkitGtk3 dialog = liftIO $ do
  htmlPath <- getDataFileName "html"
  let dialogHTML = "file://" ++ (htmlPath </> "dialog.html")

  Gtk.initGUI

  webView <- WV.webViewNew
  WV.webViewLoadUri webView dialogHTML

  scrolledWindow <- Gtk.scrolledWindowNew Nothing Nothing
  Gtk.containerAdd scrolledWindow webView

  window <- Gtk.windowNew
  Gtk.windowSetDefaultSize window 900 600
  Gtk.widgetSetSizeRequest window 480 320
  GA.set window [Gtk.windowTitle := ("Dialog" :: String)]
  Gtk.on window Gtk.deleteEvent $ do
    liftIO Gtk.mainQuit
    pure False
  Gtk.containerAdd window scrolledWindow
  Gtk.widgetShowAll window

  wakeUpDialog <- newEmptyMVar
  exitRequested <- newEmptyMVar
  noRunningDialog <- newMVar ()

  let shared = SharedState {
      shrWindow = window,
      shrWebView = webView,
      shrWakeUpDialog = wakeUpDialog,
      shrExitRequested = exitRequested,
      shrNoRunningDialog = noRunningDialog
    }

  Gtk.on webView WV.navigationPolicyDecisionRequested $
    \_ request _ decision -> do
      maybeURI <- liftIO $ NR.networkRequestGetUri request
      case maybeURI of
        Just uri -> do
          when (uri /= dialogHTML) $ do
            liftIO $ WPD.webPolicyDecisionIgnore decision
            liftIO $ openBrowser uri
            pure ()
          pure False
        Nothing -> pure False

  Gtk.on webView WV.documentLoadFinished $ \_ -> do
    Just document <- WV.webViewGetDomDocument webView

    Just scriptOutput <-
      Document.getElementById document ("script-output" :: String)
    scriptOutputListener <- liftIO $ EventM.newListener $ do
      liftIO $ putMVar wakeUpDialog ()
    EventM.addListener scriptOutput Element.click scriptOutputListener False 

    Just resetButton <-
      Document.getElementById document ("reset-button" :: String)
    resetButtonListener <- liftIO $ EventM.newListener $ do
      liftIO $ runDialogThread shared dialog
    EventM.addListener resetButton Element.click resetButtonListener False

    runDialogThread shared dialog 

  Gtk.mainGUI
  pure ()

--------------------------------------------------------------------------------

data PrivateState = PrivateState {
    privEndMessageRef :: IORef String
  }

runDialogThread :: SharedState -> DialogIO () -> IO ()
runDialogThread shared dialog = do
  endMessageRef <- newIORef "End of program."
  let priv = PrivateState {
      privEndMessageRef = endMessageRef
    }
  _ <- forkOS (dialogThreadMain shared priv dialog)
  pure ()

dialogThreadMain :: SharedState -> PrivateState -> DialogIO () -> IO ()
dialogThreadMain shared priv dialog =
  finally
    (catch
      (do
        stopExistingDialog
        clearStatusMVars
        postScriptTL "dialogReset()"
        runCommands dialog
        handleExitRequest 
          (pure ())
          (do
            endMessage <- readIORef (privEndMessageRef priv)
            postScriptTL ("dialogEnd(" <> strJSON endMessage <> ")")))
      (\(e :: SomeException) ->
        handleExitRequest
          (pure ())
          (postScriptTL ("dialogException(" <> strJSON (show e) <> ")"))))
    (putMVar (shrNoRunningDialog shared) ())
  where
    handleExitRequest :: IO a -> IO a -> IO a
    handleExitRequest ifExitting ifContinuing = do
      exitRequested <- tryReadMVar (shrExitRequested shared)
      if isNothing exitRequested
        then ifContinuing
        else ifExitting

    stopExistingDialog = do
      putMVar (shrExitRequested shared) ()
      putMVar (shrWakeUpDialog shared) ()
      takeMVar (shrNoRunningDialog shared)

    clearStatusMVars = do
      tryTakeMVar (shrWakeUpDialog shared)
      tryTakeMVar (shrExitRequested shared)
  
    runCommands :: forall a . DialogIO a -> IO a
    runCommands = \case
      Pure value -> pure value
      Bind func ->
        func handleBind
        where
          handleBind :: forall b . DialogIO b -> (b -> DialogIO a) -> IO a
          handleBind dialog getNextDialog = do
            result <- runCommands dialog
            handleExitRequest
              undefined
              (runCommands (getNextDialog result))
      Lift action ->
        action
      ChangeTitle title ->
        Gtk.postGUISync (GA.set (shrWindow shared) [Gtk.windowTitle := title])
      ChangeEndMessage endMessage ->
        writeIORef (privEndMessageRef priv) endMessage
      Display paragraphs ->
        postScriptTL ("dialogDisplay(" <> paragraphsToJSON paragraphs <> ")")
      AskLine prompt ->
        awaitScriptOutput
          (postScriptTL ("dialogAskLine(" <> strJSON prompt <> ")"))

    postScriptTL script =
      Gtk.postGUISync
        (WV.webViewExecuteScript (shrWebView shared) (TL.toStrict script))

    awaitScriptOutput :: IO () -> IO String
    awaitScriptOutput action = do
      action
      takeMVar (shrWakeUpDialog shared)
      handleExitRequest
        undefined
        (Gtk.postGUISync $ do
          Just document <- WV.webViewGetDomDocument (shrWebView shared)
          Just scriptOutput <-
            Document.getElementById document ("script-output" :: String)
          Just string <-
            HTMLElement.getInnerText
              (HTMLElement.castToHTMLElement scriptOutput)
          pure string)

--------------------------------------------------------------------------------