{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Miso.Subscription.History
( getCurrentURI
, pushURI
, replaceURI
, back
, forward
, go
, uriSub
, URI (..)
) where
import Control.Monad
import Control.Monad.IO.Class
import Miso.Concurrent
import Miso.Effect (Sub)
import Miso.FFI
import qualified Miso.FFI.History as FFI
import Miso.String
import Network.URI hiding (path)
import System.IO.Unsafe
getCurrentURI :: JSM URI
{-# INLINE getCurrentURI #-}
getCurrentURI = getURI
getURI :: JSM URI
{-# INLINE getURI #-}
getURI = do
href <- fromMisoString <$> FFI.getWindowLocationHref
case parseURI href of
Nothing -> fail $ "Could not parse URI from window.location: " ++ href
Just uri -> return uri
pushURI :: URI -> JSM ()
{-# INLINE pushURI #-}
pushURI uri = pushStateNoModel uri { uriPath = toPath uri }
toPath :: URI -> String
toPath uri =
case uriPath uri of
"" -> "/"
"/" -> "/"
xs@('/' : _) -> xs
xs -> '/' : xs
replaceURI :: URI -> JSM ()
{-# INLINE replaceURI #-}
replaceURI uri = replaceTo' uri { uriPath = toPath uri }
back :: JSM ()
{-# INLINE back #-}
back = FFI.back
forward :: JSM ()
{-# INLINE forward #-}
forward = FFI.forward
go :: Int -> JSM ()
{-# INLINE go #-}
go n = FFI.go n
chan :: Notify
{-# NOINLINE chan #-}
chan = unsafePerformIO newEmptyNotify
uriSub :: (URI -> action) -> Sub action
uriSub = \f sink -> do
void.forkJSM.forever $ do
liftIO (wait chan)
liftIO . sink . f =<< getURI
windowAddEventListener "popstate" $ \_ ->
liftIO . sink . f =<< getURI
pushStateNoModel :: URI -> JSM ()
{-# INLINE pushStateNoModel #-}
pushStateNoModel u = do
FFI.pushState . pack . show $ u
liftIO (notify chan)
replaceTo' :: URI -> JSM ()
{-# INLINE replaceTo' #-}
replaceTo' u = do
FFI.replaceState . pack . show $ u
liftIO (notify chan)