-----------------------------------------------------------------------------
{-# 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.Concurrent
import           Control.Monad
import           Control.Monad.IO.Class
import           System.IO.Unsafe
-----------------------------------------------------------------------------
import           Miso.Concurrent
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.
pushURI :: URI -> IO ()
pushURI :: URI -> IO ()
pushURI URI
uri = do
  MisoString -> IO ()
pushState (URI -> MisoString
prettyURI URI
uri)
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Waiter -> IO ()
notify Waiter
chan)
-----------------------------------------------------------------------------
-- | Replaces current URI on stack.
replaceURI :: URI -> IO ()
replaceURI :: URI -> IO ()
replaceURI URI
uri = do
  MisoString -> IO ()
replaceState (URI -> MisoString
prettyURI URI
uri)
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Waiter -> IO ()
notify Waiter
chan)
-----------------------------------------------------------------------------
-- | 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]
-----------------------------------------------------------------------------
chan :: Waiter
{-# NOINLINE chan #-}
chan :: Waiter
chan = IO Waiter -> Waiter
forall a. IO a -> a
unsafePerformIO IO Waiter
waiter
-----------------------------------------------------------------------------
-- | Subscription for @popstate@ events, from the History API.
uriSub :: (URI -> action) -> Sub action
uriSub :: forall action. (URI -> action) -> Sub action
uriSub URI -> action
f Sink action
sink = IO (ThreadId, Function)
-> ((ThreadId, Function) -> IO ()) -> Sub action
forall a b action. IO a -> (a -> IO b) -> Sub action
createSub IO (ThreadId, Function)
acquire (ThreadId, Function) -> IO ()
release Sink action
sink
  where
    release :: (ThreadId, Function) -> IO ()
release (ThreadId
tid, Function
cb) = do
      MisoString -> Function -> IO ()
FFI.windowRemoveEventListener MisoString
"popstate" Function
cb
      ThreadId -> IO ()
killThread ThreadId
tid
    acquire :: IO (ThreadId, Function)
acquire = do
      tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> (IO () -> IO ()) -> IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Waiter -> IO ()
wait Waiter
chan)
        Sink action
sink Sink action -> (URI -> action) -> URI -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> action
f (URI -> IO ()) -> IO URI -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO URI
getURI
      cb <- FFI.windowAddEventListener "popstate" $ \JSVal
_ ->
        Sink action
sink Sink action -> (URI -> action) -> URI -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> action
f (URI -> IO ()) -> IO URI -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO URI
getURI
      pure (tid, cb)
-----------------------------------------------------------------------------
-- | 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)
-----------------------------------------------------------------------------