-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.History
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Subscription.History
  ( -- *** Subscription
    uriSub
  , routerSub
    -- *** Functions
  , getURI
  , pushURI
  , replaceURI
  , back
  , forward
  , go
   -- *** Types
  , URI (..)
  ) where
-----------------------------------------------------------------------------
import           Control.Monad
-----------------------------------------------------------------------------
import           Miso.DSL
import qualified Miso.FFI.Internal as FFI
import           Miso.String
import           Miso.Router
import           Miso.Effect (Sub)
import           Miso.Subscription.Util
-----------------------------------------------------------------------------
-- | Pushes a new URI onto the History stack. Also raises a `popstate` event.
pushURI :: URI -> IO ()
pushURI :: URI -> IO ()
pushURI URI
uri = do
  MisoString -> IO ()
pushState (URI -> MisoString
prettyURI URI
uri)
  IO ()
raisePopState
-----------------------------------------------------------------------------
-- | Replaces current URI on stack. Also raises a `popstate` event.
replaceURI :: URI -> IO ()
replaceURI :: URI -> IO ()
replaceURI URI
uri = do
  MisoString -> IO ()
replaceState (URI -> MisoString
prettyURI URI
uri)
  IO ()
raisePopState
-----------------------------------------------------------------------------
raisePopState :: IO ()
raisePopState :: IO ()
raisePopState = do
  event <- IO JSVal -> [MisoString] -> IO JSVal
forall constructor args.
(ToObject constructor, ToArgs args) =>
constructor -> args -> IO JSVal
new (MisoString -> IO JSVal
jsg MisoString
"PopStateEvent") [MisoString
"popstate" :: MisoString]
  window <- jsg "window"
  void $ window # "dispatchEvent" $ [event]
-----------------------------------------------------------------------------
-- | Navigates backwards.
back :: IO ()
back :: IO ()
back = IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO JSVal -> IO ()) -> IO JSVal -> IO ()
forall a b. (a -> b) -> a -> b
$ IO JSVal
getHistory IO JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"back" (() -> IO JSVal) -> () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ ()
-----------------------------------------------------------------------------
-- | Navigates forwards.
forward :: IO ()
forward :: IO ()
forward = IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO JSVal -> IO ()) -> IO JSVal -> IO ()
forall a b. (a -> b) -> a -> b
$ IO JSVal
getHistory IO JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"forward" (() -> IO JSVal) -> () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ ()
-----------------------------------------------------------------------------
-- | Jumps to a specific position in history.
go :: Int -> IO ()
go :: Int -> IO ()
go Int
n = IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO JSVal -> IO ()) -> IO JSVal -> IO ()
forall a b. (a -> b) -> a -> b
$ IO JSVal
getHistory IO JSVal -> MisoString -> [Int] -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"go" ([Int] -> IO JSVal) -> [Int] -> IO JSVal
forall a b. (a -> b) -> a -> b
$ [Int
n]
-----------------------------------------------------------------------------
-- | Subscription for t'URI' changes, uses the History API.
--
-- This returns a new t'URI' whenever `go`, `back`, `forward`, `pushState`
-- or `replaceState` have been called.
--
uriSub :: (URI -> action) -> Sub action
uriSub :: forall action. (URI -> action) -> Sub action
uriSub URI -> action
f Sink action
sink = IO Function -> (Function -> IO ()) -> Sub action
forall a b action. IO a -> (a -> IO b) -> Sub action
createSub IO Function
acquire Function -> IO ()
release Sink action
sink
  where
    release :: Function -> IO ()
release = MisoString -> Function -> IO ()
FFI.windowRemoveEventListener MisoString
"popstate"
    acquire :: IO Function
acquire = MisoString -> (JSVal -> IO ()) -> IO Function
FFI.windowAddEventListener MisoString
"popstate" ((JSVal -> IO ()) -> IO Function)
-> (JSVal -> IO ()) -> IO Function
forall a b. (a -> b) -> a -> b
$ \JSVal
_ ->
      (Sink action
sink Sink action -> IO action -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< URI -> action
f (URI -> action) -> IO URI -> IO action
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO URI
getURI)
-----------------------------------------------------------------------------
-- | Subscription for @popstate@ events, from the History API, mapped
-- to a user-defined 'Router'.
routerSub :: Router route => (Either RoutingError route -> action) -> Sub action
routerSub :: forall route action.
Router route =>
(Either RoutingError route -> action) -> Sub action
routerSub Either RoutingError route -> action
f = (URI -> action) -> Sub action
forall action. (URI -> action) -> Sub action
uriSub ((URI -> action) -> Sub action) -> (URI -> action) -> Sub action
forall a b. (a -> b) -> a -> b
$ \URI
uri -> Either RoutingError route -> action
f (URI -> Either RoutingError route
forall route. Router route => URI -> Either RoutingError route
route URI
uri)
-----------------------------------------------------------------------------
-- | Retrieves the current relative URI by inspecting @pathname@, @search@
-- and @hash@.
getURI :: IO URI
getURI :: IO URI
getURI = do
  location <- MisoString -> IO JSVal
jsg MisoString
"window" IO JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"location"
  pathname <- fromJSValUnchecked =<< location ! "pathname"
  search <- fromJSValUnchecked =<< location ! "search"
  hash <- fromJSValUnchecked =<< location ! "hash"
  let uriText =
        [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat
        [ MisoString
pathname
        , MisoString
search
        , MisoString
hash
        ]
  case parseURI uriText of
    Left MisoString
err -> do
      MisoString -> IO ()
FFI.consoleError (MisoString
"Couldn't parse URI: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
err)
      URI -> IO URI
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
emptyURI
    Right URI
uri -> do
      URI -> IO URI
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
uri
-----------------------------------------------------------------------------
getHistory :: IO JSVal
getHistory :: IO JSVal
getHistory = MisoString -> IO JSVal
jsg MisoString
"window" IO JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"history"
-----------------------------------------------------------------------------
pushState :: MisoString -> IO ()
pushState :: MisoString -> IO ()
pushState MisoString
url = IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO JSVal -> IO ()) -> IO JSVal -> IO ()
forall a b. (a -> b) -> a -> b
$ IO JSVal
getHistory IO JSVal -> MisoString -> (JSVal, JSVal, MisoString) -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"pushState" ((JSVal, JSVal, MisoString) -> IO JSVal)
-> (JSVal, JSVal, MisoString) -> IO JSVal
forall a b. (a -> b) -> a -> b
$ (JSVal
jsNull, JSVal
jsNull, MisoString
url)
-----------------------------------------------------------------------------
replaceState :: MisoString -> IO ()
replaceState :: MisoString -> IO ()
replaceState MisoString
url = IO JSVal -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO JSVal -> IO ()) -> IO JSVal -> IO ()
forall a b. (a -> b) -> a -> b
$ IO JSVal
getHistory IO JSVal -> MisoString -> (JSVal, JSVal, MisoString) -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"replaceState" ((JSVal, JSVal, MisoString) -> IO JSVal)
-> (JSVal, JSVal, MisoString) -> IO JSVal
forall a b. (a -> b) -> a -> b
$ (JSVal
jsNull, JSVal
jsNull, MisoString
url)
-----------------------------------------------------------------------------