--------------------------------------------------------------------------------
-- |
-- 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 (forkOS)
import Control.Concurrent.MVar (
    MVar, newMVar, newEmptyMVar, 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 SharedState = SharedState {
    shrWindow :: Gtk.Window,
    shrWebView :: WV.WebView,
    shrWakeUpDialog :: MVar (),
    shrExitRequested :: MVar (),
    shrNoRunningDialog :: MVar ()
  }

data PrivateState = PrivateState {
    privEndMessageRef :: IORef String
  }

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

executeScriptTL :: WV.WebView -> TL.Text -> IO ()
executeScriptTL webView script =
  WV.webViewExecuteScript webView (TL.toStrict script)

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

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
  _ <- 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)
            couldOpenBrowser <- liftIO (openBrowser uri)
            when (not couldOpenBrowser) $
              liftIO (executeScriptTL webView 
                        ("couldNotOpenBrowser(" <> strJSON uri <> ")"))
          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 ()

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

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
        setWindowTitle "Dialog"
        postScriptTL "dialogReset()"
        runActions 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 :: IO ()
    stopExistingDialog = do
      putMVar (shrExitRequested shared) ()
      putMVar (shrWakeUpDialog shared) ()
      _ <- takeMVar (shrNoRunningDialog shared)
      pure ()

    clearStatusMVars :: IO ()
    clearStatusMVars = do
      _ <- tryTakeMVar (shrWakeUpDialog shared)
      _ <- tryTakeMVar (shrExitRequested shared)
      pure ()
  
    runActions :: forall a . DialogIO a -> IO a
    runActions = \case
      Pure value -> pure value
      Bind func ->
        func handleBind
        where
          handleBind :: forall b . DialogIO b -> (b -> DialogIO a) -> IO a
          handleBind action getNextAction = do
            result <- runActions action
            handleExitRequest
              undefined
              (runActions (getNextAction result))
      Lift action ->
        action
      ChangeTitle title ->
        setWindowTitle title
      ChangeEndMessage endMessage ->
        writeIORef (privEndMessageRef priv) endMessage
      Display paragraphs ->
        postScriptTL ("dialogDisplay(" <> paragraphsToJSON paragraphs <> ")")
      AskLine prompt ->
        awaitScriptOutput
          (postScriptTL ("dialogAskLine(" <> strJSON prompt <> ")"))

    setWindowTitle :: String -> IO ()
    setWindowTitle title =
      Gtk.postGUISync (GA.set (shrWindow shared) [Gtk.windowTitle := title])

    postScriptTL :: TL.Text -> IO ()
    postScriptTL script =
      Gtk.postGUISync (executeScriptTL (shrWebView shared) 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)

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