1ad28cb · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Add FileInput; fix a few other things

1ad28cbRyan Trinkle11 years ago

src-ghc/Reflex/Dom/Xhr/Foreign.hs+12−3

compare with develop

unifiedsplit

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ForeignFunctionInterface #-}

1+{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances, FlexibleInstances #-}

2module Reflex.Dom.Xhr.Foreign where

4import Control.Lens.Indexed

@@ -96,8 +96,17 @@ xmlHttpRequestGetResponseText xhr = do

96 peekCString ps

97 return $ Just s

99+class IsXhrPayload a where

100+ xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()

101+

102+instance IsXhrPayload () where

103+ xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr Nothing

104+

105+instance IsXhrPayload String where

106+ xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just

107+

99−xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()

108+xmlHttpRequestSendPayload :: XMLHttpRequest -> Maybe String -> IO ()

100−xmlHttpRequestSend xhr payload = do

109+xmlHttpRequestSendPayload xhr payload = do

101 let c = xhrContext xhr

110 let c = xhrContext xhr

102 (o,s) <- case payload of

111 (o,s) <- case payload of

103 Nothing -> do

112 Nothing -> do

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+21−13

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}

1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, FlexibleInstances #-}

3module Reflex.Dom.Xhr.Foreign where

@@ -7,12 +7,11 @@ import GHCJS.Foreign

7import GHCJS.Marshal

8import qualified Data.Text as T

9import Data.Text (Text)

10−import Data.Word

11import GHCJS.DOM.Types hiding (Text)

10import GHCJS.DOM.Types hiding (Text)

12−import Control.Applicative ((<$>))

13import GHCJS.DOM.EventM

11import GHCJS.DOM.EventM

14import GHCJS.DOM

12import GHCJS.DOM

15import Data.Function

13import Data.Function

14+import Control.Monad

17prepareWebView :: WebView -> IO ()

16prepareWebView :: WebView -> IO ()

18prepareWebView _ = return ()

17prepareWebView _ = return ()

@@ -116,17 +115,26 @@ xmlHttpRequestOpen self method url async user password

116

115

117foreign import javascript unsafe "($2===null)?$1[\"send\"]():$1[\"send\"]($2)"

116foreign import javascript unsafe "($2===null)?$1[\"send\"]():$1[\"send\"]($2)"

118 ghcjs_dom_xml_http_request_send ::

117 ghcjs_dom_xml_http_request_send ::

119− JSRef XMLHttpRequest -> JSString -> IO ()

118+ JSRef XMLHttpRequest -> JSRef XhrPayload -> IO ()

120

119

120+newtype XhrPayload = XhrPayload { unXhrPayload :: JSRef XhrPayload }

121+

122+class IsXhrPayload a where

121−xmlHttpRequestSend ::

123+ xmlHttpRequestSend :: IsXMLHttpRequest self => self -> a -> IO ()

122− (IsXMLHttpRequest self, ToJSString payload) =>

124+

123− self -> Maybe payload -> IO ()

125+instance IsXhrPayload () where

124−xmlHttpRequestSend self payload

126+ xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr $ XhrPayload jsNull

125− = ghcjs_dom_xml_http_request_send

127+

128+instance IsXhrPayload String where

129+ xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . XhrPayload . castRef . toJSString

130+

131+foreign import javascript unsafe "$r = new FormData(); $r['append']($1, $2)" fileToFormData :: JSString -> JSRef File -> IO (JSRef XhrPayload)

132+

133+instance IsXhrPayload File where

134+ xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . XhrPayload <=< fileToFormData (toJSString "file") . unFile

135+

136+xmlHttpRequestSendPayload :: IsXMLHttpRequest self => self -> XhrPayload -> IO ()

126− (unXMLHttpRequest (toXMLHttpRequest self))

137+xmlHttpRequestSendPayload self (XhrPayload p) = ghcjs_dom_xml_http_request_send (unXMLHttpRequest (toXMLHttpRequest self)) p

127− (case payload of

128− Just p -> toJSString p

129− Nothing -> jsNull)

130

138

131

139

132foreign import javascript unsafe "$1[\"setRequestHeader\"]($2, $3)"

140foreign import javascript unsafe "$1[\"setRequestHeader\"]($2, $3)"

src/Foreign/JavaScript/TH.hs+6−6

@@ -204,7 +204,7 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where

204 peekCString ps

205 withJSBool b a = do

206 jsContext <- askJSContext

207− valRef <- liftIO $ jsvaluemakeboolean jsContext bRef

207+ valRef <- liftIO $ jsvaluemakeboolean jsContext b

208 a $ JSRef_JavaScriptCore valRef

209 withJSString str a = do

210 jsContext <- askJSContext

@@ -234,10 +234,10 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where

234 let len = round lenDouble

235 liftIO $ forM [0..len-1] $ \i -> do

236 liftM JSRef_JavaScriptCore $ jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions

237− fromJSUint8Array a = do

237+ fromJSUint8Array a = do

238− vals <- fromJSArray a

238+ vals <- fromJSArray a

239− doubles <- mapM fromJSNumber vals

239+ doubles <- mapM fromJSNumber vals

240− return $ BS.pack $ map round doubles

240+ return $ BS.pack $ map round doubles

241 fromJSNumber (JSRef_JavaScriptCore val) = do

242 jsContext <- askJSContext

243 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions

@@ -263,7 +263,7 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where

263 getJSProp propName (JSRef_JavaScriptCore objRef) = do

264 withJSStringRaw propName $ \propNameRaw -> do

265 jsContext <- askJSContext

266− liftIO $ jsobjectgetproperty jsContext objRef propNameRaw 0 nullPtr --TODO: property attribute, exceptions

266+ liftIO $ liftM JSRef_JavaScriptCore $ jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions

267 withJSNode (Node n) f = do

268 jsContext <- askJSContext

269 withForeignPtr n $ \nPtr -> do

src/Reflex/Dom/Widget/Basic.hs+2

@@ -589,6 +589,7 @@ type family EventResultType (en :: EventTag) :: * where

589 EventResultType 'MouseleaveTag = ()

590 EventResultType 'FocusTag = ()

591 EventResultType 'BlurTag = ()

592+ EventResultType 'ChangeTag = ()

592

593

593wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM (EventType en) e (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))

594wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM (EventType en) e (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))

594wrapDomEventsMaybe element handlers = do

595wrapDomEventsMaybe element handlers = do

@@ -630,6 +631,7 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of

630 Mouseleave -> return ()

631 Mouseleave -> return ()

631 Focus -> return ()

632 Focus -> return ()

632 Blur -> return ()

633 Blur -> return ()

634+ Change -> return ()

633

635

634wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)

636wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)

635wrapElement e = do

637wrapElement e = do

src/Reflex/Dom/Widget/Input.hs+36−5

@@ -14,6 +14,8 @@ import GHCJS.DOM.Element

14import GHCJS.DOM.HTMLSelectElement

15import GHCJS.DOM.EventM

16import GHCJS.DOM.UIEvent

17+import GHCJS.DOM.File

18+import GHCJS.DOM.FileList

17import Data.Monoid

19import Data.Monoid

18import Data.Map as Map

20import Data.Map as Map

19import Control.Lens

21import Control.Lens

@@ -35,11 +37,11 @@ data TextInput t

35 }

37 }

37data TextInputConfig t

39data TextInputConfig t

38− = TextInputConfig { _textInputConfig_inputType :: String

40+ = TextInputConfig { _textInputConfig_inputType :: String

39− , _textInputConfig_initialValue :: String

41+ , _textInputConfig_initialValue :: String

40− , _textInputConfig_setValue :: Event t String

42+ , _textInputConfig_setValue :: Event t String

41− , _textInputConfig_attributes :: Dynamic t (Map String String)

43+ , _textInputConfig_attributes :: Dynamic t (Map String String)

42− }

44+ }

44instance Reflex t => Default (TextInputConfig t) where

46instance Reflex t => Default (TextInputConfig t) where

45 def = TextInputConfig { _textInputConfig_inputType = "text"

47 def = TextInputConfig { _textInputConfig_inputType = "text"

@@ -150,6 +152,31 @@ checkboxView dAttrs dValue = do

150 performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ updated dValue

152 performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ updated dValue

151 return eClicked

153 return eClicked

152

154

155+data FileInput t

156+ = FileInput { _fileInput_value :: Dynamic t [File]

157+ , _fileInput_element :: HTMLInputElement

158+ }

159+

160+data FileInputConfig t

161+ = FileInputConfig { _fileInputConfig_clearValue :: Event t ()

162+ , _fileInputConfig_attributes :: Dynamic t (Map String String)

163+ }

164+

165+instance Reflex t => Default (FileInputConfig t) where

166+ def = FileInputConfig { _fileInputConfig_clearValue = never

167+ , _fileInputConfig_attributes = constDyn mempty

168+ }

169+

170+fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t)

171+fileInput (FileInputConfig clearValue dAttrs) = do

172+ e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "file") dAttrs

173+ eChange <- wrapDomEvent e elementOnchange $ liftIO $ do

174+ Just files <- htmlInputElementGetFiles e

175+ len <- fileListGetLength files

176+ mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . fileListItem files) $ init [0..len]

177+ dValue <- holdDyn [] eChange

178+ return $ FileInput dValue e

179+

153data Dropdown t k

180data Dropdown t k

154 = Dropdown { _dropdown_value :: Dynamic t k

181 = Dropdown { _dropdown_value :: Dynamic t k

155 , _dropdown_change :: Event t k

182 , _dropdown_change :: Event t k

@@ -250,6 +277,10 @@ instance HasValue (TextInput t) where

250 type Value (TextInput t) = Dynamic t String

277 type Value (TextInput t) = Dynamic t String

251 value = _textInput_value

278 value = _textInput_value

252

279

280+instance HasValue (FileInput t) where

281+ type Value (FileInput t) = Dynamic t [File]

282+ value = _fileInput_value

283+

253instance HasValue (Dropdown t k) where

284instance HasValue (Dropdown t k) where

254 type Value (Dropdown t k) = Dynamic t k

285 type Value (Dropdown t k) = Dynamic t k

255 value = _dropdown_value

286 value = _dropdown_value

src/Reflex/Dom/Xhr.hs+11−10

@@ -1,3 +1,4 @@

1+{-# LANGUAGE GADTs #-}

1module Reflex.Dom.Xhr

2module Reflex.Dom.Xhr

2 ( module Reflex.Dom.Xhr

3 ( module Reflex.Dom.Xhr

3 , XMLHttpRequest

4 , XMLHttpRequest

@@ -33,19 +34,19 @@ import Reflex.Dom.Class

33import Reflex.Dom.Xhr.Foreign

34import Reflex.Dom.Xhr.Foreign

34import Data.Typeable

35import Data.Typeable

36−data XhrRequest

37+data XhrRequest a

37 = XhrRequest { _xhrRequest_method :: String

38 = XhrRequest { _xhrRequest_method :: String

38 , _xhrRequest_url :: String

39 , _xhrRequest_url :: String

39− , _xhrRequest_config :: XhrRequestConfig

40+ , _xhrRequest_config :: XhrRequestConfig a

40 }

41 }

41 deriving (Show, Read, Eq, Ord, Typeable)

42 deriving (Show, Read, Eq, Ord, Typeable)

43−data XhrRequestConfig

44+data XhrRequestConfig a

44 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

45 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

45 , _xhrRequestConfig_user :: Maybe String

46 , _xhrRequestConfig_user :: Maybe String

46 , _xhrRequestConfig_password :: Maybe String

47 , _xhrRequestConfig_password :: Maybe String

47 , _xhrRequestConfig_responseType :: Maybe String

48 , _xhrRequestConfig_responseType :: Maybe String

48− , _xhrRequestConfig_sendData :: Maybe String

49+ , _xhrRequestConfig_sendData :: a

49 }

50 }

50 deriving (Show, Read, Eq, Ord, Typeable)

51 deriving (Show, Read, Eq, Ord, Typeable)

@@ -54,18 +55,18 @@ data XhrResponse

54 }

55 }

55 deriving (Show, Read, Eq, Ord, Typeable)

56 deriving (Show, Read, Eq, Ord, Typeable)

57−instance Default XhrRequestConfig where

58+instance a ~ () => Default (XhrRequestConfig a) where

58 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

59 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

59 , _xhrRequestConfig_user = Nothing

60 , _xhrRequestConfig_user = Nothing

60 , _xhrRequestConfig_password = Nothing

61 , _xhrRequestConfig_password = Nothing

61 , _xhrRequestConfig_responseType = Nothing

62 , _xhrRequestConfig_responseType = Nothing

62− , _xhrRequestConfig_sendData = Nothing

63+ , _xhrRequestConfig_sendData = ()

63 }

64 }

65−xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest

66+xhrRequest :: String -> String -> XhrRequestConfig a -> XhrRequest a

66xhrRequest = XhrRequest

67xhrRequest = XhrRequest

68−newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest

69+newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> h ()) -> m XMLHttpRequest

69newXMLHttpRequest req cb = do

70newXMLHttpRequest req cb = do

70 wv <- askWebView

71 wv <- askWebView

71 postGui <- askPostGui

72 postGui <- askPostGui

@@ -92,12 +93,12 @@ newXMLHttpRequest req cb = do

92 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

93 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

93 return xhr

94 return xhr

95−performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)

96+performRequestAsync :: (MonadWidget t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)

96performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do

97performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do

97 _ <- newXMLHttpRequest r $ liftIO . cb

98 _ <- newXMLHttpRequest r $ liftIO . cb

98 return ()

99 return ()

100

100−performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))

101+performRequestsAsync :: (Traversable f, MonadWidget t m, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))

101performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do

102performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do

102 resps <- forM rs $ \r -> do

103 resps <- forM rs $ \r -> do

103 resp <- liftIO newEmptyMVar

104 resp <- liftIO newEmptyMVar