Location

MoreLocatoin.hs

{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI            #-}

module App.Front.Lib.Location where

import           Data.Text                   (Text)
import           GHC.Generics                (Generic)
import           GHCJS.DOM                   (currentWindowUnchecked)
import           GHCJS.DOM.EventTarget       (dispatchEvent_)
import qualified GHCJS.DOM.History           as Dom
import           GHCJS.DOM.Location          (reload)
import           GHCJS.DOM.PopStateEvent     (newPopStateEvent)
import           GHCJS.DOM.Types             (JSM, MonadJSM, ToJSVal, liftJSM, pFromJSVal)
import qualified GHCJS.DOM.Types             as Dom
import           GHCJS.DOM.Window            (getHistory, getLocation)
import qualified Language.Javascript.JSaddle as JS
import           Reflex.Dom.Core

#ifdef ghcjs_HOST_OSs
#else
import Control.Lens.Operators             ((^.))
import Language.Javascript.JSaddle.Object (js, js1, jsg)
#endif

-- TODO: Awaiting proper support for forced reload: https://github.com/ghcjs/ghcjs-dom/issues/79

#ifdef ghcjs_HOST_OS
foreign import javascript unsafe
  "window.location.reload(true);"
  js_forcePageReload :: JSM ()
#else
js_forcePageReload :: JSM ()
js_forcePageReload = do
  window <- jsg ("window"::Text)
  window ^. js ("location"::Text) ^. js1 ("reload"::Text) True
  pure ()
#endif

-- | Triggers a page reload when the event fires. The page may load from cache.
reloadPage :: (MonadJSM (Performable m), PerformEvent t m) => Event t () -> m ()
reloadPage ev = performEvent_ (callJs <$ ev)
  where
    callJs = do
      loc <- getLocation =<< currentWindowUnchecked
      reload loc

-- | Triggers a clean page reload (not from cache) when the event fires.
forceReloadPage
  :: (MonadJSM (Performable m), PerformEvent t m)
  => Event t a -> m ()
forceReloadPage ev = performEvent_ (liftJSM js_forcePageReload <$ ev)


data PageChangeType = PushHistory | ReplaceHistory deriving (Bounded, Enum, Eq, Generic, Show)

changePageState
  :: (MonadJSM (Performable m), PerformEvent t m, ToJSVal state)
  => Event t (PageChangeType, Maybe Text, Maybe state) -> m ()
changePageState ev = performEvent_ (callJs <$> ev)
  where
    callJs (changeType, newUrl, state) = do
      window  <- currentWindowUnchecked
      history <- getHistory window
      let
        fn = case changeType of
          PushHistory    -> Dom.pushState
          ReplaceHistory -> Dom.replaceState

      fn history state (t_ "") newUrl
      liftJSM $ dispatchEvent' window


dispatchEvent' :: Dom.Window -> JSM ()
dispatchEvent' window = do
  obj@(JS.Object o) <- JS.create
  JS.objSetPropertyByName obj (t_ "cancelable") True
  JS.objSetPropertyByName obj (t_ "bubbles")    True
  JS.objSetPropertyByName obj (t_ "view")       window
  event <- newPopStateEvent (t_ "popstate") $ Just $ pFromJSVal o
  dispatchEvent_ window event


t_ :: Text -> Text
t_ = id