@@ -0,0 +1,102 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE ForeignFunctionInterface #-}
5+{-# LANGUAGE JavaScriptFFI #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE RecursiveDo #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TemplateHaskell #-}
10+{-# LANGUAGE TypeFamilies #-}
11+
12+module Reflex.Dom.Contrib.Router where
13+
14+------------------------------------------------------------------------------
15+import Control.Concurrent
16+import Control.Monad
17+import Control.Monad.Trans
18+import Data.Maybe
19+import GHCJS.DOM
20+import GHCJS.DOM.Document
21+import GHCJS.DOM.DOMWindow
22+import GHCJS.DOM.HTMLDocument
23+#ifdef ghcjs_HOST_OS
24+import GHCJS.DOM.EventM (event, EventM)
25+import GHCJS.DOM.UIEvent
26+import GHCJS.Foreign
27+import GHCJS.Marshal
28+import GHCJS.Types
29+#endif
30+import Prelude hiding (mapM, mapM_, all, sequence)
31+import Reflex.Dom
32+import Reflex.Dom.Contrib.Utils
33+------------------------------------------------------------------------------
34+
35+
36+------------------------------------------------------------------------------
37+setUrl
38+ :: MonadWidget t m
39+ => Event t String
40+ -> m ()
41+setUrl e = do
42+ performEvent_ $ ffor e $ \url -> liftIO $ do
43+ windowHistoryPushState url
44+
45+
46+------------------------------------------------------------------------------
47+getWindowLocation :: DOMWindow -> IO String
48+#ifdef ghcjs_HOST_OS
49+getWindowLocation w = do
50+ jw <- toJSRef w
51+ liftM fromJSString $ js_windowLocationPathname jw
52+
53+foreign import javascript unsafe
54+ "$1['location']['pathname']"
55+ js_windowLocationPathname :: JSRef DOMWindow -> IO JSString
56+#else
57+getWindowLocation =
58+ error "getWindowLocation: only works in GHCJS"
59+#endif
60+
61+
62+------------------------------------------------------------------------------
63+setupHistoryHandler :: DOMWindow -> (String -> IO ()) -> IO ()
64+#ifdef ghcjs_HOST_OS
65+setupHistoryHandler w cb = do
66+ jw <- toJSRef w
67+ cbRef <- syncCallback1 NeverRetain False (cb . fromJSString)
68+ js_setupHistoryHandler jw cbRef
69+
70+foreign import javascript unsafe
71+ "$1.onpopstate = function(event) { $2($1['location']['pathname']); }"
72+ js_setupHistoryHandler :: JSRef DOMWindow -> (JSFun (JSString -> IO ())) -> IO ()
73+#else
74+setupHistoryHandler =
75+ error "setupHistoryHandler: only works in GHCJS"
76+#endif
77+
78+
79+------------------------------------------------------------------------------
80+-- | Handles routing for a site. The argument to this function is a widget
81+-- function with the effective type signature `String -> m (Event t String)`.
82+-- The String parameter is the initial value of the window location pathname.
83+-- The return value is an event that updates the window location.
84+--routeSite
85+-- :: (forall t m a. (MonadWidget t m) => (String -> m (Event t String)))
86+-- -> IO ()
87+routeSite siteFunc = runWebGUI $ \webView -> do
88+ w <- waitUntilJust currentWindow
89+ path <- getWindowLocation w
90+ --setupHistoryHandler w (\arg -> putStrLn $ "ghcjs history handling! " ++ arg)
91+ --wrapDomEvent w domWindowOnpopstate myGetEvent
92+ doc <- waitUntilJust $ liftM (fmap castToHTMLDocument) $
93+ webViewGetDomDocument webView
94+ body <- waitUntilJust $ documentGetBody doc
95+ attachWidget body webView $ do
96+ changes <- siteFunc path
97+ setUrl changes
98+ return ()
99+
100+--myGetEvent = do
101+-- e <- event
102+-- liftIO $ uiEventGetView e