@@ -0,0 +1,150 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ForeignFunctionInterface #-}
3+{-# LANGUAGE JavaScriptFFI #-}
4+{-# LANGUAGE RecursiveDo #-}
5+
6+module Reflex.Dom.Contrib.Utils where
7+
8+------------------------------------------------------------------------------
9+import Control.Lens
10+import Control.Monad
11+import Control.Monad.Reader
12+import Data.Aeson
13+import Data.ByteString.Lazy (ByteString)
14+import Data.List
15+import qualified Data.Map as M
16+import Data.Map (Map)
17+import Data.String.Conv
18+import qualified Data.Text as T
19+import GHCJS.DOM.Types hiding (Event)
20+import GHCJS.Foreign
21+import GHCJS.Marshal
22+import GHCJS.Types
23+import Network.HTTP.Types.URI
24+import Reflex
25+import Reflex.Dom
26+------------------------------------------------------------------------------
27+
28+
29+------------------------------------------------------------------------------
30+#ifdef ghcjs_HOST_OS
31+
32+foreign import javascript unsafe
33+ "confirm($1)"
34+ js_confirm :: JSString -> IO Bool
35+
36+foreign import javascript unsafe
37+ "$1.location.pathname"
38+ js_windowLocationPath :: JSRef DOMWindow -> IO JSString
39+
40+foreign import javascript unsafe
41+ "window.history.pushState({},\"\",$1)"
42+ js_windowHistoryPushState :: JSString -> IO ()
43+
44+#else
45+
46+js_confirm :: JSString -> IO Bool
47+js_confirm = error "js_confirm only works in GHCJS."
48+
49+js_windowLocationPath :: JSRef DOMWindow -> IO JSString
50+js_windowLocationPath _ =
51+ error "Window location can only be retrieved in GHCJS."
52+
53+js_windowHistoryPushState :: JSString -> IO ()
54+js_windowHistoryPushState =
55+ error "Window pushState can only be changed in GHCJS."
56+
57+#endif
58+
59+
60+------------------------------------------------------------------------------
61+-- | Convenient function that pops up a javascript confirmation dialog box
62+-- when an event fires with a message to display.
63+confirmEvent :: MonadWidget t m => (a -> String) -> Event t a -> m (Event t a)
64+confirmEvent str e = liftM (fmapMaybe id) $ performEvent (confirm <$> e)
65+ where
66+ confirm a = do
67+ ok <- liftIO $ js_confirm $ toJSString $ str a
68+ return $ if ok then Just a else Nothing
69+
70+
71+------------------------------------------------------------------------------
72+-- | Gets the current path of the DOM Window (i.e., the contents of the
73+-- address bar after the host, beginning with a "/").
74+-- https://developer.mozilla.org/en-US/docs/Web/API/Location
75+getWindowLocationPath :: DOMWindow -> IO String
76+getWindowLocationPath w = do
77+ jw <- toJSRef w
78+ liftM fromJSString $ js_windowLocationPath jw
79+
80+
81+------------------------------------------------------------------------------
82+-- | Pushes a new URL to the window history.
83+windowHistoryPushState :: String -> IO ()
84+windowHistoryPushState = js_windowHistoryPushState . toJSString
85+
86+
87+------------------------------------------------------------------------------
88+-- | URL encodes a map of key-value pairs.
89+formEncode :: Map String ByteString -> String
90+formEncode m =
91+ intercalate "&" $
92+ map (\(k,v) -> k ++ "=" ++ (encodeToString v)) $ M.toList m
93+ where
94+ encodeToString :: ByteString -> String
95+ encodeToString = toS . urlEncode True . toS
96+
97+
98+------------------------------------------------------------------------------
99+-- | Form encodes a JSON object.
100+formEncodeJSON :: ToJSON a => a -> String
101+formEncodeJSON a = case toJSON a of
102+ Object m ->
103+ formEncode $ M.fromList $ map (bimap T.unpack encode) $ itoList m
104+ _ -> error "formEncodeJSON requires an Object"
105+
106+
107+------------------------------------------------------------------------------
108+-- | Convenience function for constructing a POST request.
109+toPost
110+ :: String
111+ -- ^ URL
112+ -> String
113+ -- ^ The post data
114+ -> XhrRequest
115+toPost url d =
116+ XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
117+ , _xhrRequestConfig_sendData = Just d
118+ }
119+ where
120+ headerUrlEnc :: Map String String
121+ headerUrlEnc = "Content-type" =: "application/x-www-form-urlencoded"
122+
123+
124+------------------------------------------------------------------------------
125+-- | A common form for widgetHold calls that mirrors the pattern seen in hold
126+-- and holdDyn.
127+widgetHoldHelper
128+ :: MonadWidget t m
129+ => (a -> m b)
130+ -> a
131+ -> Event t a
132+ -> m (Dynamic t b)
133+widgetHoldHelper f eDef e = widgetHold (f eDef) (f <$> e)
134+
135+
136+------------------------------------------------------------------------------
137+-- | Simple debug function that prints a message on postBuild.
138+putDebugLn :: MonadWidget t m => String -> m ()
139+putDebugLn str = do
140+ pb <- getPostBuild
141+ putDebugLnE pb (const str)
142+
143+
144+------------------------------------------------------------------------------
145+-- | Prints a string when an event fires. This differs slightly from
146+-- traceEvent because it will print even if the event is otherwise unused.
147+putDebugLnE :: MonadWidget t m => Event t a -> (a -> String) -> m ()
148+putDebugLnE e mkStr = do
149+ performEvent_ (liftIO . putStrLn . mkStr <$> e)
150+