@@ -1,13 +1,86 @@
1−module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RankNTypes #-}
25
6+module Reflex.Dom.Location
7+ ( browserHistoryWith
8+ , getLocationAfterHost
9+ , getLocationFragment
10+ , getLocationHost
11+ , getLocationPath
12+ , getLocationProtocol
13+ , getLocationUrl
14+ ) where
15+
16+import Reflex
17+import Reflex.Dom.Builder.Immediate (wrapDomEvent)
18+
19+import Control.Lens ((^.))
20+import Control.Monad ((>=>))
321import Data.Text (Text)
4−import GHCJS.DOM (currentWindowUnchecked)
5−import GHCJS.DOM.Location (getHost, getProtocol)
6−import GHCJS.DOM.Types (MonadJSM)
7−import GHCJS.DOM.Window (getLocation)
22+import qualified GHCJS.DOM as DOM
23+import qualified GHCJS.DOM.EventM as DOM
24+import qualified GHCJS.DOM.Location as Location
25+import GHCJS.DOM.Types (Location)
26+import qualified GHCJS.DOM.Types as DOM
27+import qualified GHCJS.DOM.Window as Window
28+import qualified GHCJS.DOM.WindowEventHandlers as DOM
29+import Language.Javascript.JSaddle (FromJSString, MonadJSM, ToJSString, fromJSValUnchecked, js1, toJSVal)
30+
831
32+withLocation :: (MonadJSM m) => (Location -> m a) -> m a
33+withLocation f = DOM.currentWindowUnchecked >>= Window.getLocation >>= f
34+
35+-- | Returns the full URI-decoded URL of the current window location.
36+getLocationUrl :: (MonadJSM m) => m Text
37+getLocationUrl = withLocation (Location.getHref >=> decodeURIText)
38+
39+-- | Returns the host of the current window location
940getLocationHost :: (MonadJSM m) => m Text
10−getLocationHost = currentWindowUnchecked >>= getLocation >>= getHost
41+getLocationHost = withLocation Location.getHost
1142
43+-- | Returns the protocol/scheme (e.g. @http:@ or @https:@) of the current window location
1244getLocationProtocol :: (MonadJSM m) => m Text
13−getLocationProtocol = currentWindowUnchecked >>= getLocation >>= getProtocol
45+getLocationProtocol = withLocation Location.getProtocol
46+
47+-- | Returns the URI-decoded location after the host and port; i.e. returns the path, query, and fragment of the location.
48+getLocationAfterHost :: (MonadJSM m) => m Text
49+getLocationAfterHost = withLocation $ \loc -> do
50+ pathname <- Location.getPathname loc
51+ search <- Location.getSearch loc
52+ hash <- Location.getHash loc
53+ decodeURI (mconcat [pathname, search, hash] :: Text)
54+
55+-- | Returns the URI-decoded path of the current window location.
56+getLocationPath :: (MonadJSM m) => m Text
57+getLocationPath = withLocation (Location.getPathname >=> decodeURIText)
58+
59+-- | Returns the URI-decoded fragment/hash of the current window location.
60+getLocationFragment :: (MonadJSM m) => m Text
61+getLocationFragment = withLocation (Location.getHash >=> decodeURIText)
62+
63+
64+-- | Decodes a URI with JavaScript's @decodeURI@ function.
65+--
66+-- FIXME: @decodeURI@ will throw when URI is malformed
67+decodeURI :: (MonadJSM m, ToJSString a, FromJSString b) => a -> m b
68+decodeURI input = do
69+ window <- DOM.currentWindowUnchecked
70+ window' <- DOM.liftJSM $ toJSVal window
71+ DOM.liftJSM $ window' ^. js1 ("decodeURI"::Text) input >>= fromJSValUnchecked
72+
73+decodeURIText :: (MonadJSM m) => Text -> m Text
74+decodeURIText = decodeURI
75+
76+-- | Builds a Dynamic carrying the current window location.
77+browserHistoryWith :: (MonadJSM m, TriggerEvent t m, MonadHold t m)
78+ => (forall jsm. MonadJSM jsm => Location -> jsm a)
79+ -- ^ A function to encode the window location in a more useful form (e.g. @getLocationAfterHost@).
80+ -> m (Dynamic t a)
81+browserHistoryWith f = do
82+ window <- DOM.currentWindowUnchecked
83+ location <- Window.getLocation window
84+ loc0 <- f location
85+ locEv <- wrapDomEvent window (`DOM.on` DOM.popState) $ f location
86+ holdDyn loc0 locEv