-----------------------------------------------------------------------------
{-# LANGUAGE RecordWildCards   #-}
-----------------------------------------------------------------------------
-- |
-- 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           Control.Monad.IO.Class
import           Language.Javascript.JSaddle
import           System.IO.Unsafe
-----------------------------------------------------------------------------
import           Miso.Concurrent
import qualified Miso.FFI.Internal as FFI
import           Miso.String
import           Miso.Router
import           Miso.Effect (Sub)
-----------------------------------------------------------------------------
-- | Pushes a new URI onto the History stack
pushURI :: URI -> JSM ()
pushURI :: URI -> JSM ()
pushURI URI
uri = do
  MisoString -> JSM ()
pushState (URI -> MisoString
prettyURI URI
uri)
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Waiter -> IO ()
serve Waiter
chan)
-----------------------------------------------------------------------------
-- | Replaces current URI on stack
replaceURI :: URI -> JSM ()
replaceURI :: URI -> JSM ()
replaceURI URI
uri = do
  MisoString -> JSM ()
replaceState (URI -> MisoString
prettyURI URI
uri)
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Waiter -> IO ()
serve Waiter
chan)
-----------------------------------------------------------------------------
-- | Navigates backwards
back :: JSM ()
back :: JSM ()
back = JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSM JSVal
getHistory JSM JSVal -> String -> () -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"back" (() -> JSM JSVal) -> () -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ ()
-----------------------------------------------------------------------------
-- | Navigates forwards
forward :: JSM ()
forward :: JSM ()
forward = JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSM JSVal
getHistory JSM JSVal -> String -> () -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"forward" (() -> JSM JSVal) -> () -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ ()
-----------------------------------------------------------------------------
-- | Jumps to a specific position in history
go :: Int -> JSM ()
go :: Int -> JSM ()
go Int
n = JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSM JSVal
getHistory JSM JSVal -> String -> [Int] -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"go" ([Int] -> JSM JSVal) -> [Int] -> JSM 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 -> do
  JSM ThreadId -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM ThreadId -> JSM ())
-> (JSM () -> JSM ThreadId) -> JSM () -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSM () -> JSM ThreadId
FFI.forkJSM (JSM () -> JSM ThreadId)
-> (JSM () -> JSM ()) -> JSM () -> JSM ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSM () -> JSM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Waiter -> IO ()
wait Waiter
chan)
    Sink action
sink Sink action -> (URI -> action) -> URI -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> action
f (URI -> JSM ()) -> JSM URI -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM URI
getURI
  JSM Function -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM Function -> JSM ()) -> JSM Function -> JSM ()
forall a b. (a -> b) -> a -> b
$ MisoString -> (JSVal -> JSM ()) -> JSM Function
FFI.windowAddEventListener (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
"popstate") ((JSVal -> JSM ()) -> JSM Function)
-> (JSVal -> JSM ()) -> JSM Function
forall a b. (a -> b) -> a -> b
$ \JSVal
_ ->
    Sink action
sink Sink action -> (URI -> action) -> URI -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> action
f (URI -> JSM ()) -> JSM URI -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM 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 :: JSM URI
getURI :: JSM URI
getURI = do
  location <- String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"window" JSM JSVal -> String -> JSM JSVal
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM JSVal
! String
"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 -> JSM ()
FFI.consoleError (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
"Couldn't parse URI: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
err)
      URI -> JSM URI
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
emptyURI
    Right URI
uri -> do
      URI -> JSM URI
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
uri
-----------------------------------------------------------------------------
getHistory :: JSM JSVal
getHistory :: JSM JSVal
getHistory = String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"window" JSM JSVal -> String -> JSM JSVal
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM JSVal
! String
"history"
-----------------------------------------------------------------------------
pushState :: MisoString -> JSM ()
pushState :: MisoString -> JSM ()
pushState MisoString
url = JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSM JSVal
getHistory JSM JSVal -> String -> (JSVal, JSVal, MisoString) -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"pushState" ((JSVal, JSVal, MisoString) -> JSM JSVal)
-> (JSVal, JSVal, MisoString) -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ (JSVal
jsNull, JSVal
jsNull, MisoString
url)
-----------------------------------------------------------------------------
replaceState :: MisoString -> JSM ()
replaceState :: MisoString -> JSM ()
replaceState MisoString
url = JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSM JSVal
getHistory JSM JSVal -> String -> (JSVal, JSVal, MisoString) -> JSM JSVal
forall this name args.
(MakeObject this, ToJSString name, MakeArgs args) =>
this -> name -> args -> JSM JSVal
# String
"replaceState" ((JSVal, JSVal, MisoString) -> JSM JSVal)
-> (JSVal, JSVal, MisoString) -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ (JSVal
jsNull, JSVal
jsNull, MisoString
url)
-----------------------------------------------------------------------------