{-# 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 :: JSM URI
getCurrentURI = JSM URI
getURI
getURI :: JSM URI
{-# INLINE getURI #-}
getURI :: JSM URI
getURI = do
String
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 String -> Maybe URI
parseURI String
href of
Maybe URI
Nothing -> String -> JSM URI
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 (m :: * -> *) a. Monad m => a -> m a
return URI
uri
pushURI :: URI -> JSM ()
{-# INLINE pushURI #-}
pushURI :: URI -> JSM ()
pushURI URI
uri = URI -> JSM ()
pushStateNoModel URI
uri { uriPath :: String
uriPath = URI -> String
toPath URI
uri }
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
replaceURI :: URI -> JSM ()
{-# INLINE replaceURI #-}
replaceURI :: URI -> JSM ()
replaceURI URI
uri = URI -> JSM ()
replaceTo' URI
uri { uriPath :: String
uriPath = URI -> String
toPath URI
uri }
back :: JSM ()
{-# INLINE back #-}
back :: JSM ()
back = JSM ()
FFI.back
forward :: JSM ()
{-# INLINE forward #-}
forward :: JSM ()
forward = JSM ()
FFI.forward
go :: Int -> JSM ()
{-# INLINE go #-}
go :: Int -> JSM ()
go Int
n = Int -> JSM ()
FFI.go Int
n
chan :: Notify
{-# NOINLINE chan #-}
chan :: Notify
chan = IO Notify -> Notify
forall a. IO a -> a
unsafePerformIO IO Notify
newEmptyNotify
uriSub :: (URI -> action) -> Sub action
uriSub :: (URI -> action) -> Sub action
uriSub = \URI -> action
f Sink action
sink -> do
JSM () -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void(JSM () -> JSM ()) -> (JSM () -> JSM ()) -> JSM () -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.JSM () -> JSM ()
forkJSM(JSM () -> JSM ()) -> (JSM () -> JSM ()) -> JSM () -> JSM ()
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Notify -> IO ()
wait Notify
chan)
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> (URI -> IO ()) -> URI -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sink action
sink Sink action -> (URI -> action) -> URI -> IO ()
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 ()
windowAddEventListener MisoString
"popstate" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \JSVal
_ ->
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> (URI -> IO ()) -> URI -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sink action
sink Sink action -> (URI -> action) -> URI -> IO ()
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Notify -> IO ()
notify Notify
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Notify -> IO ()
notify Notify
chan)