DOM.hs

{-# LANGUAGE CPP, OverloadedStrings, PatternSynonyms #-}
module Language.Javascript.JSaddle.DOM (
  currentWindow
, currentDocument
, WebView
, runWebGUI
, enableInspector
) where

import qualified Data.Text as T
import Data.Monoid ((<>))
#ifdef ghcjs_HOST_OS
import GHCJS.Types (JSVal(..))
import GHCJS.Nullable (Nullable(..), nullableToMaybe)
import Control.Applicative ((<$>))
#else
import GI.WebKit.Objects.WebView
       (getWebViewSettings, onWebViewLoadFinished, setWebViewSettings,
        webViewSetSettings, webViewGetSettings, webViewLoadUri, webViewNew,
        webViewGetDomDocument, webViewGetInspector, WebView(..))
import GI.Gtk
       (widgetShowAll, mainQuit,
        WindowPosition(..), containerAdd, scrolledWindowNew,
        windowSetPosition, windowSetDefaultSize, windowNew)
import qualified GI.Gtk.Functions as Gtk (init, main)
import GI.WebKit.Objects.WebSettings
       (setWebSettingsMonospaceFontFamily,
        setWebSettingsEnableDeveloperExtras, setWebSettingsUserAgent,
        getWebSettingsUserAgent)
import GI.Gtk.Objects.Widget (onWidgetDestroy)
import GI.WebKit.Objects.WebInspector
       (onWebInspectorShowWindow, onWebInspectorInspectWebView)
import GI.Gtk.Enums (WindowType(..))
import GI.GLib.Functions (timeoutAdd)
import GI.GLib.Constants (pattern PRIORITY_LOW)
import GI.Gtk.Objects.Adjustment (noAdjustment)
import Control.Monad.IO.Class (liftIO)
#endif

import Language.Javascript.JSaddle.DOM.Window (getNavigator, getDocument)
import Language.Javascript.JSaddle.DOM.Navigator (getUserAgent)
import Foreign (ForeignPtr, nullPtr, Ptr)
import Control.Monad (unless, forever, liftM)
import Control.Concurrent
       (yield, threadDelay, takeMVar, newEmptyMVar)
import System.Environment (getArgs)
import Data.List (isSuffixOf)
import Language.Javascript.JSaddle (runJSaddle, JSM, jsg)
import Language.Javascript.JSaddle.DOM.Types
       (FromJSVal(..), MonadDOM(..), MonadDOM, Document(..), Window(..))
import Control.Monad.IO.Class (MonadIO)

#ifdef ghcjs_HOST_OS
foreign import javascript unsafe "$r = window"
  ghcjs_currentWindow :: IO JSVal

data WebView = WebView
#endif

currentWindow :: MonadDOM m => m (Maybe Window)
currentWindow = liftDOM $ jsg ("window" :: String) >>= fromJSVal

currentDocument :: MonadDOM m => m (Maybe Document)
currentDocument = liftDOM $ jsg ("document" :: String) >>= fromJSVal

runWebGUI :: (WebView -> JSM ()) -> IO ()
runWebGUI = runWebGUI' "GHCJS"

runWebGUI' :: T.Text -> (WebView -> JSM ()) -> IO ()
runWebGUI' userAgentKey main = do
#ifdef ghcjs_HOST_OS
  window <- Window <$> ghcjs_currentWindow
  runJSaddle window $ main WebView
#else
  Gtk.init Nothing
  window <- windowNew WindowTypeToplevel
  timeoutAdd PRIORITY_LOW 10 (yield >> return True)
  windowSetDefaultSize window 900 600
  windowSetPosition window WindowPositionCenter
  scrollWin <- scrolledWindowNew noAdjustment noAdjustment
  webView <- webViewNew
  settings <- getWebViewSettings webView
  userAgent <- getWebSettingsUserAgent settings
  setWebSettingsUserAgent settings $ userAgent <> " " <> userAgentKey
  setWebViewSettings webView settings
  window `containerAdd` scrollWin
  scrollWin `containerAdd` webView
  onWidgetDestroy window $ liftIO mainQuit
  widgetShowAll window
  onWebViewLoadFinished webView $ \frame ->
    runJSaddle webView $ main webView
  args <- getArgs
  case args of
    uri:_ -> webViewLoadUri webView (T.pack uri)
    []    -> runJSaddle webView $ main webView
  Gtk.main
#endif

enableInspector :: MonadIO m => WebView -> m ()
#ifdef ghcjs_HOST_OS
enableInspector _ = return ()
#else
enableInspector webView = liftIO $ do
  settings <- getWebViewSettings webView
  setWebSettingsEnableDeveloperExtras settings True
  setWebViewSettings webView settings
  inspector <- webViewGetInspector webView
  window <- windowNew WindowTypeToplevel
  windowSetDefaultSize window 900 300
  scrollWin <- scrolledWindowNew noAdjustment noAdjustment
  onWebInspectorInspectWebView inspector $ \view -> do
    inspectorView <- webViewNew
    settings <- getWebViewSettings inspectorView
    setWebSettingsMonospaceFontFamily settings "Consolas"
    setWebViewSettings inspectorView settings
    scrollWin `containerAdd` inspectorView
    window `containerAdd` scrollWin
    widgetShowAll window
    return inspectorView
  onWebInspectorShowWindow inspector $ do
    widgetShowAll window
    return True
  return ()
#endif