-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# 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
    -- *** Functions
  , getURI
  , pushURI
  , replaceURI
  , back
  , forward
  , go
   -- *** Types 
  , URI (..)
  ) where
-----------------------------------------------------------------------------
import           Control.Monad
import           Control.Monad.IO.Class
import           Miso.Concurrent
import           Miso.FFI.Internal (JSM)
import qualified Miso.FFI.Internal as FFI
import qualified Miso.FFI.History as FFI
import           Miso.String
import           Miso.Effect (Sub)
import           Network.URI hiding (path)
import           System.IO.Unsafe
-----------------------------------------------------------------------------
-- | Retrieves current URI of page
getURI :: JSM URI
{-# INLINE getURI #-}
getURI :: JSM URI
getURI = do
  href <- MisoString -> String
forall a. FromMisoString a => MisoString -> a
fromMisoString (MisoString -> String) -> JSM MisoString -> JSM String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSM MisoString
FFI.getWindowLocationHref
  case parseURI href of
    Maybe URI
Nothing  -> String -> JSM URI
forall a. String -> JSM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> JSM URI) -> String -> JSM URI
forall a b. (a -> b) -> a -> b
$ String
"Could not parse URI from window.location: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
href
    Just URI
uri ->
      URI -> JSM URI
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> URI
dropPrefix URI
uri)
  where
    dropPrefix :: URI -> URI
dropPrefix u :: URI
u@URI{String
Maybe URIAuth
uriScheme :: String
uriAuthority :: Maybe URIAuth
uriPath :: String
uriQuery :: String
uriFragment :: String
uriAuthority :: URI -> Maybe URIAuth
uriFragment :: URI -> String
uriPath :: URI -> String
uriQuery :: URI -> String
uriScheme :: URI -> String
..}
      | Char
'/' : String
xs <- String
uriPath = URI
u { uriPath = xs }
      | Bool
otherwise = URI
u
-----------------------------------------------------------------------------
-- | Pushes a new URI onto the History stack
pushURI :: URI -> JSM ()
{-# INLINE pushURI #-}
pushURI :: URI -> JSM ()
pushURI URI
uri = URI -> JSM ()
pushStateNoModel URI
uri { uriPath = toPath uri }
-----------------------------------------------------------------------------
-- | Prepend '/' if necessary
toPath :: URI -> String
toPath :: URI -> String
toPath URI
uri =
  case URI -> String
uriPath URI
uri of
    String
"" -> String
"/"
    String
"/" -> String
"/"
    xs :: String
xs@(Char
'/' : String
_) -> String
xs
    String
xs -> Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
-----------------------------------------------------------------------------
-- | Replaces current URI on stack
replaceURI :: URI -> JSM ()
{-# INLINE replaceURI #-}
replaceURI :: URI -> JSM ()
replaceURI URI
uri = URI -> JSM ()
replaceTo' URI
uri { uriPath = toPath uri }
-----------------------------------------------------------------------------
-- | Navigates backwards
back :: JSM ()
{-# INLINE back #-}
back :: JSM ()
back = JSM ()
FFI.back
-----------------------------------------------------------------------------
-- | Navigates forwards
forward :: JSM ()
{-# INLINE forward #-}
forward :: JSM ()
forward = JSM ()
FFI.forward
-----------------------------------------------------------------------------
-- | Jumps to a specific position in history
go :: Int -> JSM ()
{-# INLINE go #-}
go :: Int -> JSM ()
go Int
n = Int -> JSM ()
FFI.go 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
  MisoString -> (JSVal -> JSM ()) -> JSM ()
FFI.windowAddEventListener MisoString
"popstate" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
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
-----------------------------------------------------------------------------
pushStateNoModel :: URI -> JSM ()
{-# INLINE pushStateNoModel #-}
pushStateNoModel :: URI -> JSM ()
pushStateNoModel URI
u = do
  MisoString -> JSM ()
FFI.pushState (MisoString -> JSM ()) -> (URI -> MisoString) -> URI -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
pack (String -> MisoString) -> (URI -> String) -> URI -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
forall a. Show a => a -> String
show (URI -> JSM ()) -> URI -> JSM ()
forall a b. (a -> b) -> a -> b
$ URI
u
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Waiter -> IO ()
serve Waiter
chan)
-----------------------------------------------------------------------------
replaceTo' :: URI -> JSM ()
{-# INLINE replaceTo' #-}
replaceTo' :: URI -> JSM ()
replaceTo' URI
u = do
  MisoString -> JSM ()
FFI.replaceState (MisoString -> JSM ()) -> (URI -> MisoString) -> URI -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
pack (String -> MisoString) -> (URI -> String) -> URI -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
forall a. Show a => a -> String
show (URI -> JSM ()) -> URI -> JSM ()
forall a b. (a -> b) -> a -> b
$ URI
u
  IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Waiter -> IO ()
serve Waiter
chan)
-----------------------------------------------------------------------------