a00ce01 · reflex-dom · git.iko.soy

src-ghc/Reflex/Dom/Internal/Foreign.hs+11−12

compare with develop

unifiedsplit

@@ -27,6 +27,7 @@ import System.Directory

27import System.Glib.FFI hiding (void)

28import qualified Data.ByteString as BS

29import Data.Monoid

30+import Data.Maybe

30import Data.Text (Text)

31import Data.Text (Text)

31import qualified Data.Text as T

32import qualified Data.Text as T

32

33

@@ -113,29 +114,27 @@ toJSObject ctx args = do

113fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Text)

114fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Text)

114fromJSStringMaybe c t = do

115fromJSStringMaybe c t = do

115 isNull <- jsvalueisnull c t

116 isNull <- jsvalueisnull c t

116− case isNull of

117− True -> return Nothing

117+ if isNull then return Nothing else do

118− False -> do

119− j <- jsvaluetostringcopy c t nullPtr

118+ j <- jsvaluetostringcopy c t nullPtr

120− l <- jsstringgetmaximumutf8cstringsize j

119+ l <- jsstringgetmaximumutf8cstringsize j

121− s <- allocaBytes (fromIntegral l) $ \ps -> do

120+ s <- allocaBytes (fromIntegral l) $ \ps -> do

122− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

121+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

123− peekCString ps

122+ peekCString ps

124− return $ Just $ T.pack s

123+ return $ Just $ T.pack s

125

124

126getLocationHost :: WebView -> IO Text

125getLocationHost :: WebView -> IO Text

127getLocationHost wv = withWebViewContext wv $ \c -> do

126getLocationHost wv = withWebViewContext wv $ \c -> do

128 script <- jsstringcreatewithutf8cstring "location.host"

127 script <- jsstringcreatewithutf8cstring "location.host"

129 lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

128 lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

130 lh' <- fromJSStringMaybe c lh

129 lh' <- fromJSStringMaybe c lh

131− return $ maybe "" id lh'

130+ return $ fromMaybe "" lh'

132

131

133getLocationProtocol :: WebView -> IO Text

132getLocationProtocol :: WebView -> IO Text

134getLocationProtocol wv = withWebViewContext wv $ \c -> do

133getLocationProtocol wv = withWebViewContext wv $ \c -> do

135 script <- jsstringcreatewithutf8cstring "location.protocol"

134 script <- jsstringcreatewithutf8cstring "location.protocol"

136 lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

135 lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

137 lp' <- fromJSStringMaybe c lp

136 lp' <- fromJSStringMaybe c lp

138− return $ maybe "" id lp'

137+ return $ fromMaybe "" lp'

139

138

140bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef

139bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef

141bsToArrayBuffer c bs = do

140bsToArrayBuffer c bs = do

@@ -159,7 +158,7 @@ bsFromArrayBuffer c a = do

159 i' <- jsvaluemakenumber c (fromIntegral i)

158 i' <- jsvaluemakenumber c (fromIntegral i)

160 args <- toJSObject c [uint8Array, i']

159 args <- toJSObject c [uint8Array, i']

161 getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr

160 getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr

162− fmap BS.pack $ forM [0..byteLength-1] arrayLookup

161+ BS.pack <$> forM [0..byteLength-1] arrayLookup

163

162

164withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a

163withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a

165withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv

164withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+1−1

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

1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}

1+{-# LANGUAGE JavaScriptFFI, CPP, NoMonomorphismRestriction, RankNTypes, GADTs, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}

2

3module Reflex.Dom.WebSocket.Foreign where

4

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

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

1−{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, QuasiQuotes, ForeignFunctionInterface, OverloadedStrings #-}

1+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, QuasiQuotes, OverloadedStrings #-}

2module Reflex.Dom.Xhr.Foreign ( module Reflex.Dom.Xhr.Foreign

3 , XhrResponseType

4 ) where

@@ -111,14 +111,12 @@ xmlHttpRequestGetResponse xhr = do

111 script <- jsstringcreatewithutf8cstring "this.response"

112 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

113 isNull <- jsvalueisnull c t

114− case isNull of

115− True -> return Nothing

114+ if isNull then return Nothing else case mrt of

116− False -> case mrt of

117− Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t

115+ Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t

118− Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t

116+ Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t

119− Just XhrResponseType_Default -> fmap (XhrResponseBody_Default) <$> fromJSStringMaybe c t

117+ Just XhrResponseType_Default -> fmap XhrResponseBody_Default <$> fromJSStringMaybe c t

120− Just XhrResponseType_Text -> fmap (XhrResponseBody_Text) <$> fromJSStringMaybe c t

118+ Just XhrResponseType_Text -> fmap XhrResponseBody_Text <$> fromJSStringMaybe c t

121− _ -> return Nothing

119+ _ -> return Nothing

122

120

123xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)

121xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)

124xmlHttpRequestGetResponseText xhr = do

122xmlHttpRequestGetResponseText xhr = do

@@ -138,17 +136,11 @@ xmlHttpRequestSendPayload xhr payload = do

138 onError <- jsobjectmakefunctionwithcallback c nullPtr e

136 onError <- jsobjectmakefunctionwithcallback c nullPtr e

139 bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do

137 bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do

140 onLoad <- jsobjectmakefunctionwithcallback c nullPtr l

138 onLoad <- jsobjectmakefunctionwithcallback c nullPtr l

141− (o,s) <- case payload of

139+ d <- case payload of

142− Nothing -> do

143− d <- jsvaluemakeundefined c

140+ Nothing -> jsvaluemakeundefined c

144− o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]

145− s <- jsstringcreatewithutf8cstring send

146− return (o,s)

147− Just payload' -> do

148− d <- stringToJSValue c payload'

141+ Just payload' -> stringToJSValue c payload'

149− o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]

142+ o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]

150− s <- jsstringcreatewithutf8cstring send

143+ s <- jsstringcreatewithutf8cstring send

151− return (o,s)

152 _ <- jsevaluatescript c s o nullPtr 1 nullPtr

144 _ <- jsevaluatescript c s o nullPtr 1 nullPtr

153 takeMVar result >>= mapM_ throwIO

145 takeMVar result >>= mapM_ throwIO

154 where

146 where

src-ghcjs/Reflex/Dom/Internal/Foreign.hs+3−4

@@ -3,7 +3,6 @@ module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign

3 , runWebGUI

4 ) where

5

6−import Control.Monad

7import Data.ByteString (ByteString)

6import Data.ByteString (ByteString)

8import Foreign

7import Foreign

9import Foreign.C

8import Foreign.C

@@ -21,12 +20,12 @@ quitWebView = error "quitWebView: unimplemented in GHCJS"

21foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString

20foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString

22

21

23getLocationHost :: FromJSString r => a -> IO r

22getLocationHost :: FromJSString r => a -> IO r

24−getLocationHost _ = liftM fromJSString getLocationHost_

23+getLocationHost _ = fmap fromJSString getLocationHost_

25

24

26foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString

25foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString

27

26

28getLocationProtocol :: FromJSString r => a -> IO r

27getLocationProtocol :: FromJSString r => a -> IO r

29−getLocationProtocol _ = liftM fromJSString getLocationProtocol_

28+getLocationProtocol _ = fmap fromJSString getLocationProtocol_

30

29

31withWebViewContext :: a -> (a -> IO b) -> IO b

30withWebViewContext :: a -> (a -> IO b) -> IO b

32withWebViewContext a f = f a

31withWebViewContext a f = f a

@@ -40,4 +39,4 @@ bsToArrayBuffer _ bs = BS.useAsCString bs $ \cStr -> do

40 extractByteArray cStr $ BS.length bs

39 extractByteArray cStr $ BS.length bs

41

40

42bsFromArrayBuffer :: a -> JSVal -> IO ByteString

41bsFromArrayBuffer :: a -> JSVal -> IO ByteString

43−bsFromArrayBuffer _ ab = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JS.unsafeFreeze $ JS.pFromJSVal ab

42+bsFromArrayBuffer _ ab = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JS.unsafeFreeze $ JS.pFromJSVal ab

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

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

1−{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings #-}

1+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, JavaScriptFFI, OverloadedStrings #-}

2

3module Reflex.Dom.Xhr.Foreign (

4 XMLHttpRequest

@@ -163,11 +163,11 @@ xmlHttpRequestGetResponse xhr = do

163 mr <- getResponse xhr

164 rt <- xmlHttpRequestGetResponseType xhr

165 case rt of

166− Just XhrResponseType_Blob -> return $ fmap (XhrResponseBody_Blob . castToBlob) mr

166+ Just XhrResponseType_Blob -> return $ XhrResponseBody_Blob . castToBlob <$> mr

167− Just XhrResponseType_Text -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr

167+ Just XhrResponseType_Text -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr

168− Just XhrResponseType_Default -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr

168+ Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr

169− Just XhrResponseType_ArrayBuffer -> case (fmap unGObject mr) of

169+ Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of

170 Nothing -> return Nothing

171− Just ptr -> fmap (Just . XhrResponseBody_ArrayBuffer) $ bsFromArrayBuffer ptr ptr

171+ Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer ptr ptr

172 _ -> return Nothing

173

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

@@ -213,15 +213,15 @@ instance IsJSContext JSCtx_IO where

213 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }

214

215instance MonadJS JSCtx_IO IO where

216− runJS (JSFFI f) l = liftM JSRef_IO . f =<< JS.fromListIO (coerce l)

216+ runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)

217 forkJS = forkIO

218 mkJSUndefined = return $ JSRef_IO JS.jsUndefined

219 isJSNull (JSRef_IO r) = return $ JS.isNull r

220 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r

221 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r

222 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r

223− fromJSArray (JSRef_IO r) = liftM coerce $ JS.toListIO $ coerce r

223+ fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r

224− fromJSUint8Array (JSRef_IO r) = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable

224+ fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable

225 fromJSNumber (JSRef_IO r) = do

226 Just n <- JS.fromJSVal r

227 return n

@@ -241,7 +241,7 @@ instance MonadJS JSCtx_IO IO where

241 l <- JS.toListIO $ coerce args

242 JSRef_IO result <- f $ coerce l

243 return result

244− liftM (JSFun . JSRef_IO) $ funWithArguments $ coerce cb

244+ fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb

245 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r

246 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o

247 getJSProp s (JSRef_IO o) = do

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

294 liftIO $ forkIO $ runWithWebView a wv

295 mkJSUndefined = do

296 jsContext <- askJSContext

297− liftM JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext

297+ fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext

298 isJSNull (JSRef_JavaScriptCore r) = do

299 jsContext <- askJSContext

300 liftIO $ jsvalueisnull jsContext r

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

343 lenDouble <- fromJSNumberRaw lenRef

344 let len = round lenDouble

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

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

346+ JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions

347 fromJSUint8Array a = do

348 vals <- fromJSArray a

349 doubles <- mapM fromJSNumber vals

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

359 x <- peekElemOff argv n

360 jsvalueprotect jsContext x

361 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually

362− liftM unJSRef_JavaScriptCore $ runWithWebView (a args) wv

362+ unJSRef_JavaScriptCore <$> runWithWebView (a args) wv

363 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb

364 liftIO $ jsvalueprotect jsContext cbRef

365 return $ JSFun $ JSRef_JavaScriptCore cbRef

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

373 getJSProp propName (JSRef_JavaScriptCore objRef) = do

374 withJSStringRaw propName $ \propNameRaw -> do

375 jsContext <- askJSContext

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

376+ liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions

377 withJSNode = error "withJSNode is only supported in ghcjs"

378

379#endif

@@ -399,7 +399,7 @@ instance FromJS x Text where

399instance FromJS x a => FromJS x (Maybe a) where

400 fromJS x = do

401 n <- isJSNull x

402− if n then return Nothing else liftM Just $ fromJS x

402+ if n then return Nothing else Just <$> fromJS x

403

404class ToJS x a where

405 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r

@@ -422,7 +422,7 @@ instance ToJS x a => ToJS x (JSArray a) where

422 withJS = withJSArrayFromList . unJSArray

423

424instance FromJS x a => FromJS x (JSArray a) where

425− fromJS = liftM JSArray . mapM fromJS <=< fromJSArray

425+ fromJS = fmap JSArray . mapM fromJS <=< fromJSArray

426

427withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r

428withJSArrayFromList as f = go as []

@@ -444,7 +444,7 @@ instance ToJS x Int where

444 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions

445

446instance FromJS x Int where

447− fromJS = liftM round . fromJSNumber --TODO: Check things; throw exceptions

447+ fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions

448

449instance ToJS x Double where

450 withJS = withJSNumber

src/Reflex/Dom.hs+16−31

@@ -1,32 +1,17 @@

1−module Reflex.Dom ( module Reflex

1+module Reflex.Dom (module X) where

2− , module Reflex.Dom.Builder.Class

3− , module Reflex.Dom.Builder.Immediate

4− , module Reflex.Dom.Builder.Static

5− , module Reflex.Dom.Class

6− , module Reflex.Dom.DynamicWriter

7− , module Reflex.Dom.Internal

8− , module Reflex.Dom.Location

9− , module Reflex.Dom.Old

10− , module Reflex.Dom.PerformEvent.Class

11− , module Reflex.Dom.PostBuild.Class

12− , module Reflex.Dom.Time

13− , module Reflex.Dom.WebSocket

14− , module Reflex.Dom.Widget

15− , module Reflex.Dom.Xhr

16− ) where

17

2

18−import Reflex

3+import Reflex as X

19−import Reflex.Dom.Builder.Class

4+import Reflex.Dom.Builder.Class as X

20−import Reflex.Dom.Builder.Immediate

5+import Reflex.Dom.Builder.Immediate as X

21−import Reflex.Dom.Builder.Static

6+import Reflex.Dom.Builder.Static as X

22−import Reflex.Dom.Class

7+import Reflex.Dom.Class as X

23−import Reflex.Dom.DynamicWriter

8+import Reflex.Dom.DynamicWriter as X

24−import Reflex.Dom.Internal

9+import Reflex.Dom.Internal as X

25−import Reflex.Dom.Location

10+import Reflex.Dom.Location as X

26−import Reflex.Dom.Old

11+import Reflex.Dom.Old as X

27−import Reflex.Dom.PerformEvent.Class

12+import Reflex.Dom.PerformEvent.Class as X

28−import Reflex.Dom.PostBuild.Class

13+import Reflex.Dom.PostBuild.Class as X

29−import Reflex.Dom.Time

14+import Reflex.Dom.Time as X

30−import Reflex.Dom.WebSocket

15+import Reflex.Dom.WebSocket as X

31−import Reflex.Dom.Widget

16+import Reflex.Dom.Widget as X

32−import Reflex.Dom.Xhr

17+import Reflex.Dom.Xhr as X

src/Reflex/Dom/Builder/Class.hs+4−4

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

1−{-# LANGUAGE OverloadedStrings, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, DeriveFunctor, FlexibleInstances, DataKinds, LambdaCase, PolyKinds, RankNTypes, ScopedTypeVariables, PolyKinds, FlexibleContexts, UndecidableInstances, ConstraintKinds, DefaultSignatures #-}

1+{-# LANGUAGE OverloadedStrings, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, DeriveFunctor, FlexibleInstances, DataKinds, LambdaCase, PolyKinds, RankNTypes, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, ConstraintKinds, DefaultSignatures #-}

2module Reflex.Dom.Builder.Class

3 ( module Reflex.Dom.Builder.Class

4 , module Reflex.Dom.Builder.Class.Events

@@ -244,7 +244,7 @@ instance Functor1 (ElementConfig er t) where

244instance Reflex t => Functor1 (PlaceholderConfig above t) where

245 {-# INLINABLE fmap1 #-}

246 fmap1 f cfg = cfg

247− { _placeholderConfig_insertAbove = fmap f $ _placeholderConfig_insertAbove cfg

247+ { _placeholderConfig_insertAbove = f <$> _placeholderConfig_insertAbove cfg

248 }

249

250instance Functor1 (InputElementConfig er t) where

@@ -262,7 +262,7 @@ class HasDomEvent t target eventName where

262instance Reflex t => HasDomEvent t (Element EventResult d t) en where

263 type DomEventType (Element EventResult d t) en = EventResultType en

264 {-# INLINABLE domEvent #-}

265− domEvent en e = fmap unEventResult $ Reflex.select (_element_events e) (WrapArg en)

265+ domEvent en e = unEventResult <$> Reflex.select (_element_events e) (WrapArg en)

266

267instance Reflex t => HasDomEvent t (InputElement EventResult d t) en where

268 type DomEventType (InputElement EventResult d t) en = EventResultType en

@@ -307,7 +307,7 @@ instance MonadTransControlStateless (ReaderT r)

307type RunStateless t = forall n b. Monad n => t n b -> n b

308

309liftWithStateless :: forall m t a. (Monad m, MonadTransControlStateless t) => (RunStateless t -> m a) -> t m a

310−liftWithStateless a = liftWith $ \run -> a $ \x -> liftM (fromStT (Proxy :: Proxy t)) $ run x

310+liftWithStateless a = liftWith $ \run -> a $ \x -> fromStT (Proxy :: Proxy t) <$> run x

311

312liftTextNode :: (MonadTrans f, DomBuilder t m) => TextNodeConfig t -> f m (TextNode t)

313liftTextNode = lift . textNode

src/Reflex/Dom/Builder/Immediate.hs+9−13

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

1−{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, UndecidableInstances, FunctionalDependencies, DataKinds, TypeFamilies, RankNTypes, ConstraintKinds, TypeOperators, FlexibleContexts, LambdaCase, ScopedTypeVariables, PolyKinds, EmptyDataDecls #-}

1+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, UndecidableInstances, DataKinds, TypeFamilies, RankNTypes, ConstraintKinds, TypeOperators, FlexibleContexts, LambdaCase, ScopedTypeVariables, PolyKinds, EmptyDataDecls #-}

2module Reflex.Dom.Builder.Immediate where

3

4import Reflex

@@ -62,7 +62,7 @@ instance MonadTrans (ImmediateDomBuilderT t) where

62

63{-# INLINABLE runImmediateDomBuilderT #-}

64runImmediateDomBuilderT :: ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t -> m a

65−runImmediateDomBuilderT (ImmediateDomBuilderT a) env = runReaderT a env

65+runImmediateDomBuilderT (ImmediateDomBuilderT a) = runReaderT a

66

67{-# INLINABLE askDocument #-}

68askDocument :: Monad m => ImmediateDomBuilderT t m Document

@@ -206,8 +206,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

206 let domInputElement = castToHTMLInputElement domElement

207 Just v0 <- Input.getValue domInputElement

208 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement

209− valueChangedByUI <- performEvent $ ffor (Reflex.select (_element_events e) (WrapArg Input)) $ \_ ->

209+ valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

210− getMyValue

211 valueChangedBySetValue <- performEvent $ ffor (cfg ^. inputElementConfig_setValue) $ \v' -> do

210 valueChangedBySetValue <- performEvent $ ffor (cfg ^. inputElementConfig_setValue) $ \v' -> do

212 Input.setValue domInputElement $ Just v'

211 Input.setValue domInputElement $ Just v'

213 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

212 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

@@ -240,8 +239,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

240 let domTextAreaElement = castToHTMLTextAreaElement domElement

239 let domTextAreaElement = castToHTMLTextAreaElement domElement

241 Just v0 <- TextArea.getValue domTextAreaElement

240 Just v0 <- TextArea.getValue domTextAreaElement

242 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement

241 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement

243− valueChangedByUI <- performEvent $ ffor (Reflex.select (_element_events e) (WrapArg Input)) $ \_ ->

242+ valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

244− getMyValue

245 valueChangedBySetValue <- performEvent $ ffor (cfg ^. textAreaElementConfig_setValue) $ \v' -> do

243 valueChangedBySetValue <- performEvent $ ffor (cfg ^. textAreaElementConfig_setValue) $ \v' -> do

246 TextArea.setValue domTextAreaElement $ Just v'

244 TextArea.setValue domTextAreaElement $ Just v'

247 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

245 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

@@ -314,10 +312,9 @@ instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) =>

314 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

312 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

315 newEventWithLazyTriggerWithOnComplete f = do

313 newEventWithLazyTriggerWithOnComplete f = do

316 events <- askEvents

314 events <- askEvents

317− eResult <- lift $ newEventWithTrigger $ \t -> f $ \a cb -> do

315+ lift $ newEventWithTrigger $ \t -> f $ \a cb -> do

318 reResultTrigger <- newIORef $ Just t

316 reResultTrigger <- newIORef $ Just t

319 writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]

317 writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]

320− return eResult

321

318

322instance HasWebView m => HasWebView (ImmediateDomBuilderT t m) where

319instance HasWebView m => HasWebView (ImmediateDomBuilderT t m) where

323 type WebViewPhantom (ImmediateDomBuilderT t m) = WebViewPhantom m

320 type WebViewPhantom (ImmediateDomBuilderT t m) = WebViewPhantom m

@@ -392,7 +389,7 @@ type family EventType en where

392

389

393{-# INLINABLE defaultDomEventHandler #-}

390{-# INLINABLE defaultDomEventHandler #-}

394defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))

391defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))

395−defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of

392+defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of

396 Click -> return ()

393 Click -> return ()

397 Dblclick -> return ()

394 Dblclick -> return ()

398 Keypress -> getKeyEvent

395 Keypress -> getKeyEvent

@@ -444,7 +441,7 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of

444

441

445{-# INLINABLE defaultDomWindowEventHandler #-}

442{-# INLINABLE defaultDomWindowEventHandler #-}

446defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))

443defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))

447−defaultDomWindowEventHandler w evt = liftM (Just . EventResult) $ case evt of

444+defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of

448 Click -> return ()

445 Click -> return ()

449 Dblclick -> return ()

446 Dblclick -> return ()

450 Keypress -> getKeyEvent

447 Keypress -> getKeyEvent

@@ -652,7 +649,7 @@ windowOnEventName en e = case en of

652

649

653{-# INLINABLE wrapDomEvent #-}

650{-# INLINABLE wrapDomEvent #-}

654wrapDomEvent :: (MonadIO m, TriggerEvent t m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event a -> m (Event t a)

651wrapDomEvent :: (MonadIO m, TriggerEvent t m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event a -> m (Event t a)

655−wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ liftM Just getValue

652+wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue

656

653

657{-# INLINABLE subscribeDomEvent #-}

654{-# INLINABLE subscribeDomEvent #-}

658subscribeDomEvent :: (EventM e event () -> IO (IO ()))

655subscribeDomEvent :: (EventM e event () -> IO (IO ()))

@@ -674,10 +671,9 @@ wrapDomEventMaybe :: (MonadIO m, TriggerEvent t m)

674 -> EventM e event (Maybe a)

671 -> EventM e event (Maybe a)

675 -> m (Event t a)

672 -> m (Event t a)

676wrapDomEventMaybe el elementOnevent getValue = do

673wrapDomEventMaybe el elementOnevent getValue = do

677− e <- newEventWithLazyTriggerWithOnComplete $ \trigger -> elementOnevent el $ do

674+ newEventWithLazyTriggerWithOnComplete $ \trigger -> elementOnevent el $ do

678 mv <- getValue

675 mv <- getValue

679 forM_ mv $ \v -> liftIO $ trigger v $ return ()

676 forM_ mv $ \v -> liftIO $ trigger v $ return ()

680− return e

681

677

682{-# INLINABLE wrapDomEventsMaybe #-}

678{-# INLINABLE wrapDomEventsMaybe #-}

683wrapDomEventsMaybe :: (MonadIO m, MonadReflexCreateTrigger t m)

679wrapDomEventsMaybe :: (MonadIO m, MonadReflexCreateTrigger t m)

src/Reflex/Dom/Builder/Static.hs+6−9

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

1−{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, UndecidableInstances, FunctionalDependencies, DataKinds, TypeFamilies, RankNTypes, ConstraintKinds, TypeOperators, FlexibleContexts, LambdaCase, ScopedTypeVariables, PolyKinds, EmptyDataDecls #-}

1+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, UndecidableInstances, DataKinds, TypeFamilies, RankNTypes, ConstraintKinds, TypeOperators, FlexibleContexts, LambdaCase, ScopedTypeVariables, PolyKinds, EmptyDataDecls #-}

2module Reflex.Dom.Builder.Static where

3

4import Reflex

@@ -13,12 +13,9 @@ import Control.Monad.Identity

13import Data.Dependent.Sum (DSum (..))

14

15import Data.Monoid

16−import Data.Text (Text)

17import qualified Data.Map as Map

16import qualified Data.Map as Map

18−import Data.Map (Map)

19import Control.Lens hiding (element)

17import Control.Lens hiding (element)

20import qualified Data.ByteString.Lazy as BL

18import qualified Data.ByteString.Lazy as BL

21−import qualified Data.ByteString.Char8 as B8

22import Data.ByteString (ByteString)

19import Data.ByteString (ByteString)

23import Control.Monad.State.Strict

20import Control.Monad.State.Strict

24import Control.Monad.Trans.Control

21import Control.Monad.Trans.Control

@@ -104,15 +101,15 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

104

101

105 {-# INLINABLE element #-}

102 {-# INLINABLE element #-}

106 element elementTag cfg child = do

103 element elementTag cfg child = do

107− let toAttr (_mns, k) v = encodeUtf8 k <> "=\"" <> (BL.toStrict $ toLazyByteString $ fromHtmlEscapedText v) <> "\""

104+ let toAttr (_mns, k) v = encodeUtf8 k <> "=\"" <> BL.toStrict (toLazyByteString $ fromHtmlEscapedText v) <> "\""

108 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

105 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

109 StaticDomBuilderT $ do

106 StaticDomBuilderT $ do

110 (result, innerHtml) <- lift $ runStaticDomBuilderT child

107 (result, innerHtml) <- lift $ runStaticDomBuilderT child

111 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

108 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

112 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList

109 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList

113− let tag = encodeUtf8 elementTag

110+ let tagBS = encodeUtf8 elementTag

114− let open = mconcat [constant ("<" <> tag <> " "), attrs1, constant ">"]

111+ let open = mconcat [constant ("<" <> tagBS <> " "), attrs1, constant ">"]

115− let close = constant $ "</" <> tag <> ">" -- TODO handle elements without closing tags

112+ let close = constant $ "</" <> tagBS <> ">" -- TODO handle elements without closing tags

116 modify $ (:) $ mconcat $ [open, innerHtml, close]

113 modify $ (:) $ mconcat $ [open, innerHtml, close]

117 return (Element es (error "Static.element RawElement was used"), result)

114 return (Element es (error "Static.element RawElement was used"), result)

118

115

@@ -120,7 +117,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

120 placeholder (PlaceholderConfig toInsertAbove _delete) = StaticDomBuilderT $ do

117 placeholder (PlaceholderConfig toInsertAbove _delete) = StaticDomBuilderT $ do

121 result <- lift $ performEvent (fmap runStaticDomBuilderT toInsertAbove)

118 result <- lift $ performEvent (fmap runStaticDomBuilderT toInsertAbove)

122 acc <- foldDyn (:) [] (fmap snd result)

119 acc <- foldDyn (:) [] (fmap snd result)

123− modify $ (:) $ join $ fmap (mconcat . reverse) $ current acc

120+ modify $ (:) $ join $ mconcat . reverse <$> current acc

124 return $ Placeholder (fmap fst result) never

121 return $ Placeholder (fmap fst result) never

125

122

126 {-# INLINABLE inputElement #-}

123 {-# INLINABLE inputElement #-}

src/Reflex/Dom/Class.hs+1

@@ -16,6 +16,7 @@ import qualified Data.Map as Map

16-- | Alias for Data.Map.singleton

17(=:) :: k -> a -> Map k a

18(=:) = Map.singleton

19+infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6

19

20

20keycodeEnter :: Int

21keycodeEnter :: Int

21keycodeEnter = 13

22keycodeEnter = 13

src/Reflex/Dom/DynamicWriter.hs+4−4

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

1−{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, RecursiveDo, ScopedTypeVariables, LambdaCase, GADTs #-}

1+{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances, FunctionalDependencies, RecursiveDo, ScopedTypeVariables, LambdaCase, GADTs #-}

2module Reflex.Dom.DynamicWriter where

3

4import Reflex

@@ -66,7 +66,7 @@ mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map

66mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f

67

68unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'

69−unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ fmap g $ updatedIncremental a

69+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a

70

71incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)

72incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m

@@ -174,7 +174,7 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (

174 return (el, a)

175 placeholder cfg = do

176 let cfg' = cfg

177− { _placeholderConfig_insertAbove = fmap runDynamicWriterTInternal $ _placeholderConfig_insertAbove cfg

177+ { _placeholderConfig_insertAbove = runDynamicWriterTInternal <$> _placeholderConfig_insertAbove cfg

178 }

179 let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order

180 -> Event t () -- ^ No more nodes will be added after this event fires

@@ -193,7 +193,7 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (

193 p <- DynamicWriterT $ do

194 modify (children:)

195 lift $ placeholder cfg'

196− let result = fmap fst $ _placeholder_insertedAbove p

196+ let result = fst <$> _placeholder_insertedAbove p

197 childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p

198 return $ p

199 { _placeholder_insertedAbove = result

src/Reflex/Dom/Internal.hs+9−10

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

1−{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, ConstraintKinds, CPP #-}

1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, RecursiveDo, UndecidableInstances, NoMonomorphismRestriction, TypeOperators, LambdaCase, ConstraintKinds, CPP #-}

2module Reflex.Dom.Internal where

3

4import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)

@@ -17,7 +17,6 @@ import GHCJS.DOM.Node

17import GHCJS.DOM.Element

18import GHCJS.DOM.Document

19import Control.Lens

20−import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

21import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

20import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

22import Control.Monad.Ref

21import Control.Monad.Ref

23import Control.Concurrent

22import Control.Concurrent

@@ -34,7 +33,7 @@ import Data.Maybe

34{-# INLINABLE mainWidget #-}

33{-# INLINABLE mainWidget #-}

35mainWidget :: (forall x. Widget x ()) -> IO ()

34mainWidget :: (forall x. Widget x ()) -> IO ()

36mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

35mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

37− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView

36+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

38 Just body <- getBody doc

37 Just body <- getBody doc

39 attachWidget body webViewSing w

38 attachWidget body webViewSing w

40

39

@@ -42,8 +41,8 @@ mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSi

42{-# INLINABLE mainWidgetWithHead #-}

41{-# INLINABLE mainWidgetWithHead #-}

43mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()

42mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()

44mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

43mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

45− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView

44+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

46− Just headElement <- liftM (fmap DOM.castToHTMLElement) $ getHead doc

45+ Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc

47 attachWidget headElement webViewSing h

46 attachWidget headElement webViewSing h

48 Just body <- getBody doc

47 Just body <- getBody doc

49 attachWidget body webViewSing b

48 attachWidget body webViewSing b

@@ -51,8 +50,8 @@ mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $

51{-# INLINABLE mainWidgetWithCss #-}

50{-# INLINABLE mainWidgetWithCss #-}

52mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()

51mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()

53mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

52mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

54− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView

53+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

55− Just headElement <- liftM (fmap DOM.castToHTMLElement) $ getHead doc

54+ Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc

56 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

55 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

57 Just body <- getBody doc

56 Just body <- getBody doc

58 attachWidget body webViewSing w

57 attachWidget body webViewSing w

@@ -60,7 +59,7 @@ mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $

60{-# INLINABLE mainWidgetFragment #-}

59{-# INLINABLE mainWidgetFragment #-}

61mainWidgetFragment :: (forall x. Widget x ()) -> IO ()

60mainWidgetFragment :: (forall x. Widget x ()) -> IO ()

62mainWidgetFragment w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

61mainWidgetFragment w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

63− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView

62+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

64 Just body <- getBody doc

63 Just body <- getBody doc

65 attachWidgetFragment body webViewSing w

64 attachWidgetFragment body webViewSing w

66

65

@@ -129,7 +128,7 @@ attachWidgetFragment' rootElement wv w = do

129 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

128 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

130 return ()

129 return ()

131 setInnerHTML rootElement $ Just (""::String)

130 setInnerHTML rootElement $ Just (""::String)

132− appendChild rootElement $ Just df

131+ _ <- appendChild rootElement $ Just df

133 return (result, fc)

132 return (result, fc)

134

133

135data AppInput t = AppInput

134data AppInput t = AppInput

@@ -142,7 +141,7 @@ data AppOutput t = AppOutput --TODO: Add quit event

142

141

143runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()

142runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()

144runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

143runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

145− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView

144+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

146 Just body <- getBody doc

145 Just body <- getBody doc

147 Just win <- getDefaultView doc

146 Just win <- getDefaultView doc

148 rec o <- attachWidget body webViewSing $ do

147 rec o <- attachWidget body webViewSing $ do

src/Reflex/Dom/PerformEvent/Base.hs+4−4

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

1−{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies, TypeOperators, RankNTypes, ScopedTypeVariables, StandaloneDeriving, FlexibleContexts, RecursiveDo, UndecidableInstances #-}

1+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies, TypeOperators, RankNTypes, ScopedTypeVariables, StandaloneDeriving, FlexibleContexts, RecursiveDo, UndecidableInstances #-}

2module Reflex.Dom.PerformEvent.Base where

3

4import Reflex

@@ -25,7 +25,7 @@ import Control.Lens

25

26newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }

27

28−newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> (ReadPhase m a) -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?

28+newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?

29

30newtype PerformEventT t m a = PerformEventT { unPerformEventT :: StateT [Event t (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())] (HostFrame t) a }

31

@@ -55,7 +55,7 @@ instance (ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t

55 return [EventTriggerRef reResultTrigger :=> Identity result]

56 return eResult

57

58−instance (ReflexHost t, Monad (HostFrame t), MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => Deletable t (PerformEventT t m) where

58+instance (ReflexHost t, Monad (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => Deletable t (PerformEventT t m) where

59 {-# INLINABLE deletable #-}

60 deletable d a = PerformEventT $ do

61 (result, reverseEventsToPerform) <- lift $ runStateT (unPerformEventT a) []

@@ -133,7 +133,7 @@ hostPerformEventT a = do

133 followupEventTriggerRefs <- runHostFrame toPerform

134 followupEventTriggers <- forM followupEventTriggerRefs $ \(EventTriggerRef rt :=> x) -> do

135 mt <- readRef rt

136− return $ fmap (\t -> t :=> x) mt

136+ return $ fmap (:=> x) mt

137 fmap (result':) $ go $ catMaybes followupEventTriggers

138 go triggers

139

src/Reflex/Dom/PerformEvent/Class.hs+1−1

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

1−{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies, TypeOperators, RankNTypes, ScopedTypeVariables, StandaloneDeriving, FlexibleContexts, UndecidableInstances #-}

1+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeFamilies, TypeOperators, RankNTypes, ScopedTypeVariables, FlexibleContexts, UndecidableInstances #-}

2module Reflex.Dom.PerformEvent.Class where

3

4import Reflex

src/Reflex/Dom/PostBuild/Class.hs+2−2

@@ -50,7 +50,7 @@ instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBui

50 placeholder cfg = lift $ do

51 rec childPostBuild <- deletable (_placeholder_deletedSelf p) $ performEvent $ return () <$ _placeholder_insertedAbove p

52 p <- placeholder $ cfg

53− { _placeholderConfig_insertAbove = fmap (\a -> runPostBuildT a =<< headE childPostBuild) $ _placeholderConfig_insertAbove cfg

53+ { _placeholderConfig_insertAbove = ffor (_placeholderConfig_insertAbove cfg) $ \a -> runPostBuildT a =<< headE childPostBuild

54 }

55 return p

56 {-# INLINABLE inputElement #-}

@@ -113,7 +113,7 @@ instance HasWebView m => HasWebView (PostBuildT t m) where

113

114{-# INLINABLE runPostBuildT #-}

115runPostBuildT :: PostBuildT t m a -> Event t () -> m a

116−runPostBuildT (PostBuildT a) postBuild = runReaderT a postBuild

116+runPostBuildT (PostBuildT a) = runReaderT a

117

118instance PostBuild t m => PostBuild t (ReaderT r m) where

119 getPostBuild = lift getPostBuild

src/Reflex/Dom/Time.hs+3−4

@@ -42,7 +42,7 @@ tickLossyFrom

42 -- there could be uses for starting multiple timer threads.

43 -> m (Event t TickInfo)

44tickLossyFrom dt t0 e = do

45− rec result <- performEventAsync $ fmap callAtNextInterval $ leftmost [() <$ e, () <$ result]

45+ rec result <- performEventAsync $ callAtNextInterval <$> leftmost [() <$ e, () <$ result]

46 return result

47 where callAtNextInterval _ cb = void $ liftIO $ forkIO $ do

48 tick <- getCurrentTick dt t0

@@ -84,8 +84,7 @@ poissonLossyFrom

84 -- there could be uses for starting multiple timer threads.

85 -- Start sending events in response to the event parameter.

86 -> m (Event t TickInfo)

87−poissonLossyFrom rnd rate t0 t =

88− inhomogeneousPoissonFrom rnd (current $ constDyn rate) rate t0 t

87+poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate

89

88

90

89

91-- | Send events with Poisson timing with the given basis and rate

90-- | Send events with Poisson timing with the given basis and rate

@@ -148,7 +147,7 @@ inhomogeneousPoissonFrom rnd rate maxRate t0 e = do

148

147

149 -- Inter-event interval is drawn from exponential

148 -- Inter-event interval is drawn from exponential

150 -- distribution accourding to u

149 -- distribution accourding to u

151− let dt = realToFrac $ -1 * log(u)/maxRate :: NominalDiffTime

150+ let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime

152 nEvents = lastN + 1

151 nEvents = lastN + 1

153 alreadyElapsed = diffUTCTime t tTargetLast

152 alreadyElapsed = diffUTCTime t tTargetLast

154 tTarget = addUTCTime dt tTargetLast

153 tTarget = addUTCTime dt tTargetLast

src/Reflex/Dom/WebSocket.hs+2−4

@@ -38,15 +38,13 @@ data WebSocket t

38webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m) => Text -> WebSocketConfig t -> m (WebSocket t)

39webSocket url config = do

40 wv <- fmap unWebViewSingleton askWebView

41− (eRecv, triggerERecv) <- newTriggerEvent

41+ (eRecv, onMessage) <- newTriggerEvent

42 currentSocketRef <- liftIO $ newIORef Nothing

43 --TODO: Disconnect if value no longer needed

44 (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete

45 payloadQueue <- liftIO newTQueueIO

46 isOpen <- liftIO newEmptyTMVarIO

47− let onMessage :: ByteString -> IO ()

48− onMessage m = triggerERecv m

49− onOpen = triggerEOpen () $ do

47+ let onOpen = triggerEOpen () $ do

50 liftIO $ void $ atomically $ tryPutTMVar isOpen ()

48 liftIO $ void $ atomically $ tryPutTMVar isOpen ()

51 --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?

49 --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?

52 onClose = void $ forkIO $ do

50 onClose = void $ forkIO $ do

src/Reflex/Dom/Widget.hs+5−9

@@ -1,10 +1,6 @@

1−module Reflex.Dom.Widget ( module Reflex.Dom.Widget.Basic

1+module Reflex.Dom.Widget (module X) where

2− , module Reflex.Dom.Widget.Input

3− , module Reflex.Dom.Widget.Lazy

4− , module Reflex.Dom.Widget.Resize

5− ) where

6

2

7−import Reflex.Dom.Widget.Basic

3+import Reflex.Dom.Widget.Basic as X

8−import Reflex.Dom.Widget.Input

4+import Reflex.Dom.Widget.Input as X

9−import Reflex.Dom.Widget.Lazy

5+import Reflex.Dom.Widget.Lazy as X

10−import Reflex.Dom.Widget.Resize

6+import Reflex.Dom.Widget.Resize as X

src/Reflex/Dom/Widget/Basic.hs+20−20

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

1−{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-}

1+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes #-}

2−

3module Reflex.Dom.Widget.Basic where

2module Reflex.Dom.Widget.Basic where

4

3

5import Reflex.Dom.Class

4import Reflex.Dom.Class

@@ -16,6 +15,7 @@ import Data.Set (Set)

16import qualified Data.Set as Set

15import qualified Data.Set as Set

17import Data.Foldable

16import Data.Foldable

18import Data.Traversable

17import Data.Traversable

18+import Control.Arrow

19import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

20import Control.Lens hiding (element, children)

21import Data.These

@@ -65,12 +65,12 @@ listHoldWithKey initialChildren modifyChildren buildChild = do

65 & deleteSelf .~ delete

66 ph <- placeholder myCfg

67 result <- deletable delete $ buildChild k v

68− return $ ChildResult (result, (fmap (fmap Just) $ _placeholder_insertedAbove ph) <> (Map.singleton k Nothing <$ _placeholder_deletedSelf ph)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed

68+ return $ ChildResult (result, (fmap Just <$> _placeholder_insertedAbove ph) <> (Map.singleton k Nothing <$ _placeholder_deletedSelf ph)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed

69 rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild

70 augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove

71− let newInsertedAbove = switch $ fmap (mconcat . reverse . fmap (snd . unChildResult) . Map.elems) $ current augmentedResults

71+ let newInsertedAbove = switch $ mconcat . reverse . fmap (snd . unChildResult) . Map.elems <$> current augmentedResults

72 belowAll <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Right ())

73− let newInsertedBelow = fmap (fmap Just) $ _placeholder_insertedAbove belowAll

73+ let newInsertedBelow = fmap Just <$> _placeholder_insertedAbove belowAll

74 mapDyn (fmap (fst . unChildResult)) augmentedResults

75

76text :: DomBuilder t m => Text -> m ()

@@ -101,7 +101,7 @@ dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

101dyn child = do

102 postBuild <- getPostBuild

103 let newChild = leftmost [updated child, tag (current child) postBuild]

104− liftM snd $ widgetHoldInternal (return ()) newChild

104+ snd <$> widgetHoldInternal (return ()) newChild

105

106-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.

107-- The returned Dynamic of widget results occurs when the Event does.

@@ -167,7 +167,7 @@ listWithKey' = listWithKeyShallowDiff

167listWithKeyShallowDiff :: (Ord k, DomBuilder t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

168listWithKeyShallowDiff initialVals valsChanged mkChild = do

169 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged

170− sentVals <- foldDyn applyMap Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged

170+ sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged

171 let relevantPatch patch _ = case patch of

172 Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored

173 Just _ -> Nothing -- We don't want to let spurious re-creations of items through

@@ -178,10 +178,10 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do

178-- | Create a dynamically-changing set of Event-valued widgets.

179-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.

180listViewWithKey :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))

181−listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild

181+listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild

182

183listViewWithKey' :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))

184−listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild

184+listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild

185

186-- | Create a dynamically-changing set of widgets, one of which is selected at any time.

187selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

@@ -195,14 +195,14 @@ selectViewListWithKey selection vals mkChild = do

195 selected <- getDemuxed selectionDemux k

196 selectSelf <- mkChild k v selected

197 return $ fmap ((,) k) selectSelf

198− liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild

198+ return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild

199

200selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

201 => Dynamic t k -- ^ Current selection key

202 -> Dynamic t (Map k v) -- ^ Dynamic key/value map

203 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

204 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

205−selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewListWithKey selection vals mkChild

205+selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild

206

207{-

208{-# INLINABLE elWith #-}

@@ -265,7 +265,7 @@ el' elementTag = element elementTag def

265{-# INLINABLE elAttr' #-}

266elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

267elAttr' elementTag attrs = element elementTag $ def

268− & initialAttributes .~ (Map.fromList $ fmap (\(k, v) -> ((Nothing, k), v)) $ Map.toList $ attrs)

268+ & initialAttributes .~ Map.mapKeys (\k -> (Nothing, k)) attrs

269

270{-# INLINABLE elDynAttr #-}

271elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a

@@ -276,7 +276,7 @@ el :: forall t m a. DomBuilder t m => Text -> m a -> m a

276el elementTag child = snd <$> el' elementTag child

277

278elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a

279−elClass elementTag c child = fmap snd $ element elementTag (def & initialAttributes .~ (Nothing, "class") =: c) child

279+elClass elementTag c child = snd <$> element elementTag (def & initialAttributes .~ (Nothing, "class") =: c) child

280

281--------------------------------------------------------------------------------

282-- Copied and pasted from Reflex.Widget.Class

@@ -325,17 +325,17 @@ newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)

325

326workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)

327workflow w0 = do

328− rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult

328+ rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

329− mapDyn fst eResult

329+ return $ fmap fst eResult

330

331workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

332workflowView w0 = do

333− rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace

333+ rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace

334− eReplace <- liftM switch $ hold never $ fmap snd eResult

334+ eReplace <- fmap switch $ hold never $ fmap snd eResult

335 return $ fmap fst eResult

336

337mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b

338−mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x)

338+mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

339

340divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a

341divClass = elClass "div"

@@ -376,9 +376,9 @@ tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuil

376tabDisplay ulClass activeClass tabItems = do

377 let t0 = listToMaybe $ Map.keys tabItems

378 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do

379− tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< getDemuxed currentTab (Just k)) tabItems

379+ tabClicksList :: [Event t k] <- Map.elems <$> imapM (\k (s,_) -> headerBarLink s k =<< getDemuxed currentTab (Just k)) tabItems

380 let eTabClicks :: Event t k = leftmost tabClicksList

381− liftM demux $ holdDyn t0 $ fmap Just eTabClicks

381+ fmap demux $ holdDyn t0 $ fmap Just eTabClicks

382 el "div" $ do

383 iforM_ tabItems $ \k (_, w) -> do

384 isSelected <- getDemuxed currentTab $ Just k

src/Reflex/Dom/Widget/Input.hs+11−39

@@ -25,7 +25,7 @@ import Control.Monad.IO.Class

25import GHCJS.DOM.EventM (on)

26import GHCJS.DOM.Types (File)

27import qualified GHCJS.DOM.Element as Element

28−import qualified GHCJS.DOM.File as File

28+-- import qualified GHCJS.DOM.File as File

29import qualified GHCJS.DOM.FileList as FileList

30

31

@@ -150,24 +150,6 @@ textArea (TextAreaConfig initial eSet attrs) = do

150 , _textArea_hasFocus = _textAreaElement_hasFocus i

151 , _textArea_element = castToHTMLTextAreaElement $ _element_raw $ _textAreaElement_element i

152 }

153−{-

154− e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs

155− TextArea.setValue e $ Just initial

156− postGui <- askPostGui

157− runWithActions <- askRunWithActions

158− eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

159− unsubscribeOnblur <- on e blurEvent $ liftIO $ do

160− postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]

161− unsubscribeOnfocus <- on e focusEvent $ liftIO $ do

162− postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]

163− return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

164− performEvent_ $ fmap (TextArea.setValue e . Just) eSet

165− f <- holdDyn False eChangeFocus

166− ev <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> TextArea.getValue e

167− v <- holdDyn initial $ leftmost [eSet, ev]

168− eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent

169− return $ TextArea v ev e f eKeypress

170−-}

171

153

172data CheckboxConfig t

154data CheckboxConfig t

173 = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool

155 = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool

@@ -191,7 +173,7 @@ data Checkbox t

191checkbox :: (DomBuilder t m, PostBuild t m) => Bool -> CheckboxConfig t -> m (Checkbox t)

173checkbox :: (DomBuilder t m, PostBuild t m) => Bool -> CheckboxConfig t -> m (Checkbox t)

192checkbox checked config = do

174checkbox checked config = do

193 let permanentAttrs = "type" =: "checkbox"

175 let permanentAttrs = "type" =: "checkbox"

194− dAttrs = fmap (Map.delete "checked" . Map.union permanentAttrs) $ _checkboxConfig_attributes config

176+ dAttrs = Map.delete "checked" . Map.union permanentAttrs <$> _checkboxConfig_attributes config

195 modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs

177 modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs

196 i <- inputElement $ def

178 i <- inputElement $ def

197 & inputElementConfig_initialChecked .~ checked

179 & inputElementConfig_initialChecked .~ checked

@@ -201,14 +183,6 @@ checkbox checked config = do

201 return $ Checkbox

183 return $ Checkbox

202 { _checkbox_value = _inputElement_checked i

184 { _checkbox_value = _inputElement_checked i

203 }

185 }

204−{-

205− attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config)

206− e <- liftM castToHTMLInputElement $ buildEmptyElement "input" attrs

207− eClick <- wrapDomEvent e (`on` click) $ Input.getChecked e

208− performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ _checkboxConfig_setValue config

209− dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick]

210− return $ Checkbox dValue eClick

211−-}

212

186

213type family CheckboxViewEventResultType (en :: EventTag) :: * where

187type family CheckboxViewEventResultType (en :: EventTag) :: * where

214 CheckboxViewEventResultType 'ClickTag = Bool

188 CheckboxViewEventResultType 'ClickTag = Bool

@@ -297,7 +271,7 @@ checkboxView dAttrs dValue = do

297 & inputElementConfig_setChecked .~ leftmost [updated dValue, tag (current dValue) postBuild]

271 & inputElementConfig_setChecked .~ leftmost [updated dValue, tag (current dValue) postBuild]

298 & inputElementConfig_elementConfig .~ elementConfig

272 & inputElementConfig_elementConfig .~ elementConfig

299 i <- inputElement inputElementConfig

273 i <- inputElement inputElementConfig

300− return $ fmap unCheckboxViewEventResult $ select (_element_events $ _inputElement_element i) (WrapArg Click)

274+ return $ unCheckboxViewEventResult <$> select (_element_events $ _inputElement_element i) (WrapArg Click)

301{-

275{-

302 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs

276 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs

303 eClicked <- wrapDomEvent e (`on` click) $ do

277 eClicked <- wrapDomEvent e (`on` click) $ do

@@ -326,11 +300,11 @@ fileInput :: forall t m. (MonadIO m, MonadFix m, MonadHold t m, TriggerEvent t m

326 => FileInputConfig t -> m (FileInput t)

300 => FileInputConfig t -> m (FileInput t)

327fileInput config = do

301fileInput config = do

328 let insertType = Map.insert "type" "file"

302 let insertType = Map.insert "type" "file"

329− dAttrs = fmap insertType $ _fileInputConfig_attributes config

303+ dAttrs = insertType <$> _fileInputConfig_attributes config

330 modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs

304 modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs

331 let cfg = (def :: ElementConfig EventResult t m)

305 let cfg = (def :: ElementConfig EventResult t m)

332 { _elementConfig_modifyAttributes = modifyAttrs

306 { _elementConfig_modifyAttributes = modifyAttrs

333− , _elementConfig_eventFilters = DMap.singleton Change . EventFilter . GhcjsDomHandler $ \(GhcjsDomEvent evt) -> do

307+ , _elementConfig_eventFilters = DMap.singleton Change . EventFilter . GhcjsDomHandler $ \_ -> do

334 return . (,) mempty . GhcjsDomHandler $ \_ -> return . Just $ EventResult ()

308 return . (,) mempty . GhcjsDomHandler $ \_ -> return . Just $ EventResult ()

335 }

309 }

336 (eRaw, _) <- element "input" cfg blank

310 (eRaw, _) <- element "input" cfg blank

@@ -338,7 +312,7 @@ fileInput config = do

338 eChange <- wrapDomEvent e (`on` Element.change) $ do

312 eChange <- wrapDomEvent e (`on` Element.change) $ do

339 Just files <- Input.getFiles e

313 Just files <- Input.getFiles e

340 len <- FileList.getLength files

314 len <- FileList.getLength files

341− mapM (liftM (fromMaybe (error "fileInput: fileList.item returned null")) . FileList.item files) $ [0 .. len-1]

315+ mapM (fmap (fromMaybe (error "fileInput: fileList.item returned null")) . FileList.item files) $ [0 .. len-1]

342 dValue <- holdDyn [] eChange

316 dValue <- holdDyn [] eChange

343 return $ FileInput

317 return $ FileInput

344 { _fileInput_value = dValue

318 { _fileInput_value = dValue

@@ -447,12 +421,12 @@ dropdown k0 options (DropdownConfig setK attrs) = do

447 optionAttrs <- mapDyn (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey

421 optionAttrs <- mapDyn (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey

448 elDynAttr "option" optionAttrs $ dynText v

422 elDynAttr "option" optionAttrs $ dynText v

449 let e = castToHTMLSelectElement $ _element_raw eRaw

423 let e = castToHTMLSelectElement $ _element_raw eRaw

450− performEvent_ $ fmap (HTMLSelectElement.setValue e . Just . show) $ attachDynWithMaybe (flip Bimap.lookupR) ixKeys setK

424+ performEvent_ $ HTMLSelectElement.setValue e . Just . show <$> attachDynWithMaybe (flip Bimap.lookupR) ixKeys setK

451 let lookupSelected ks value = do

425 let lookupSelected ks value = do

452 v <- value

426 v <- value

453 key <- T.readMaybe v

427 key <- T.readMaybe v

454 Bimap.lookup key ks

428 Bimap.lookup key ks

455− eChange <- attachDynWith lookupSelected ixKeys <$> (wrapDomEvent e (`on` Element.change) $ HTMLSelectElement.getValue e)

429+ eChange <- attachDynWith lookupSelected ixKeys <$> wrapDomEvent e (`on` Element.change) (HTMLSelectElement.getValue e)

456 let readKey keys mk = fromMaybe k0 $ do

430 let readKey keys mk = fromMaybe k0 $ do

457 k <- mk

431 k <- mk

458 guard $ Bimap.memberR k keys

432 guard $ Bimap.memberR k keys

@@ -460,13 +434,13 @@ dropdown k0 options (DropdownConfig setK attrs) = do

460 dValue <- combineDyn readKey ixKeys <=< holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]

434 dValue <- combineDyn readKey ixKeys <=< holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]

461 return $ Dropdown dValue (attachDynWith readKey ixKeys eChange)

435 return $ Dropdown dValue (attachDynWith readKey ixKeys eChange)

462

436

463−liftM concat $ mapM makeLenses

437+concat <$> mapM makeLenses

464 [ ''TextAreaConfig

438 [ ''TextAreaConfig

465 , ''TextArea

439 , ''TextArea

466 , ''TextInputConfig

440 , ''TextInputConfig

467 , ''TextInput

441 , ''TextInput

468−-- , ''FileInputConfig

442+ , ''FileInputConfig

469−-- , ''FileInput

443+ , ''FileInput

470 , ''DropdownConfig

444 , ''DropdownConfig

471 , ''Dropdown

445 , ''Dropdown

472 , ''CheckboxConfig

446 , ''CheckboxConfig

@@ -489,11 +463,9 @@ instance HasAttributes (CheckboxConfig t) where

489 type Attrs (CheckboxConfig t) = Dynamic t (Map Text Text)

463 type Attrs (CheckboxConfig t) = Dynamic t (Map Text Text)

490 attributes = checkboxConfig_attributes

464 attributes = checkboxConfig_attributes

491

465

492−{-

493instance HasAttributes (FileInputConfig t) where

466instance HasAttributes (FileInputConfig t) where

494 type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)

467 type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)

495 attributes = fileInputConfig_attributes

468 attributes = fileInputConfig_attributes

496−-}

497

469

498class HasSetValue a where

470class HasSetValue a where

499 type SetValue a :: *

471 type SetValue a :: *

src/Reflex/Dom/Widget/Lazy.hs+11−9

@@ -49,14 +49,15 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa

49 scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll container

50 , fmap (const (i0 * rowPx)) pb

51 ]

52− window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition

52+ window <- combineDyn (findWindow rowPx) heightPx scrollPosition

53 itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items

54 postBuild <- getPostBuild

55+ performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i -> do

55− performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_element_raw container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]

56+ liftIO $ setScrollTop (_element_raw container) (i * rowPx)

56 indexAndLength <- mapDyn snd window

57 indexAndLength <- mapDyn snd window

57 return (indexAndLength, sel)

58 return (indexAndLength, sel)

58 where

59 where

59− toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)

60+ toStyleAttr m = "style" =: Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m

60 toViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>

61 toViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>

61 "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px")

62 "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px")

62 toContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (T.pack (show h) <> "px")

63 toContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (T.pack (show h) <> "px")

@@ -66,7 +67,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa

66 tagWrapper elTag attrs attrsOverride c = do

67 tagWrapper elTag attrs attrsOverride c = do

67 attrs' <- combineDyn Map.union attrsOverride attrs

68 attrs' <- combineDyn Map.union attrsOverride attrs

68 elDynAttr' elTag attrs' c

69 elDynAttr' elTag attrs' c

69− findWindow windowSize sizeIncrement startingPosition =

70+ findWindow sizeIncrement windowSize startingPosition =

70 let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement

71 let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement

71 topPx = startingPosition - topOffsetPx

72 topPx = startingPosition - topOffsetPx

72 numItems = windowSize `div` sizeIncrement + 1

73 numItems = windowSize `div` sizeIncrement + 1

@@ -94,11 +95,12 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu

94 scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll viewport

95 scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll viewport

95 , fmap (const (i0 * rowPx)) pb

96 , fmap (const (i0 * rowPx)) pb

96 ]

97 ]

97− window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition

98+ window <- combineDyn (findWindow rowPx) heightPx scrollPosition

98− performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_element_raw viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]

99+ performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i -> do

100+ liftIO $ setScrollTop (_element_raw viewport) (i * rowPx)

99 return (nubDyn window, result)

101 return (nubDyn window, result)

100 where

102 where

101− toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)

103+ toStyleAttr m = "style" =: Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m

102 mkViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>

104 mkViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>

103 "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px")

105 "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px")

104 mkContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (T.pack (show h) <> "px")

106 mkContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (T.pack (show h) <> "px")

@@ -110,7 +112,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu

110 "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>

112 "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>

111 "position" =: "absolute" <>

113 "position" =: "absolute" <>

112 "width" =: "100%"

114 "width" =: "100%"

113− findWindow windowSize sizeIncrement startingPosition =

115+ findWindow sizeIncrement windowSize startingPosition =

114 let (startingIndex, _) = startingPosition `divMod'` sizeIncrement

116 let (startingIndex, _) = startingPosition `divMod'` sizeIncrement

115 numItems = (windowSize + sizeIncrement - 1) `div` sizeIncrement

117 numItems = (windowSize + sizeIncrement - 1) `div` sizeIncrement

116 in (startingIndex, numItems)

118 in (startingIndex, numItems)

@@ -137,6 +139,6 @@ virtualListBuffered buffer heightPx rowPx maxIndex i0 setI keyToIndex items0 ite

137 then Nothing

139 then Nothing

138 else Just (extendWin winOffset winLimit)) (current winBuffered) (updated win)

140 else Just (extendWin winOffset winLimit)) (current winBuffered) (updated win)

139 winBuffered <- holdDyn (0, 0) $ leftmost [ winHitEdge

141 winBuffered <- holdDyn (0, 0) $ leftmost [ winHitEdge

140− , fmap (uncurry extendWin) $ tagDyn win pb

142+ , attachDynWith (\(x, y) _ -> extendWin x y) win pb

141 ]

143 ]

142 return (updated winBuffered, m)

144 return (updated winBuffered, m)

src/Reflex/Dom/Widget/Resize.hs+4−4

@@ -30,7 +30,7 @@ resizeDetectorWithStyle :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, Per

30 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.

31 -> m a -- ^ The embedded widget

32 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget

33−resizeDetectorWithStyle styleString w = resizeDetectorWithAttrs ("style" =: styleString) w

33+resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)

34

35resizeDetectorWithAttrs :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadIO m, MonadFix m)

36 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.

@@ -68,12 +68,12 @@ resizeDetectorWithAttrs attrs w = do

68 pow <- getOffsetWidth (_el_element parent)

69 poh <- getOffsetHeight (_el_element parent)

70 if ds == (Just pow, Just poh)

71− then return Nothing

71+ then return Nothing

72− else liftM Just reset

72+ else fmap Just reset

73 pb <- getPostBuild

74 expandScroll <- wrapDomEvent (_el_element expand) (`on` scroll) $ return ()

75 shrinkScroll <- wrapDomEvent (_el_element shrink) (`on` scroll) $ return ()

76 size0 <- performEvent $ fmap (const $ liftIO reset) pb

77 rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]

78 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]

79− return (fmap (const ()) $ fmapMaybe id resize, w')

79+ return (fmapMaybe void resize, w')

src/Reflex/Dom/Xhr.hs+15−17

@@ -56,7 +56,7 @@ import Reflex.Dom.Xhr.Exception

56import Reflex.Dom.Xhr.ResponseType

57

58import Control.Concurrent

59−import Control.Exception (catch)

59+import Control.Exception (handle)

60import Control.Lens

61import Control.Monad hiding (forM)

62import Control.Monad.IO.Class

@@ -134,7 +134,7 @@ newXMLHttpRequestWithError

134newXMLHttpRequestWithError req cb = do

135 wv <- askWebView

136 xhr <- liftIO $ xmlHttpRequestNew $ unWebViewSingleton wv

137− void $ liftIO $ forkIO $ flip catch (cb . Left) $ void $ do

137+ void $ liftIO $ forkIO $ handle (cb . Left) $ void $ do

138 let c = _xhrRequest_config req

139 rt = _xhrRequestConfig_responseType c

140 xmlHttpRequestOpen

@@ -150,20 +150,18 @@ newXMLHttpRequestWithError req cb = do

150 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

151 status <- liftIO $ xmlHttpRequestGetStatus xhr

152 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

153− if readyState == 4

153+ when (readyState == 4) $ do

154− then do

155− t <- if rt == Just XhrResponseType_Text || rt == Nothing

154+ t <- if rt == Just XhrResponseType_Text || isNothing rt

156− then liftIO $ xmlHttpRequestGetResponseText xhr

155+ then liftIO $ xmlHttpRequestGetResponseText xhr

157− else return Nothing

156+ else return Nothing

158− r <- liftIO $ xmlHttpRequestGetResponse xhr

157+ r <- liftIO $ xmlHttpRequestGetResponse xhr

159− _ <- liftIO $ cb $ Right $

158+ _ <- liftIO $ cb $ Right $ XhrResponse

160− XhrResponse { _xhrResponse_status = status

159+ { _xhrResponse_status = status

161− , _xhrResponse_statusText = statusText

160+ , _xhrResponse_statusText = statusText

162− , _xhrResponse_response = r

161+ , _xhrResponse_response = r

163− , _xhrResponse_responseText = t

162+ , _xhrResponse_responseText = t

164− }

163+ }

165− return ()

166− else return ()

164+ return ()

167 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

165 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

168 return ()

166 return ()

169 return xhr

167 return xhr

@@ -255,7 +253,7 @@ decodeText = decode . BL.fromStrict . encodeUtf8

255decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

253decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

256decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

254decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

257

255

258−liftM concat $ mapM makeLenses

256+concat <$> mapM makeLenses

259 [ ''XhrRequest

257 [ ''XhrRequest

260 , ''XhrRequestConfig

258 , ''XhrRequestConfig

261 , ''XhrResponse

259 , ''XhrResponse