git.iko.soy/reflex-dom
on develop help sign in
Many style fixes

Using: hlint -i "Redundant do" -i "Use camelCase" -i "Redundant $" -i "Reduce duplication" .

commita00ce01f78ebf80d361ba8242bc5ac1988484143 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 16 Jul 2016, 23:40 (10 years ago) parentfa282cf
24 files changed+171−238
compare with develop
unifiedsplit
src-ghc/Reflex/Dom/Internal/Foreign.hs+11−12 src-ghc/Reflex/Dom/WebSocket/Foreign.hs+1−1 src-ghc/Reflex/Dom/Xhr/Foreign.hs+12−20 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+3−4 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+6−6 src/Foreign/JavaScript/TH.hs+11−11 src/Reflex/Dom.hs+16−31 src/Reflex/Dom/Builder/Class.hs+4−4 src/Reflex/Dom/Builder/Immediate.hs+9−13 src/Reflex/Dom/Builder/Static.hs+6−9 src/Reflex/Dom/Class.hs+1 src/Reflex/Dom/DynamicWriter.hs+4−4 src/Reflex/Dom/Internal.hs+9−10 src/Reflex/Dom/PerformEvent/Base.hs+4−4 src/Reflex/Dom/PerformEvent/Class.hs+1−1 src/Reflex/Dom/PostBuild/Class.hs+2−2 src/Reflex/Dom/Time.hs+3−4 src/Reflex/Dom/WebSocket.hs+2−4 src/Reflex/Dom/Widget.hs+5−9 src/Reflex/Dom/Widget/Basic.hs+20−20 src/Reflex/Dom/Widget/Input.hs+11−39 src/Reflex/Dom/Widget/Lazy.hs+11−9 src/Reflex/Dom/Widget/Resize.hs+4−4 src/Reflex/Dom/Xhr.hs+15−17
src-ghc/Reflex/Dom/Internal/Foreign.hs+11−12
@@ -27,6 +27,7 @@ import System.Directory
2727import System.Glib.FFI hiding (void)
2828import qualified Data.ByteString as BS
2929import Data.Monoid
30+import Data.Maybe
3031import Data.Text (Text)
3132import qualified Data.Text as T
3233
@@ -113,29 +114,27 @@ toJSObject ctx args = do
113114fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Text)
114115fromJSStringMaybe c t = do
115116 isNull <- jsvalueisnull c t
116− case isNull of
117− True -> return Nothing
118− False -> do
119− j <- jsvaluetostringcopy c t nullPtr
120− l <- jsstringgetmaximumutf8cstringsize j
121− s <- allocaBytes (fromIntegral l) $ \ps -> do
122− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
123− peekCString ps
124− return $ Just $ T.pack s
117+ if isNull then return Nothing else do
118+ j <- jsvaluetostringcopy c t nullPtr
119+ l <- jsstringgetmaximumutf8cstringsize j
120+ s <- allocaBytes (fromIntegral l) $ \ps -> do
121+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
122+ peekCString ps
123+ return $ Just $ T.pack s
125124
126125getLocationHost :: WebView -> IO Text
127126getLocationHost wv = withWebViewContext wv $ \c -> do
128127 script <- jsstringcreatewithutf8cstring "location.host"
129128 lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
130129 lh' <- fromJSStringMaybe c lh
131− return $ maybe "" id lh'
130+ return $ fromMaybe "" lh'
132131
133132getLocationProtocol :: WebView -> IO Text
134133getLocationProtocol wv = withWebViewContext wv $ \c -> do
135134 script <- jsstringcreatewithutf8cstring "location.protocol"
136135 lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
137136 lp' <- fromJSStringMaybe c lp
138− return $ maybe "" id lp'
137+ return $ fromMaybe "" lp'
139138
140139bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef
141140bsToArrayBuffer c bs = do
@@ -159,7 +158,7 @@ bsFromArrayBuffer c a = do
159158 i' <- jsvaluemakenumber c (fromIntegral i)
160159 args <- toJSObject c [uint8Array, i']
161160 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
163162
164163withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a
165164withWebViewContext 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 #-}
22
33module Reflex.Dom.WebSocket.Foreign where
44
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 #-}
22module Reflex.Dom.Xhr.Foreign ( module Reflex.Dom.Xhr.Foreign
33 , XhrResponseType
44 ) where
@@ -111,14 +111,12 @@ xmlHttpRequestGetResponse xhr = do
111111 script <- jsstringcreatewithutf8cstring "this.response"
112112 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
113113 isNull <- jsvalueisnull c t
114− case isNull of
115− True -> return Nothing
116− False -> case mrt of
117− Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t
118− Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t
119− Just XhrResponseType_Default -> fmap (XhrResponseBody_Default) <$> fromJSStringMaybe c t
120− Just XhrResponseType_Text -> fmap (XhrResponseBody_Text) <$> fromJSStringMaybe c t
121− _ -> return Nothing
114+ if isNull then return Nothing else case mrt of
115+ Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t
116+ Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t
117+ Just XhrResponseType_Default -> fmap XhrResponseBody_Default <$> fromJSStringMaybe c t
118+ Just XhrResponseType_Text -> fmap XhrResponseBody_Text <$> fromJSStringMaybe c t
119+ _ -> return Nothing
122120
123121xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)
124122xmlHttpRequestGetResponseText xhr = do
@@ -138,17 +136,11 @@ xmlHttpRequestSendPayload xhr payload = do
138136 onError <- jsobjectmakefunctionwithcallback c nullPtr e
139137 bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do
140138 onLoad <- jsobjectmakefunctionwithcallback c nullPtr l
141− (o,s) <- case payload of
142− Nothing -> do
143− d <- 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'
149− o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
150− s <- jsstringcreatewithutf8cstring send
151− return (o,s)
139+ d <- case payload of
140+ Nothing -> jsvaluemakeundefined c
141+ Just payload' -> stringToJSValue c payload'
142+ o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
143+ s <- jsstringcreatewithutf8cstring send
152144 _ <- jsevaluatescript c s o nullPtr 1 nullPtr
153145 takeMVar result >>= mapM_ throwIO
154146 where
src-ghcjs/Reflex/Dom/Internal/Foreign.hs+3−4
@@ -3,7 +3,6 @@ module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign
33 , runWebGUI
44 ) where
55
6−import Control.Monad
76import Data.ByteString (ByteString)
87import Foreign
98import Foreign.C
@@ -21,12 +20,12 @@ quitWebView = error "quitWebView: unimplemented in GHCJS"
2120foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString
2221
2322getLocationHost :: FromJSString r => a -> IO r
24−getLocationHost _ = liftM fromJSString getLocationHost_
23+getLocationHost _ = fmap fromJSString getLocationHost_
2524
2625foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString
2726
2827getLocationProtocol :: FromJSString r => a -> IO r
29−getLocationProtocol _ = liftM fromJSString getLocationProtocol_
28+getLocationProtocol _ = fmap fromJSString getLocationProtocol_
3029
3130withWebViewContext :: a -> (a -> IO b) -> IO b
3231withWebViewContext a f = f a
@@ -40,4 +39,4 @@ bsToArrayBuffer _ bs = BS.useAsCString bs $ \cStr -> do
4039 extractByteArray cStr $ BS.length bs
4140
4241bsFromArrayBuffer :: 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 #-}
22
33module Reflex.Dom.Xhr.Foreign (
44 XMLHttpRequest
@@ -163,11 +163,11 @@ xmlHttpRequestGetResponse xhr = do
163163 mr <- getResponse xhr
164164 rt <- xmlHttpRequestGetResponseType xhr
165165 case rt of
166− Just XhrResponseType_Blob -> return $ fmap (XhrResponseBody_Blob . castToBlob) mr
167− Just XhrResponseType_Text -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr
168− Just XhrResponseType_Default -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr
169− Just XhrResponseType_ArrayBuffer -> case (fmap unGObject mr) of
166+ Just XhrResponseType_Blob -> return $ XhrResponseBody_Blob . castToBlob <$> mr
167+ Just XhrResponseType_Text -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
168+ Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
169+ Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of
170170 Nothing -> return Nothing
171− Just ptr -> fmap (Just . XhrResponseBody_ArrayBuffer) $ bsFromArrayBuffer ptr ptr
171+ Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer ptr ptr
172172 _ -> return Nothing
173173
src/Foreign/JavaScript/TH.hs+11−11
@@ -213,15 +213,15 @@ instance IsJSContext JSCtx_IO where
213213 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
214214
215215instance 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)
217217 forkJS = forkIO
218218 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
219219 isJSNull (JSRef_IO r) = return $ JS.isNull r
220220 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
221221 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
222222 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
223− fromJSArray (JSRef_IO r) = liftM 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
223+ fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
224+ fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
225225 fromJSNumber (JSRef_IO r) = do
226226 Just n <- JS.fromJSVal r
227227 return n
@@ -241,7 +241,7 @@ instance MonadJS JSCtx_IO IO where
241241 l <- JS.toListIO $ coerce args
242242 JSRef_IO result <- f $ coerce l
243243 return result
244− liftM (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
244+ fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
245245 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
246246 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
247247 getJSProp s (JSRef_IO o) = do
@@ -294,7 +294,7 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
294294 liftIO $ forkIO $ runWithWebView a wv
295295 mkJSUndefined = do
296296 jsContext <- askJSContext
297− liftM JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
297+ fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
298298 isJSNull (JSRef_JavaScriptCore r) = do
299299 jsContext <- askJSContext
300300 liftIO $ jsvalueisnull jsContext r
@@ -343,7 +343,7 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
343343 lenDouble <- fromJSNumberRaw lenRef
344344 let len = round lenDouble
345345 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
347347 fromJSUint8Array a = do
348348 vals <- fromJSArray a
349349 doubles <- mapM fromJSNumber vals
@@ -359,7 +359,7 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
359359 x <- peekElemOff argv n
360360 jsvalueprotect jsContext x
361361 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
362− liftM unJSRef_JavaScriptCore $ runWithWebView (a args) wv
362+ unJSRef_JavaScriptCore <$> runWithWebView (a args) wv
363363 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
364364 liftIO $ jsvalueprotect jsContext cbRef
365365 return $ JSFun $ JSRef_JavaScriptCore cbRef
@@ -373,7 +373,7 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
373373 getJSProp propName (JSRef_JavaScriptCore objRef) = do
374374 withJSStringRaw propName $ \propNameRaw -> do
375375 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
377377 withJSNode = error "withJSNode is only supported in ghcjs"
378378
379379#endif
@@ -399,7 +399,7 @@ instance FromJS x Text where
399399instance FromJS x a => FromJS x (Maybe a) where
400400 fromJS x = do
401401 n <- isJSNull x
402− if n then return Nothing else liftM Just $ fromJS x
402+ if n then return Nothing else Just <$> fromJS x
403403
404404class ToJS x a where
405405 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
@@ -422,7 +422,7 @@ instance ToJS x a => ToJS x (JSArray a) where
422422 withJS = withJSArrayFromList . unJSArray
423423
424424instance FromJS x a => FromJS x (JSArray a) where
425− fromJS = liftM JSArray . mapM fromJS <=< fromJSArray
425+ fromJS = fmap JSArray . mapM fromJS <=< fromJSArray
426426
427427withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
428428withJSArrayFromList as f = go as []
@@ -444,7 +444,7 @@ instance ToJS x Int where
444444 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
445445
446446instance FromJS x Int where
447− fromJS = liftM round . fromJSNumber --TODO: Check things; throw exceptions
447+ fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions
448448
449449instance ToJS x Double where
450450 withJS = withJSNumber
src/Reflex/Dom.hs+16−31
@@ -1,32 +1,17 @@
1−module Reflex.Dom ( module Reflex
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
1+module Reflex.Dom (module X) where
172
18−import Reflex
19−import Reflex.Dom.Builder.Class
20−import Reflex.Dom.Builder.Immediate
21−import Reflex.Dom.Builder.Static
22−import Reflex.Dom.Class
23−import Reflex.Dom.DynamicWriter
24−import Reflex.Dom.Internal
25−import Reflex.Dom.Location
26−import Reflex.Dom.Old
27−import Reflex.Dom.PerformEvent.Class
28−import Reflex.Dom.PostBuild.Class
29−import Reflex.Dom.Time
30−import Reflex.Dom.WebSocket
31−import Reflex.Dom.Widget
32−import Reflex.Dom.Xhr
3+import Reflex as X
4+import Reflex.Dom.Builder.Class as X
5+import Reflex.Dom.Builder.Immediate as X
6+import Reflex.Dom.Builder.Static as X
7+import Reflex.Dom.Class as X
8+import Reflex.Dom.DynamicWriter as X
9+import Reflex.Dom.Internal as X
10+import Reflex.Dom.Location as X
11+import Reflex.Dom.Old as X
12+import Reflex.Dom.PerformEvent.Class as X
13+import Reflex.Dom.PostBuild.Class as X
14+import Reflex.Dom.Time as X
15+import Reflex.Dom.WebSocket as X
16+import Reflex.Dom.Widget as X
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 #-}
22module Reflex.Dom.Builder.Class
33 ( module Reflex.Dom.Builder.Class
44 , module Reflex.Dom.Builder.Class.Events
@@ -244,7 +244,7 @@ instance Functor1 (ElementConfig er t) where
244244instance Reflex t => Functor1 (PlaceholderConfig above t) where
245245 {-# INLINABLE fmap1 #-}
246246 fmap1 f cfg = cfg
247− { _placeholderConfig_insertAbove = fmap f $ _placeholderConfig_insertAbove cfg
247+ { _placeholderConfig_insertAbove = f <$> _placeholderConfig_insertAbove cfg
248248 }
249249
250250instance Functor1 (InputElementConfig er t) where
@@ -262,7 +262,7 @@ class HasDomEvent t target eventName where
262262instance Reflex t => HasDomEvent t (Element EventResult d t) en where
263263 type DomEventType (Element EventResult d t) en = EventResultType en
264264 {-# 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)
266266
267267instance Reflex t => HasDomEvent t (InputElement EventResult d t) en where
268268 type DomEventType (InputElement EventResult d t) en = EventResultType en
@@ -307,7 +307,7 @@ instance MonadTransControlStateless (ReaderT r)
307307type RunStateless t = forall n b. Monad n => t n b -> n b
308308
309309liftWithStateless :: 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
311311
312312liftTextNode :: (MonadTrans f, DomBuilder t m) => TextNodeConfig t -> f m (TextNode t)
313313liftTextNode = 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 #-}
22module Reflex.Dom.Builder.Immediate where
33
44import Reflex
@@ -62,7 +62,7 @@ instance MonadTrans (ImmediateDomBuilderT t) where
6262
6363{-# INLINABLE runImmediateDomBuilderT #-}
6464runImmediateDomBuilderT :: ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t -> m a
65−runImmediateDomBuilderT (ImmediateDomBuilderT a) env = runReaderT a env
65+runImmediateDomBuilderT (ImmediateDomBuilderT a) = runReaderT a
6666
6767{-# INLINABLE askDocument #-}
6868askDocument :: Monad m => ImmediateDomBuilderT t m Document
@@ -206,8 +206,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
206206 let domInputElement = castToHTMLInputElement domElement
207207 Just v0 <- Input.getValue domInputElement
208208 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
209− valueChangedByUI <- performEvent $ ffor (Reflex.select (_element_events e) (WrapArg Input)) $ \_ ->
210− getMyValue
209+ valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
211210 valueChangedBySetValue <- performEvent $ ffor (cfg ^. inputElementConfig_setValue) $ \v' -> do
212211 Input.setValue domInputElement $ Just v'
213212 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
240239 let domTextAreaElement = castToHTMLTextAreaElement domElement
241240 Just v0 <- TextArea.getValue domTextAreaElement
242241 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
243− valueChangedByUI <- performEvent $ ffor (Reflex.select (_element_events e) (WrapArg Input)) $ \_ ->
244− getMyValue
242+ valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
245243 valueChangedBySetValue <- performEvent $ ffor (cfg ^. textAreaElementConfig_setValue) $ \v' -> do
246244 TextArea.setValue domTextAreaElement $ Just v'
247245 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) =>
314312 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
315313 newEventWithLazyTriggerWithOnComplete f = do
316314 events <- askEvents
317− eResult <- lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
315+ lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
318316 reResultTrigger <- newIORef $ Just t
319317 writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]
320− return eResult
321318
322319instance HasWebView m => HasWebView (ImmediateDomBuilderT t m) where
323320 type WebViewPhantom (ImmediateDomBuilderT t m) = WebViewPhantom m
@@ -392,7 +389,7 @@ type family EventType en where
392389
393390{-# INLINABLE defaultDomEventHandler #-}
394391defaultDomEventHandler :: 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
396393 Click -> return ()
397394 Dblclick -> return ()
398395 Keypress -> getKeyEvent
@@ -444,7 +441,7 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
444441
445442{-# INLINABLE defaultDomWindowEventHandler #-}
446443defaultDomWindowEventHandler :: 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
448445 Click -> return ()
449446 Dblclick -> return ()
450447 Keypress -> getKeyEvent
@@ -652,7 +649,7 @@ windowOnEventName en e = case en of
652649
653650{-# INLINABLE wrapDomEvent #-}
654651wrapDomEvent :: (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
656653
657654{-# INLINABLE subscribeDomEvent #-}
658655subscribeDomEvent :: (EventM e event () -> IO (IO ()))
@@ -674,10 +671,9 @@ wrapDomEventMaybe :: (MonadIO m, TriggerEvent t m)
674671 -> EventM e event (Maybe a)
675672 -> m (Event t a)
676673wrapDomEventMaybe el elementOnevent getValue = do
677− e <- newEventWithLazyTriggerWithOnComplete $ \trigger -> elementOnevent el $ do
674+ newEventWithLazyTriggerWithOnComplete $ \trigger -> elementOnevent el $ do
678675 mv <- getValue
679676 forM_ mv $ \v -> liftIO $ trigger v $ return ()
680− return e
681677
682678{-# INLINABLE wrapDomEventsMaybe #-}
683679wrapDomEventsMaybe :: (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 #-}
22module Reflex.Dom.Builder.Static where
33
44import Reflex
@@ -13,12 +13,9 @@ import Control.Monad.Identity
1313import Data.Dependent.Sum (DSum (..))
1414
1515import Data.Monoid
16−import Data.Text (Text)
1716import qualified Data.Map as Map
18−import Data.Map (Map)
1917import Control.Lens hiding (element)
2018import qualified Data.ByteString.Lazy as BL
21−import qualified Data.ByteString.Char8 as B8
2219import Data.ByteString (ByteString)
2320import Control.Monad.State.Strict
2421import Control.Monad.Trans.Control
@@ -104,15 +101,15 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
104101
105102 {-# INLINABLE element #-}
106103 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) <> "\""
108105 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
109106 StaticDomBuilderT $ do
110107 (result, innerHtml) <- lift $ runStaticDomBuilderT child
111108 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
112109 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
113− let tag = encodeUtf8 elementTag
114− let open = mconcat [constant ("<" <> tag <> " "), attrs1, constant ">"]
115− let close = constant $ "</" <> tag <> ">" -- TODO handle elements without closing tags
110+ let tagBS = encodeUtf8 elementTag
111+ let open = mconcat [constant ("<" <> tagBS <> " "), attrs1, constant ">"]
112+ let close = constant $ "</" <> tagBS <> ">" -- TODO handle elements without closing tags
116113 modify $ (:) $ mconcat $ [open, innerHtml, close]
117114 return (Element es (error "Static.element RawElement was used"), result)
118115
@@ -120,7 +117,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
120117 placeholder (PlaceholderConfig toInsertAbove _delete) = StaticDomBuilderT $ do
121118 result <- lift $ performEvent (fmap runStaticDomBuilderT toInsertAbove)
122119 acc <- foldDyn (:) [] (fmap snd result)
123− modify $ (:) $ join $ fmap (mconcat . reverse) $ current acc
120+ modify $ (:) $ join $ mconcat . reverse <$> current acc
124121 return $ Placeholder (fmap fst result) never
125122
126123 {-# INLINABLE inputElement #-}
src/Reflex/Dom/Class.hs+1
@@ -16,6 +16,7 @@ import qualified Data.Map as Map
1616-- | Alias for Data.Map.singleton
1717(=:) :: k -> a -> Map k a
1818(=:) = Map.singleton
19+infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6
1920
2021keycodeEnter :: Int
2122keycodeEnter = 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 #-}
22module Reflex.Dom.DynamicWriter where
33
44import Reflex
@@ -66,7 +66,7 @@ mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map
6666mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
6767
6868unsafeMapIncremental :: (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
7070
7171incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
7272incrementalExtractFunctorDMap = 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 (
174174 return (el, a)
175175 placeholder cfg = do
176176 let cfg' = cfg
177− { _placeholderConfig_insertAbove = fmap runDynamicWriterTInternal $ _placeholderConfig_insertAbove cfg
177+ { _placeholderConfig_insertAbove = runDynamicWriterTInternal <$> _placeholderConfig_insertAbove cfg
178178 }
179179 let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order
180180 -> 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 (
193193 p <- DynamicWriterT $ do
194194 modify (children:)
195195 lift $ placeholder cfg'
196− let result = fmap fst $ _placeholder_insertedAbove p
196+ let result = fst <$> _placeholder_insertedAbove p
197197 childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p
198198 return $ p
199199 { _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 #-}
22module Reflex.Dom.Internal where
33
44import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)
@@ -17,7 +17,6 @@ import GHCJS.DOM.Node
1717import GHCJS.DOM.Element
1818import GHCJS.DOM.Document
1919import Control.Lens
20−import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
2120import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
2221import Control.Monad.Ref
2322import Control.Concurrent
@@ -34,7 +33,7 @@ import Data.Maybe
3433{-# INLINABLE mainWidget #-}
3534mainWidget :: (forall x. Widget x ()) -> IO ()
3635mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
37− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView
36+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
3837 Just body <- getBody doc
3938 attachWidget body webViewSing w
4039
@@ -42,8 +41,8 @@ mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSi
4241{-# INLINABLE mainWidgetWithHead #-}
4342mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()
4443mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
45− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView
46− Just headElement <- liftM (fmap DOM.castToHTMLElement) $ getHead doc
44+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
45+ Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
4746 attachWidget headElement webViewSing h
4847 Just body <- getBody doc
4948 attachWidget body webViewSing b
@@ -51,8 +50,8 @@ mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $
5150{-# INLINABLE mainWidgetWithCss #-}
5251mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()
5352mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
54− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView
55− Just headElement <- liftM (fmap DOM.castToHTMLElement) $ getHead doc
53+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
54+ Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
5655 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
5756 Just body <- getBody doc
5857 attachWidget body webViewSing w
@@ -60,7 +59,7 @@ mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $
6059{-# INLINABLE mainWidgetFragment #-}
6160mainWidgetFragment :: (forall x. Widget x ()) -> IO ()
6261mainWidgetFragment w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
63− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView
62+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
6463 Just body <- getBody doc
6564 attachWidgetFragment body webViewSing w
6665
@@ -129,7 +128,7 @@ attachWidgetFragment' rootElement wv w = do
129128 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
130129 return ()
131130 setInnerHTML rootElement $ Just (""::String)
132− appendChild rootElement $ Just df
131+ _ <- appendChild rootElement $ Just df
133132 return (result, fc)
134133
135134data AppInput t = AppInput
@@ -142,7 +141,7 @@ data AppOutput t = AppOutput --TODO: Add quit event
142141
143142runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()
144143runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
145− Just doc <- liftM (fmap DOM.castToHTMLDocument) $ webViewGetDomDocument webView
144+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
146145 Just body <- getBody doc
147146 Just win <- getDefaultView doc
148147 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 #-}
22module Reflex.Dom.PerformEvent.Base where
33
44import Reflex
@@ -25,7 +25,7 @@ import Control.Lens
2525
2626newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
2727
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?
2929
3030newtype PerformEventT t m a = PerformEventT { unPerformEventT :: StateT [Event t (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())] (HostFrame t) a }
3131
@@ -55,7 +55,7 @@ instance (ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t
5555 return [EventTriggerRef reResultTrigger :=> Identity result]
5656 return eResult
5757
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
5959 {-# INLINABLE deletable #-}
6060 deletable d a = PerformEventT $ do
6161 (result, reverseEventsToPerform) <- lift $ runStateT (unPerformEventT a) []
@@ -133,7 +133,7 @@ hostPerformEventT a = do
133133 followupEventTriggerRefs <- runHostFrame toPerform
134134 followupEventTriggers <- forM followupEventTriggerRefs $ \(EventTriggerRef rt :=> x) -> do
135135 mt <- readRef rt
136− return $ fmap (\t -> t :=> x) mt
136+ return $ fmap (:=> x) mt
137137 fmap (result':) $ go $ catMaybes followupEventTriggers
138138 go triggers
139139
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 #-}
22module Reflex.Dom.PerformEvent.Class where
33
44import 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
5050 placeholder cfg = lift $ do
5151 rec childPostBuild <- deletable (_placeholder_deletedSelf p) $ performEvent $ return () <$ _placeholder_insertedAbove p
5252 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
5454 }
5555 return p
5656 {-# INLINABLE inputElement #-}
@@ -113,7 +113,7 @@ instance HasWebView m => HasWebView (PostBuildT t m) where
113113
114114{-# INLINABLE runPostBuildT #-}
115115runPostBuildT :: PostBuildT t m a -> Event t () -> m a
116−runPostBuildT (PostBuildT a) postBuild = runReaderT a postBuild
116+runPostBuildT (PostBuildT a) = runReaderT a
117117
118118instance PostBuild t m => PostBuild t (ReaderT r m) where
119119 getPostBuild = lift getPostBuild
src/Reflex/Dom/Time.hs+3−4
@@ -42,7 +42,7 @@ tickLossyFrom
4242 -- there could be uses for starting multiple timer threads.
4343 -> m (Event t TickInfo)
4444tickLossyFrom dt t0 e = do
45− rec result <- performEventAsync $ fmap callAtNextInterval $ leftmost [() <$ e, () <$ result]
45+ rec result <- performEventAsync $ callAtNextInterval <$> leftmost [() <$ e, () <$ result]
4646 return result
4747 where callAtNextInterval _ cb = void $ liftIO $ forkIO $ do
4848 tick <- getCurrentTick dt t0
@@ -84,8 +84,7 @@ poissonLossyFrom
8484 -- there could be uses for starting multiple timer threads.
8585 -- Start sending events in response to the event parameter.
8686 -> 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
8988
9089
9190-- | Send events with Poisson timing with the given basis and rate
@@ -148,7 +147,7 @@ inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
148147
149148 -- Inter-event interval is drawn from exponential
150149 -- distribution accourding to u
151− let dt = realToFrac $ -1 * log(u)/maxRate :: NominalDiffTime
150+ let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime
152151 nEvents = lastN + 1
153152 alreadyElapsed = diffUTCTime t tTargetLast
154153 tTarget = addUTCTime dt tTargetLast
src/Reflex/Dom/WebSocket.hs+2−4
@@ -38,15 +38,13 @@ data WebSocket t
3838webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m) => Text -> WebSocketConfig t -> m (WebSocket t)
3939webSocket url config = do
4040 wv <- fmap unWebViewSingleton askWebView
41− (eRecv, triggerERecv) <- newTriggerEvent
41+ (eRecv, onMessage) <- newTriggerEvent
4242 currentSocketRef <- liftIO $ newIORef Nothing
4343 --TODO: Disconnect if value no longer needed
4444 (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete
4545 payloadQueue <- liftIO newTQueueIO
4646 isOpen <- liftIO newEmptyTMVarIO
47− let onMessage :: ByteString -> IO ()
48− onMessage m = triggerERecv m
49− onOpen = triggerEOpen () $ do
47+ let onOpen = triggerEOpen () $ do
5048 liftIO $ void $ atomically $ tryPutTMVar isOpen ()
5149 --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
5250 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
2− , module Reflex.Dom.Widget.Input
3− , module Reflex.Dom.Widget.Lazy
4− , module Reflex.Dom.Widget.Resize
5− ) where
1+module Reflex.Dom.Widget (module X) where
62
7−import Reflex.Dom.Widget.Basic
8−import Reflex.Dom.Widget.Input
9−import Reflex.Dom.Widget.Lazy
10−import Reflex.Dom.Widget.Resize
3+import Reflex.Dom.Widget.Basic as X
4+import Reflex.Dom.Widget.Input as X
5+import Reflex.Dom.Widget.Lazy as X
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 #-}
2−
1+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes #-}
32module Reflex.Dom.Widget.Basic where
43
54import Reflex.Dom.Class
@@ -16,6 +15,7 @@ import Data.Set (Set)
1615import qualified Data.Set as Set
1716import Data.Foldable
1817import Data.Traversable
18+import Control.Arrow
1919import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
2020import Control.Lens hiding (element, children)
2121import Data.These
@@ -65,12 +65,12 @@ listHoldWithKey initialChildren modifyChildren buildChild = do
6565 & deleteSelf .~ delete
6666 ph <- placeholder myCfg
6767 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
6969 rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild
7070 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
7272 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
7474 mapDyn (fmap (fst . unChildResult)) augmentedResults
7575
7676text :: DomBuilder t m => Text -> m ()
@@ -101,7 +101,7 @@ dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
101101dyn child = do
102102 postBuild <- getPostBuild
103103 let newChild = leftmost [updated child, tag (current child) postBuild]
104− liftM snd $ widgetHoldInternal (return ()) newChild
104+ snd <$> widgetHoldInternal (return ()) newChild
105105
106106-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
107107-- The returned Dynamic of widget results occurs when the Event does.
@@ -167,7 +167,7 @@ listWithKey' = listWithKeyShallowDiff
167167listWithKeyShallowDiff :: (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))
168168listWithKeyShallowDiff initialVals valsChanged mkChild = do
169169 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
171171 let relevantPatch patch _ = case patch of
172172 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
173173 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
@@ -178,10 +178,10 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do
178178-- | Create a dynamically-changing set of Event-valued widgets.
179179-- 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'.
180180listViewWithKey :: (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
182182
183183listViewWithKey' :: (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
185185
186186-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
187187selectViewListWithKey :: 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
195195 selected <- getDemuxed selectionDemux k
196196 selectSelf <- mkChild k v selected
197197 return $ fmap ((,) k) selectSelf
198− liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
198+ return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
199199
200200selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
201201 => Dynamic t k -- ^ Current selection key
202202 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
203203 -> (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
204204 -> 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
206206
207207{-
208208{-# INLINABLE elWith #-}
@@ -265,7 +265,7 @@ el' elementTag = element elementTag def
265265{-# INLINABLE elAttr' #-}
266266elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
267267elAttr' 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
269269
270270{-# INLINABLE elDynAttr #-}
271271elDynAttr :: 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
276276el elementTag child = snd <$> el' elementTag child
277277
278278elClass :: 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
280280
281281--------------------------------------------------------------------------------
282282-- 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)
325325
326326workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
327327workflow w0 = do
328− rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult
329− mapDyn fst eResult
328+ rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
329+ return $ fmap fst eResult
330330
331331workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
332332workflowView w0 = do
333− rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
334− eReplace <- liftM switch $ hold never $ fmap snd eResult
333+ rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace
334+ eReplace <- fmap switch $ hold never $ fmap snd eResult
335335 return $ fmap fst eResult
336336
337337mapWorkflow :: (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)
339339
340340divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
341341divClass = elClass "div"
@@ -376,9 +376,9 @@ tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuil
376376tabDisplay ulClass activeClass tabItems = do
377377 let t0 = listToMaybe $ Map.keys tabItems
378378 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
380380 let eTabClicks :: Event t k = leftmost tabClicksList
381− liftM demux $ holdDyn t0 $ fmap Just eTabClicks
381+ fmap demux $ holdDyn t0 $ fmap Just eTabClicks
382382 el "div" $ do
383383 iforM_ tabItems $ \k (_, w) -> do
384384 isSelected <- getDemuxed currentTab $ Just k
src/Reflex/Dom/Widget/Input.hs+11−39
@@ -25,7 +25,7 @@ import Control.Monad.IO.Class
2525import GHCJS.DOM.EventM (on)
2626import GHCJS.DOM.Types (File)
2727import qualified GHCJS.DOM.Element as Element
28−import qualified GHCJS.DOM.File as File
28+-- import qualified GHCJS.DOM.File as File
2929import qualified GHCJS.DOM.FileList as FileList
3030
3131
@@ -150,24 +150,6 @@ textArea (TextAreaConfig initial eSet attrs) = do
150150 , _textArea_hasFocus = _textAreaElement_hasFocus i
151151 , _textArea_element = castToHTMLTextAreaElement $ _element_raw $ _textAreaElement_element i
152152 }
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−-}
171153
172154data CheckboxConfig t
173155 = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool
@@ -191,7 +173,7 @@ data Checkbox t
191173checkbox :: (DomBuilder t m, PostBuild t m) => Bool -> CheckboxConfig t -> m (Checkbox t)
192174checkbox checked config = do
193175 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
195177 modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs
196178 i <- inputElement $ def
197179 & inputElementConfig_initialChecked .~ checked
@@ -201,14 +183,6 @@ checkbox checked config = do
201183 return $ Checkbox
202184 { _checkbox_value = _inputElement_checked i
203185 }
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−-}
212186
213187type family CheckboxViewEventResultType (en :: EventTag) :: * where
214188 CheckboxViewEventResultType 'ClickTag = Bool
@@ -297,7 +271,7 @@ checkboxView dAttrs dValue = do
297271 & inputElementConfig_setChecked .~ leftmost [updated dValue, tag (current dValue) postBuild]
298272 & inputElementConfig_elementConfig .~ elementConfig
299273 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)
301275{-
302276 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs
303277 eClicked <- wrapDomEvent e (`on` click) $ do
@@ -326,11 +300,11 @@ fileInput :: forall t m. (MonadIO m, MonadFix m, MonadHold t m, TriggerEvent t m
326300 => FileInputConfig t -> m (FileInput t)
327301fileInput config = do
328302 let insertType = Map.insert "type" "file"
329− dAttrs = fmap insertType $ _fileInputConfig_attributes config
303+ dAttrs = insertType <$> _fileInputConfig_attributes config
330304 modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs
331305 let cfg = (def :: ElementConfig EventResult t m)
332306 { _elementConfig_modifyAttributes = modifyAttrs
333− , _elementConfig_eventFilters = DMap.singleton Change . EventFilter . GhcjsDomHandler $ \(GhcjsDomEvent evt) -> do
307+ , _elementConfig_eventFilters = DMap.singleton Change . EventFilter . GhcjsDomHandler $ \_ -> do
334308 return . (,) mempty . GhcjsDomHandler $ \_ -> return . Just $ EventResult ()
335309 }
336310 (eRaw, _) <- element "input" cfg blank
@@ -338,7 +312,7 @@ fileInput config = do
338312 eChange <- wrapDomEvent e (`on` Element.change) $ do
339313 Just files <- Input.getFiles e
340314 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]
342316 dValue <- holdDyn [] eChange
343317 return $ FileInput
344318 { _fileInput_value = dValue
@@ -447,12 +421,12 @@ dropdown k0 options (DropdownConfig setK attrs) = do
447421 optionAttrs <- mapDyn (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey
448422 elDynAttr "option" optionAttrs $ dynText v
449423 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
451425 let lookupSelected ks value = do
452426 v <- value
453427 key <- T.readMaybe v
454428 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)
456430 let readKey keys mk = fromMaybe k0 $ do
457431 k <- mk
458432 guard $ Bimap.memberR k keys
@@ -460,13 +434,13 @@ dropdown k0 options (DropdownConfig setK attrs) = do
460434 dValue <- combineDyn readKey ixKeys <=< holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]
461435 return $ Dropdown dValue (attachDynWith readKey ixKeys eChange)
462436
463−liftM concat $ mapM makeLenses
437+concat <$> mapM makeLenses
464438 [ ''TextAreaConfig
465439 , ''TextArea
466440 , ''TextInputConfig
467441 , ''TextInput
468−-- , ''FileInputConfig
469−-- , ''FileInput
442+ , ''FileInputConfig
443+ , ''FileInput
470444 , ''DropdownConfig
471445 , ''Dropdown
472446 , ''CheckboxConfig
@@ -489,11 +463,9 @@ instance HasAttributes (CheckboxConfig t) where
489463 type Attrs (CheckboxConfig t) = Dynamic t (Map Text Text)
490464 attributes = checkboxConfig_attributes
491465
492−{-
493466instance HasAttributes (FileInputConfig t) where
494467 type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)
495468 attributes = fileInputConfig_attributes
496−-}
497469
498470class HasSetValue a where
499471 type SetValue a :: *
src/Reflex/Dom/Widget/Lazy.hs+11−9
@@ -49,14 +49,15 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
4949 scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll container
5050 , fmap (const (i0 * rowPx)) pb
5151 ]
52− window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition
52+ window <- combineDyn (findWindow rowPx) heightPx scrollPosition
5353 itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
5454 postBuild <- getPostBuild
55− performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_element_raw container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]
55+ performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i -> do
56+ liftIO $ setScrollTop (_element_raw container) (i * rowPx)
5657 indexAndLength <- mapDyn snd window
5758 return (indexAndLength, sel)
5859 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
6061 toViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>
6162 "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px")
6263 toContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (T.pack (show h) <> "px")
@@ -66,7 +67,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
6667 tagWrapper elTag attrs attrsOverride c = do
6768 attrs' <- combineDyn Map.union attrsOverride attrs
6869 elDynAttr' elTag attrs' c
69− findWindow windowSize sizeIncrement startingPosition =
70+ findWindow sizeIncrement windowSize startingPosition =
7071 let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement
7172 topPx = startingPosition - topOffsetPx
7273 numItems = windowSize `div` sizeIncrement + 1
@@ -94,11 +95,12 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu
9495 scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll viewport
9596 , fmap (const (i0 * rowPx)) pb
9697 ]
97− window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition
98− performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_element_raw viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]
98+ window <- combineDyn (findWindow rowPx) heightPx scrollPosition
99+ performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i -> do
100+ liftIO $ setScrollTop (_element_raw viewport) (i * rowPx)
99101 return (nubDyn window, result)
100102 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
102104 mkViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>
103105 "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px")
104106 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
110112 "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>
111113 "position" =: "absolute" <>
112114 "width" =: "100%"
113− findWindow windowSize sizeIncrement startingPosition =
115+ findWindow sizeIncrement windowSize startingPosition =
114116 let (startingIndex, _) = startingPosition `divMod'` sizeIncrement
115117 numItems = (windowSize + sizeIncrement - 1) `div` sizeIncrement
116118 in (startingIndex, numItems)
@@ -137,6 +139,6 @@ virtualListBuffered buffer heightPx rowPx maxIndex i0 setI keyToIndex items0 ite
137139 then Nothing
138140 else Just (extendWin winOffset winLimit)) (current winBuffered) (updated win)
139141 winBuffered <- holdDyn (0, 0) $ leftmost [ winHitEdge
140− , fmap (uncurry extendWin) $ tagDyn win pb
142+ , attachDynWith (\(x, y) _ -> extendWin x y) win pb
141143 ]
142144 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
3030 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
3131 -> m a -- ^ The embedded widget
3232 -> 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)
3434
3535resizeDetectorWithAttrs :: (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)
3636 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
@@ -68,12 +68,12 @@ resizeDetectorWithAttrs attrs w = do
6868 pow <- getOffsetWidth (_el_element parent)
6969 poh <- getOffsetHeight (_el_element parent)
7070 if ds == (Just pow, Just poh)
71− then return Nothing
72− else liftM Just reset
71+ then return Nothing
72+ else fmap Just reset
7373 pb <- getPostBuild
7474 expandScroll <- wrapDomEvent (_el_element expand) (`on` scroll) $ return ()
7575 shrinkScroll <- wrapDomEvent (_el_element shrink) (`on` scroll) $ return ()
7676 size0 <- performEvent $ fmap (const $ liftIO reset) pb
7777 rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
7878 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
5656import Reflex.Dom.Xhr.ResponseType
5757
5858import Control.Concurrent
59−import Control.Exception (catch)
59+import Control.Exception (handle)
6060import Control.Lens
6161import Control.Monad hiding (forM)
6262import Control.Monad.IO.Class
@@ -134,7 +134,7 @@ newXMLHttpRequestWithError
134134newXMLHttpRequestWithError req cb = do
135135 wv <- askWebView
136136 xhr <- liftIO $ xmlHttpRequestNew $ unWebViewSingleton wv
137− void $ liftIO $ forkIO $ flip catch (cb . Left) $ void $ do
137+ void $ liftIO $ forkIO $ handle (cb . Left) $ void $ do
138138 let c = _xhrRequest_config req
139139 rt = _xhrRequestConfig_responseType c
140140 xmlHttpRequestOpen
@@ -150,20 +150,18 @@ newXMLHttpRequestWithError req cb = do
150150 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
151151 status <- liftIO $ xmlHttpRequestGetStatus xhr
152152 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
153− if readyState == 4
154− then do
155− t <- if rt == Just XhrResponseType_Text || rt == Nothing
156− then liftIO $ xmlHttpRequestGetResponseText xhr
157− else return Nothing
158− r <- liftIO $ xmlHttpRequestGetResponse xhr
159− _ <- liftIO $ cb $ Right $
160− XhrResponse { _xhrResponse_status = status
161− , _xhrResponse_statusText = statusText
162− , _xhrResponse_response = r
163− , _xhrResponse_responseText = t
164− }
165− return ()
166− else return ()
153+ when (readyState == 4) $ do
154+ t <- if rt == Just XhrResponseType_Text || isNothing rt
155+ then liftIO $ xmlHttpRequestGetResponseText xhr
156+ else return Nothing
157+ r <- liftIO $ xmlHttpRequestGetResponse xhr
158+ _ <- liftIO $ cb $ Right $ XhrResponse
159+ { _xhrResponse_status = status
160+ , _xhrResponse_statusText = statusText
161+ , _xhrResponse_response = r
162+ , _xhrResponse_responseText = t
163+ }
164+ return ()
167165 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
168166 return ()
169167 return xhr
@@ -255,7 +253,7 @@ decodeText = decode . BL.fromStrict . encodeUtf8
255253decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
256254decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
257255
258−liftM concat $ mapM makeLenses
256+concat <$> mapM makeLenses
259257 [ ''XhrRequest
260258 , ''XhrRequestConfig
261259 , ''XhrResponse