-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.History
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- = Overview
--
-- "Miso.Subscription.History" wraps the browser's
-- <https://developer.mozilla.org/en-US/docs/Web/API/History History API>
-- and
-- <https://developer.mozilla.org/en-US/docs/Web/API/PopStateEvent popstate>
-- event, providing both a reactive subscription and imperative navigation
-- helpers.
--
-- = Subscriptions
--
-- 'uriSub' fires whenever the URL changes — through browser back\/forward
-- buttons or any of the imperative helpers below:
--
-- @
-- subs :: ['Miso.Effect.Sub' Action]
-- subs = [ 'uriSub' UrlChanged ]
-- @
--
-- 'routerSub' is a convenience wrapper that decodes the 'URI' via a
-- 'Miso.Router.Router' instance before delivering it as an action:
--
-- @
-- subs = [ 'routerSub' (RouteChanged . 'Data.Either.fromRight' NotFound) ]
-- @
--
-- = Imperative navigation
--
-- These functions push or replace entries on the browser history stack and
-- simultaneously fire a synthetic @popstate@ event so that 'uriSub' and
-- 'routerSub' are notified automatically:
--
-- @
-- update GoHome     = 'Miso.Effect.io_' ('pushURI' ('Miso.Router.toURI' Home))
-- update GoProfile  = 'Miso.Effect.io_' ('pushRoute' (User (Capture 42)))
-- update ReplaceUrl = 'Miso.Effect.io_' ('replaceURI' newUri)
-- update GoBack     = 'Miso.Effect.io_' 'back'
-- update GoForward  = 'Miso.Effect.io_' 'forward'
-- update (Jump n)   = 'Miso.Effect.io_' ('go' n)
-- @
--
-- 'getURI' reads the current URL from @window.location@ without subscribing:
--
-- @
-- update Init = 'Miso.Effect.io' (GotURI \<$\> 'getURI')
-- @
--
-- = See also
--
-- * "Miso.Router" — 'Miso.Router.Router', 'Miso.Router.URI', 'Miso.Router.toURI', 'Miso.Router.prettyURI'
-- * "Miso.Subscription" — re-export hub
-- * "Miso.Subscription.Util" — 'Miso.Subscription.Util.createSub' used internally
----------------------------------------------------------------------------
module Miso.Subscription.History
  ( -- *** Subscription
    uriSub
  , routerSub
    -- *** Functions
  , getURI
  , pushURI
  , pushRoute
  , 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
  -- ^ The URI to push onto the history stack
  -> IO ()
pushURI :: URI -> IO ()
pushURI URI
uri = do
  MisoString -> IO ()
pushState (URI -> MisoString
prettyURI URI
uri)
  IO ()
raisePopState
-----------------------------------------------------------------------------
-- | Pushes a new 'Route' onto the History stack. Also raises a `popstate` event.
--
-- Converts the t'Route' to a t'URI' internally.
--
pushRoute
  :: Router route
  => route
  -- ^ The route to push onto the history stack (converted to a URI internally)
  -> IO ()
pushRoute :: forall route. Router route => route -> IO ()
pushRoute = URI -> IO ()
pushURI (URI -> IO ()) -> (route -> URI) -> route -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> URI
forall route. Router route => route -> URI
toURI
-----------------------------------------------------------------------------
-- | Replaces current URI on stack. Also raises a `popstate` event.
replaceURI
  :: URI
  -- ^ The URI to replace the current history entry with
  -> 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
  -- ^ Number of steps to jump; positive = forward, negative = backward
  -> 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)
  -- ^ Callback fired with the new 'URI' on every URL change
  -> 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 -> (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
-----------------------------------------------------------------------------
-- | Subscription for @popstate@ events, from the History API, mapped
-- to a user-defined 'Router'.
routerSub
  :: Router route
  => (Either RoutingError route -> action)
  -- ^ Callback fired with the decoded route (or 'RoutingError') on every URL change
  -> 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)
-----------------------------------------------------------------------------