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

git.iko.soy/reflex-dom

Add FileInput; fix a few other things

commit1ad28cbc19013d08fbab5b8f591080b05128dd56 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSun 16 Aug 2015, 18:34 (11 years ago) parentc6ee1e7

6 files changed+88−37

compare with develop

unifiedsplit

src-ghc/Reflex/Dom/Xhr/Foreign.hs+12−3 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+21−13 src/Foreign/JavaScript/TH.hs+6−6 src/Reflex/Dom/Widget/Basic.hs+2 src/Reflex/Dom/Widget/Input.hs+36−5 src/Reflex/Dom/Xhr.hs+11−10

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

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

1−{-# LANGUAGE ForeignFunctionInterface #-}

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

22module Reflex.Dom.Xhr.Foreign where

44import Control.Lens.Indexed

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

9696 peekCString ps

9797 return $ Just s

9898

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

100−xmlHttpRequestSend xhr payload = do

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+

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

109+xmlHttpRequestSendPayload xhr payload = do

101110 let c = xhrContext xhr

102111 (o,s) <- case payload of

103112 Nothing -> do

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

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

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

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

33module Reflex.Dom.Xhr.Foreign where

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

77import GHCJS.Marshal

88import qualified Data.Text as T

99import Data.Text (Text)

10−import Data.Word

1110import GHCJS.DOM.Types hiding (Text)

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

1311import GHCJS.DOM.EventM

1412import GHCJS.DOM

1513import Data.Function

14+import Control.Monad

1615

1716prepareWebView :: WebView -> IO ()

1817prepareWebView _ = return ()

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

116115

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

118117 ghcjs_dom_xml_http_request_send ::

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

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

120119

121−xmlHttpRequestSend ::

122− (IsXMLHttpRequest self, ToJSString payload) =>

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

124−xmlHttpRequestSend self payload

125− = ghcjs_dom_xml_http_request_send

126− (unXMLHttpRequest (toXMLHttpRequest self))

127− (case payload of

128− Just p -> toJSString p

129− Nothing -> jsNull)

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

121+

122+class IsXhrPayload a where

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

124+

125+instance IsXhrPayload () where

126+ xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr $ XhrPayload jsNull

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 ()

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

130138

131139

132140foreign 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

204204 peekCString ps

205205 withJSBool b a = do

206206 jsContext <- askJSContext

207− valRef <- liftIO $ jsvaluemakeboolean jsContext bRef

207+ valRef <- liftIO $ jsvaluemakeboolean jsContext b

208208 a $ JSRef_JavaScriptCore valRef

209209 withJSString str a = do

210210 jsContext <- askJSContext

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

234234 let len = round lenDouble

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

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

237− fromJSUint8Array a = do

238− vals <- fromJSArray a

239− doubles <- mapM fromJSNumber vals

240− return $ BS.pack $ map round doubles

237+ fromJSUint8Array a = do

238+ vals <- fromJSArray a

239+ doubles <- mapM fromJSNumber vals

240+ return $ BS.pack $ map round doubles

241241 fromJSNumber (JSRef_JavaScriptCore val) = do

242242 jsContext <- askJSContext

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

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

263263 getJSProp propName (JSRef_JavaScriptCore objRef) = do

264264 withJSStringRaw propName $ \propNameRaw -> do

265265 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

267267 withJSNode (Node n) f = do

268268 jsContext <- askJSContext

269269 withForeignPtr n $ \nPtr -> do

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

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

589589 EventResultType 'MouseleaveTag = ()

590590 EventResultType 'FocusTag = ()

591591 EventResultType 'BlurTag = ()

592+ EventResultType 'ChangeTag = ()

592593

593594wrapDomEventsMaybe :: (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))

594595wrapDomEventsMaybe element handlers = do

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

630631 Mouseleave -> return ()

631632 Focus -> return ()

632633 Blur -> return ()

634+ Change -> return ()

633635

634636wrapElement :: 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)

635637wrapElement e = do

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

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

1414import GHCJS.DOM.HTMLSelectElement

1515import GHCJS.DOM.EventM

1616import GHCJS.DOM.UIEvent

17+import GHCJS.DOM.File

18+import GHCJS.DOM.FileList

1719import Data.Monoid

1820import Data.Map as Map

1921import Control.Lens

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

3537 }

3638

3739data TextInputConfig t

38− = TextInputConfig { _textInputConfig_inputType :: String

39− , _textInputConfig_initialValue :: String

40− , _textInputConfig_setValue :: Event t String

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

42− }

40+ = TextInputConfig { _textInputConfig_inputType :: String

41+ , _textInputConfig_initialValue :: String

42+ , _textInputConfig_setValue :: Event t String

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

44+ }

4345

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

4547 def = TextInputConfig { _textInputConfig_inputType = "text"

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

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

151153 return eClicked

152154

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+

153180data Dropdown t k

154181 = Dropdown { _dropdown_value :: Dynamic t k

155182 , _dropdown_change :: Event t k

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

250277 type Value (TextInput t) = Dynamic t String

251278 value = _textInput_value

252279

280+instance HasValue (FileInput t) where

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

282+ value = _fileInput_value

283+

253284instance HasValue (Dropdown t k) where

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

255286 value = _dropdown_value

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

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

1+{-# LANGUAGE GADTs #-}

12module Reflex.Dom.Xhr

23 ( module Reflex.Dom.Xhr

34 , XMLHttpRequest

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

3334import Reflex.Dom.Xhr.Foreign

3435import Data.Typeable

3536

36−data XhrRequest

37+data XhrRequest a

3738 = XhrRequest { _xhrRequest_method :: String

3839 , _xhrRequest_url :: String

39− , _xhrRequest_config :: XhrRequestConfig

40+ , _xhrRequest_config :: XhrRequestConfig a

4041 }

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

4243

43−data XhrRequestConfig

44+data XhrRequestConfig a

4445 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

4546 , _xhrRequestConfig_user :: Maybe String

4647 , _xhrRequestConfig_password :: Maybe String

4748 , _xhrRequestConfig_responseType :: Maybe String

48− , _xhrRequestConfig_sendData :: Maybe String

49+ , _xhrRequestConfig_sendData :: a

4950 }

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

5152

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

5455 }

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

5657

57−instance Default XhrRequestConfig where

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

5859 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

5960 , _xhrRequestConfig_user = Nothing

6061 , _xhrRequestConfig_password = Nothing

6162 , _xhrRequestConfig_responseType = Nothing

62− , _xhrRequestConfig_sendData = Nothing

63+ , _xhrRequestConfig_sendData = ()

6364 }

6465

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

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

6667xhrRequest = XhrRequest

6768

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

6970newXMLHttpRequest req cb = do

7071 wv <- askWebView

7172 postGui <- askPostGui

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

9293 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

9394 return xhr

9495

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)

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

9798 _ <- newXMLHttpRequest r $ liftIO . cb

9899 return ()

99100

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))

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

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

103104 resp <- liftIO newEmptyMVar