b10f2ad · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

General cleanup

b10f2adRyan Trinkle12 years ago

src/Reflex/Dom/Class.hs+3−21

compare with develop

unifiedsplit

@@ -7,34 +7,14 @@ import Reflex

7import Reflex.Host.Class

9import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence)

10−import Control.Lens hiding ((<|))

11−import Data.Set (Set)

12−import qualified Data.Set as Set

13import Data.Map (Map)

10import Data.Map (Map)

14import qualified Data.Map as Map

11import qualified Data.Map as Map

15−import Data.Traversable

16import Data.Foldable

12import Data.Foldable

17import Control.Monad.Ref

13import Control.Monad.Ref

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

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

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

15import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)

20−import qualified Data.Dependent.Map as DMap

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

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

22−import Data.IORef

23−import Data.These

24−import Data.Align

25import GHCJS.DOM.Types hiding (Event)

17import GHCJS.DOM.Types hiding (Event)

26−import GHCJS.DOM.Document

27−import GHCJS.DOM.Node

28−import GHCJS.DOM.NamedNodeMap

29−import GHCJS.DOM.Element

30−import GHCJS.DOM.HTMLElement

31−import GHCJS.DOM.HTMLInputElement

32−import GHCJS.DOM.HTMLSelectElement

33−import GHCJS.DOM.HTMLTextAreaElement

34−import GHCJS.DOM.UIEvent

35−import GHCJS.DOM.EventM (event, preventDefault)

36−import Data.Dependent.Map (DMap)

37−import Safe

39-- | Alias for Data.Map.singleton

19-- | Alias for Data.Map.singleton

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

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

@@ -48,7 +28,7 @@ keycodeEscape = 27

49class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m

29class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m

50 , HasDocument m

30 , HasDocument m

51− , MonadIO (WidgetHost m), Functor (WidgetHost m), MonadSample t (WidgetHost m)

31+ , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)

52 , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)

32 , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)

53 , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO

33 , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO

54 , MonadFix m

34 , MonadFix m

@@ -106,8 +86,10 @@ instance MonadWidget t m => MonadWidget t (ReaderT r m) where

106 (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r

86 (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r

107 return (a, postBuild, voidActions)

87 return (a, postBuild, voidActions)

108

89+performEvent_ :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()

109performEvent_ = addVoidAction

90performEvent_ = addVoidAction

110

92+performEvent :: (MonadWidget t m, Ref m ~ Ref IO) => Event t (WidgetHost m a) -> m (Event t a)

111performEvent e = do

93performEvent e = do

112 (eResult, reResultTrigger) <- newEventWithTriggerRef

94 (eResult, reResultTrigger) <- newEventWithTriggerRef

113 addVoidAction $ ffor e $ \o -> do

95 addVoidAction $ ffor e $ \o -> do

src/Reflex/Dom/Internal.hs+14−34

@@ -8,44 +8,25 @@ import Reflex.Dom.Class

8import GHCJS.DOM

9import GHCJS.DOM.Types hiding (Widget, unWidget, Event)

10import GHCJS.DOM.Node

11−import GHCJS.DOM.Element

12import GHCJS.DOM.HTMLElement

11import GHCJS.DOM.HTMLElement

13−import GHCJS.DOM.HTMLInputElement

14−import GHCJS.DOM.NamedNodeMap

15import GHCJS.DOM.Document

12import GHCJS.DOM.Document

16−import GHCJS.DOM.UIEvent

17−import GHCJS.DOM.EventM (event, Signal (..))

18import Reflex.Class

13import Reflex.Class

19−import Reflex.Dynamic

20import Reflex.Host.Class

14import Reflex.Host.Class

21import Reflex.Spider (Spider, SpiderHost (..))

15import Reflex.Spider (Spider, SpiderHost (..))

22−import qualified Reflex.Spider

23import Control.Lens

16import Control.Lens

24−import Control.Applicative

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

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

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

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

27import Control.Monad.Ref

19import Control.Monad.Ref

28import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

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

29−import Data.Map (Map)

30−import qualified Data.Map as Map

31−import Data.Set (Set)

32−import qualified Data.Set as Set

33import Control.Concurrent

21import Control.Concurrent

22+import Data.ByteString (ByteString)

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

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

35−import Data.Dependent.Map (DMap)

36−import qualified Data.Dependent.Map as DMap

37import Data.Foldable

24import Data.Foldable

38import Data.Traversable

25import Data.Traversable

39−import Data.IORef

40−import Data.Align

41−import Data.These

42−import Data.ByteString (ByteString)

43import qualified Data.Text as T

26import qualified Data.Text as T

44import Data.Text.Encoding

27import Data.Text.Encoding

45import Data.Monoid ((<>))

28import Data.Monoid ((<>))

47−import System.IO.Unsafe

48−

49data GuiEnv t h

30data GuiEnv t h

50 = GuiEnv { _guiEnvDocument :: !HTMLDocument

31 = GuiEnv { _guiEnvDocument :: !HTMLDocument

51 , _guiEnvPostGui :: !(h () -> IO ())

32 , _guiEnvPostGui :: !(h () -> IO ())

@@ -134,7 +115,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Widget t m)

134 newEventWithTrigger = lift . newEventWithTrigger

115 newEventWithTrigger = lift . newEventWithTrigger

135

116

136instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO

117instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO

137− , MonadIO m, Functor m

118+ , MonadIO m, MonadIO h, Functor m

138 , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m

119 , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m

139 , MonadFix m

120 , MonadFix m

140 ) => MonadWidget t (Widget t (Gui t h m)) where

121 ) => MonadWidget t (Widget t (Gui t h m)) where

@@ -180,17 +161,19 @@ mainWidget w = runWebGUI $ \webView -> do

180 Just body <- documentGetBody doc

161 Just body <- documentGetBody doc

181 attachWidget body w

162 attachWidget body w

182

163

164+mainWidgetWithHead :: Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()

183mainWidgetWithHead h b = runWebGUI $ \webView -> do

165mainWidgetWithHead h b = runWebGUI $ \webView -> do

184 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView

166 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView

185− Just head <- liftM (fmap castToHTMLElement) $ documentGetHead doc

167+ Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc

186− attachWidget head h

168+ attachWidget headElement h

187 Just body <- documentGetBody doc

169 Just body <- documentGetBody doc

188 attachWidget body b

170 attachWidget body b

189

171

172+mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()

190mainWidgetWithCss css w = runWebGUI $ \webView -> do

173mainWidgetWithCss css w = runWebGUI $ \webView -> do

191 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView

174 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView

192− Just head <- liftM (fmap castToHTMLElement) $ documentGetHead doc

175+ Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc

193− htmlElementSetInnerHTML head $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

176+ htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

194 Just body <- documentGetBody doc

177 Just body <- documentGetBody doc

195 attachWidget body w

178 attachWidget body w

196

179

@@ -201,21 +184,18 @@ attachWidget rootElement w = runSpiderHost $ do --TODO: It seems to re-run this

201 rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost) runWithActions :: GuiEnv Spider SpiderHost

184 rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost) runWithActions :: GuiEnv Spider SpiderHost

202 runWithActions dm = do

185 runWithActions dm = do

203 voidActionNeeded <- fireEventsAndRead dm $ do

186 voidActionNeeded <- fireEventsAndRead dm $ do

204− sequence =<< readEvent voidAction

187+ sequence =<< readEvent voidActionHandle

205 runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv

188 runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv

206 Just df <- liftIO $ documentCreateDocumentFragment doc

189 Just df <- liftIO $ documentCreateDocumentFragment doc

207 (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do

190 (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do

208− (result, postBuild, voidAction) <- runWidget df w

191+ (r, postBuild, va) <- runWidget df w

209 postBuild

192 postBuild

210− return (result, voidAction)

193+ return (r, va)

211 liftIO $ htmlElementSetInnerHTML rootElement ""

194 liftIO $ htmlElementSetInnerHTML rootElement ""

212− liftIO $ nodeAppendChild rootElement $ Just df

195+ _ <- liftIO $ nodeAppendChild rootElement $ Just df

213− subscribeEvent voidAction --TODO: Should be unnecessary

196+ voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary

214−-- currentFrame <- liftIO $ newEmptyMVar

215−-- idleAdd (tryTakeMVar currentFrame >>= maybe (return ()) id >> return True) priorityLow --TODO: avoid wasting CPU here

216−-- forkIO $ forever $ putMVar currentFrame =<< readChan frames

217 --postGUISync seems to leak memory on GHC (unknown on GHCJS)

197 --postGUISync seems to leak memory on GHC (unknown on GHCJS)

218− liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe

198+ _ <- liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe

219 return result

199 return result

220

200

221--type MonadWidget t h m = (t ~ Spider, h ~ Gui Spider SpiderHost (HostFrame Spider), m ~ Widget t h, Monad h, MonadHold t h, HasDocument h, MonadSample t h, MonadRef h, MonadIO h, Functor (Event t), Functor h, Reflex t) -- Locking down these types seems to help a little in GHCJS, but not really in GHC

201--type MonadWidget t h m = (t ~ Spider, h ~ Gui Spider SpiderHost (HostFrame Spider), m ~ Widget t h, Monad h, MonadHold t h, HasDocument h, MonadSample t h, MonadRef h, MonadIO h, Functor (Event t), Functor h, Reflex t) -- Locking down these types seems to help a little in GHCJS, but not really in GHC

src/Reflex/Dom/Widget/Basic.hs+30−31

@@ -14,18 +14,16 @@ import qualified Data.Set as Set

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

15import Control.Monad.Trans

16import Control.Monad.Reader

17−import Control.Monad.State

17+import Control.Monad.State hiding (state)

18−import Control.Monad.Ref

19import GHCJS.DOM.Node

18import GHCJS.DOM.Node

20import GHCJS.DOM.UIEvent

19import GHCJS.DOM.UIEvent

21−import GHCJS.DOM.EventM (event, Signal, EventM)

20+import GHCJS.DOM.EventM (event, EventM)

22import GHCJS.DOM.Document

21import GHCJS.DOM.Document

23import GHCJS.DOM.Element

22import GHCJS.DOM.Element

24import GHCJS.DOM.HTMLElement

23import GHCJS.DOM.HTMLElement

25import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)

24import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)

26import GHCJS.DOM.NamedNodeMap

25import GHCJS.DOM.NamedNodeMap

27−import Control.Lens

26+import Control.Lens hiding (element, children)

28−import Data.Monoid

29import Data.These

27import Data.These

30import Data.Align

28import Data.Align

@@ -121,7 +119,7 @@ dyn child = do

121 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)

119 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)

122 postBuild

120 postBuild

123 Just p <- liftIO $ nodeGetParentNode endPlaceholder

121 Just p <- liftIO $ nodeGetParentNode endPlaceholder

124− liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

122+ _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

125 return ()

123 return ()

126 schedulePostBuild $ do

124 schedulePostBuild $ do

127 c <- sample $ current child

125 c <- sample $ current child

@@ -151,7 +149,7 @@ widgetHold child0 newChild = do

151 case mp of

149 case mp of

152 Nothing -> return () --TODO: Is this right?

150 Nothing -> return () --TODO: Is this right?

153 Just p -> do

151 Just p -> do

154− liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

152+ _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

155 return ()

153 return ()

156 return ()

154 return ()

157 addVoidAction $ ffor newChild $ \c -> do

155 addVoidAction $ ffor newChild $ \c -> do

@@ -163,7 +161,6 @@ widgetHold child0 newChild = do

163listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))

161listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))

164listWithKey vals mkChild = do

162listWithKey vals mkChild = do

165 doc <- askDocument

163 doc <- askDocument

166− startPlaceholder <- text' ""

167 endPlaceholder <- text' ""

164 endPlaceholder <- text' ""

168 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef

165 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef

169 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack

166 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack

@@ -182,9 +179,9 @@ listWithKey vals mkChild = do

182 (result, postBuild, voidAction) <- buildChild df k v

179 (result, postBuild, voidAction) <- buildChild df k v

183 return ((result, voidAction), postBuild)

180 return ((result, voidAction), postBuild)

184 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame

181 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame

185− sequence $ fmap snd initialState

182+ sequence_ $ fmap snd initialState

186 Just p <- liftIO $ nodeGetParentNode endPlaceholder

183 Just p <- liftIO $ nodeGetParentNode endPlaceholder

187− liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

184+ _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

188 return ()

185 return ()

189 addVoidAction $ flip fmap (updated vals) $ \newVals -> do

186 addVoidAction $ flip fmap (updated vals) $ \newVals -> do

190 curState <- sample children

187 curState <- sample children

@@ -202,7 +199,7 @@ listWithKey vals mkChild = do

202 Nothing -> endPlaceholder

199 Nothing -> endPlaceholder

203 Just (_, ((_, (start, _)), _)) -> start

200 Just (_, ((_, (start, _)), _)) -> start

204 Just p <- liftIO $ nodeGetParentNode placeholder

201 Just p <- liftIO $ nodeGetParentNode placeholder

205− liftIO $ nodeInsertBefore p (Just df) (Just placeholder)

202+ _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)

206 return $ Just s

203 return $ Just s

207 These state _ -> do

204 These state _ -> do

208 return $ Just state

205 return $ Just state

@@ -213,7 +210,6 @@ listWithKey vals mkChild = do

213listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

210listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

214listWithKey' initialVals valsChanged mkChild = do

211listWithKey' initialVals valsChanged mkChild = do

215 doc <- askDocument

212 doc <- askDocument

216− startPlaceholder <- text' ""

217 endPlaceholder <- text' ""

213 endPlaceholder <- text' ""

218 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef

214 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef

219-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack

215-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack

@@ -226,12 +222,12 @@ listWithKey' initialVals valsChanged mkChild = do

226 result <- mkChild k v $ select childValChangedSelector $ Const2 k

222 result <- mkChild k v $ select childValChangedSelector $ Const2 k

227 childEnd <- text' ""

223 childEnd <- text' ""

228 return (result, (childStart, childEnd))

224 return (result, (childStart, childEnd))

229− Just df <- liftIO $ documentCreateDocumentFragment doc

225+ Just dfOrig <- liftIO $ documentCreateDocumentFragment doc

230− initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode df) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read

226+ initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode dfOrig) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read

231 children <- holdDyn initialState newChildren

227 children <- holdDyn initialState newChildren

232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children

228 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children

233− Just p <- liftIO $ nodeGetParentNode endPlaceholder

229+ Just pOrig <- liftIO $ nodeGetParentNode endPlaceholder

234− liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

230+ _ <- liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)

235 addVoidAction $ flip fmap valsChanged $ \newVals -> do

231 addVoidAction $ flip fmap valsChanged $ \newVals -> do

236 curState <- sample $ current children

232 curState <- sample $ current children

237 --TODO: Should we remove the parent from the DOM first to avoid reflows?

233 --TODO: Should we remove the parent from the DOM first to avoid reflows?

@@ -246,7 +242,7 @@ listWithKey' initialVals valsChanged mkChild = do

246 let s = (childResult, childVoidAction)

242 let s = (childResult, childVoidAction)

247 modify (>>childPostBuild)

243 modify (>>childPostBuild)

248 Just p <- liftIO $ nodeGetParentNode end

244 Just p <- liftIO $ nodeGetParentNode end

249− liftIO $ nodeInsertBefore p (Just df) (Just end)

245+ _ <- liftIO $ nodeInsertBefore p (Just df) (Just end)

250 return $ Just s

246 return $ Just s

251 That Nothing -> return Nothing -- Deleting non-existent child

247 That Nothing -> return Nothing -- Deleting non-existent child

252 That (Just v) -> do -- Creating new child

248 That (Just v) -> do -- Creating new child

@@ -258,7 +254,7 @@ listWithKey' initialVals valsChanged mkChild = do

258 Nothing -> endPlaceholder

254 Nothing -> endPlaceholder

259 Just (_, ((_, (start, _)), _)) -> start

255 Just (_, ((_, (start, _)), _)) -> start

260 Just p <- liftIO $ nodeGetParentNode placeholder

256 Just p <- liftIO $ nodeGetParentNode placeholder

261− liftIO $ nodeInsertBefore p (Just df) (Just placeholder)

257+ _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)

262 return $ Just s

258 return $ Just s

263 This state -> do -- No change

259 This state -> do -- No change

264 return $ Just state

260 return $ Just state

@@ -273,7 +269,6 @@ listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey'

273listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))

269listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))

274listViewWithKey' vals mkChild = do

270listViewWithKey' vals mkChild = do

275 doc <- askDocument

271 doc <- askDocument

276− startPlaceholder <- text' ""

277 endPlaceholder <- text' ""

272 endPlaceholder <- text' ""

278 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef

273 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef

279 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack

274 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack

@@ -292,9 +287,9 @@ listViewWithKey' vals mkChild = do

292 (result, postBuild, voidAction) <- buildChild df k v

287 (result, postBuild, voidAction) <- buildChild df k v

293 return ((result, voidAction), postBuild)

288 return ((result, voidAction), postBuild)

294 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame

289 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame

295− sequence $ fmap snd initialState

290+ sequence_ $ fmap snd initialState

296 Just p <- liftIO $ nodeGetParentNode endPlaceholder

291 Just p <- liftIO $ nodeGetParentNode endPlaceholder

297− liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

292+ _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

298 return ()

293 return ()

299 addVoidAction $ flip fmap (updated vals) $ \newVals -> do

294 addVoidAction $ flip fmap (updated vals) $ \newVals -> do

300 curState <- sample children

295 curState <- sample children

@@ -312,7 +307,7 @@ listViewWithKey' vals mkChild = do

312 Nothing -> endPlaceholder

307 Nothing -> endPlaceholder

313 Just (_, ((_, (start, _)), _)) -> start

308 Just (_, ((_, (start, _)), _)) -> start

314 Just p <- liftIO $ nodeGetParentNode placeholder

309 Just p <- liftIO $ nodeGetParentNode placeholder

315− liftIO $ nodeInsertBefore p (Just df) (Just placeholder)

310+ _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)

316 return $ Just s

311 return $ Just s

317 These state _ -> do

312 These state _ -> do

318 return $ Just state

313 return $ Just state

@@ -336,6 +331,7 @@ selectViewListWithKey_ selection vals mkChild = do

336--------------------------------------------------------------------------------

331--------------------------------------------------------------------------------

337

332

338-- | s and e must both be children of the same node and s must precede e

333-- | s and e must both be children of the same node and s must precede e

334+deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()

339deleteBetweenExclusive s e = do

335deleteBetweenExclusive s e = do

340 mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

336 mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

341 case mCurrentParent of

337 case mCurrentParent of

@@ -344,19 +340,21 @@ deleteBetweenExclusive s e = do

344 let go = do

340 let go = do

345 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first

341 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first

346 when (unNode (toNode s) /= unNode (toNode x)) $ do

342 when (unNode (toNode s) /= unNode (toNode x)) $ do

347− nodeRemoveChild currentParent $ Just x

343+ _ <- nodeRemoveChild currentParent $ Just x

348 go

344 go

349 go

345 go

350

346

351-- | s and e must both be children of the same node and s must precede e

347-- | s and e must both be children of the same node and s must precede e

348+deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()

352deleteBetweenInclusive s e = do

349deleteBetweenInclusive s e = do

353 Just currentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

350 Just currentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

354 let go = do

351 let go = do

355 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first

352 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first

356− nodeRemoveChild currentParent $ Just x

353+ _ <- nodeRemoveChild currentParent $ Just x

357 when (unNode (toNode s) /= unNode (toNode x)) go

354 when (unNode (toNode s) /= unNode (toNode x)) go

358 go

355 go

359− nodeRemoveChild currentParent $ Just e

356+ _ <- nodeRemoveChild currentParent $ Just e

357+ return ()

360

358

361--------------------------------------------------------------------------------

359--------------------------------------------------------------------------------

362-- Adapters

360-- Adapters

@@ -398,7 +396,7 @@ elAttr elementTag attrs child = do

398

396

399{-# INLINABLE el' #-}

397{-# INLINABLE el' #-}

400el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)

398el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)

401−el' tag child = elAttr' tag (Map.empty :: AttributeMap) child

399+el' elementTag child = elAttr' elementTag (Map.empty :: AttributeMap) child

402

400

403{-# INLINABLE elAttr' #-}

401{-# INLINABLE elAttr' #-}

404elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)

402elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)

@@ -415,15 +413,16 @@ elDynAttr elementTag attrs child = do

415

413

416{-# INLINABLE el #-}

414{-# INLINABLE el #-}

417el :: forall t m a. MonadWidget t m => String -> m a -> m a

415el :: forall t m a. MonadWidget t m => String -> m a -> m a

418−el tag child = elAttr tag Map.empty child

416+el elementTag child = elAttr elementTag Map.empty child

419

417

420elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a

418elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a

421−elClass tag c child = elAttr tag ("class" =: c) child

419+elClass elementTag c child = elAttr elementTag ("class" =: c) child

422

420

423--------------------------------------------------------------------------------

421--------------------------------------------------------------------------------

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

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

425--------------------------------------------------------------------------------

423--------------------------------------------------------------------------------

426

424

425+list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))

427list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

426list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

428

427

429elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)

428elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)

@@ -492,7 +491,7 @@ tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) => String ->

492tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do

491tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do

493 elAttr "table" (Map.singleton "class" klass) $ do

492 elAttr "table" (Map.singleton "class" klass) $ do

494 el "thead" $ el "tr" $ do

493 el "thead" $ el "tr" $ do

495− mapM (\(h, _) -> el "th" $ text h) cols

494+ mapM_ (\(h, _) -> el "th" $ text h) cols

496 el "tbody" $ do

495 el "tbody" $ do

497 listWithKey dRows (\k r -> do

496 listWithKey dRows (\k r -> do

498 dAttrs <- rowAttrs k

497 dAttrs <- rowAttrs k

@@ -508,7 +507,7 @@ tabDisplay ulClass activeClass tabItems = do

508 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))

507 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))

509 divClass "" $ do

508 divClass "" $ do

510 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems

509 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems

511− listWithKey dTabs (\k dTab -> do

510+ _ <- listWithKey dTabs (\k dTab -> do

512 dAttrs <- mapDyn (\sel -> do

511 dAttrs <- mapDyn (\sel -> do

513 let t1 = listToMaybe $ Map.keys tabItems

512 let t1 = listToMaybe $ Map.keys tabItems

514 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab

513 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab

@@ -526,5 +525,5 @@ tabDisplay ulClass activeClass tabItems = do

526unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)

525unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)

527unsafePlaceElement e = do

526unsafePlaceElement e = do

528 p <- askParent

527 p <- askParent

529− liftIO $ nodeAppendChild p $ Just e

528+ _ <- liftIO $ nodeAppendChild p $ Just e

530 wrapElement e

529 wrapElement e

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

@@ -1,18 +1,15 @@

1{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, DataKinds, GADTs, ScopedTypeVariables, FlexibleInstances, RecursiveDo #-}

2module Reflex.Dom.Widget.Input where

4−import Prelude hiding (forM_)

4+import Prelude

6import Reflex.Dom.Class

7import Reflex.Dom.Widget.Basic

9import Reflex

10import Reflex.Host.Class

11−import Data.Map (Map)

12−import GHCJS.DOM.Document

13import GHCJS.DOM.HTMLInputElement

11import GHCJS.DOM.HTMLInputElement

14import GHCJS.DOM.HTMLTextAreaElement

12import GHCJS.DOM.HTMLTextAreaElement

15−import GHCJS.DOM.Node

16import GHCJS.DOM.Element

13import GHCJS.DOM.Element

17import GHCJS.DOM.HTMLSelectElement

14import GHCJS.DOM.HTMLSelectElement

18import GHCJS.DOM.EventM

15import GHCJS.DOM.EventM

@@ -21,7 +18,6 @@ import Data.Monoid

21import Data.Map as Map

18import Data.Map as Map

22import Control.Monad hiding (forM_)

19import Control.Monad hiding (forM_)

23import Control.Monad.IO.Class

20import Control.Monad.IO.Class

24−import Control.Lens

25import Data.Default

21import Data.Default

26import Data.Maybe

22import Data.Maybe

27import Safe

23import Safe

@@ -116,6 +112,7 @@ data TextArea t

116textArea :: MonadWidget t m => String -> Event t String -> Dynamic t (Map String String) -> m (TextArea t)

112textArea :: MonadWidget t m => String -> Event t String -> Dynamic t (Map String String) -> m (TextArea t)

117textArea initial eSet attrs = do

113textArea initial eSet attrs = do

118 e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs

114 e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs

115+ liftIO $ htmlTextAreaElementSetValue e initial

119 postGui <- askPostGui

116 postGui <- askPostGui

120 runWithActions <- askRunWithActions

117 runWithActions <- askRunWithActions

121 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

118 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

src/Reflex/Dom/Xhr.hs+5−7

@@ -3,7 +3,6 @@ module Reflex.Dom.Xhr where

4#ifdef __GHCJS__

5import Control.Concurrent

6−import Control.Concurrent.MVar

7import Control.Lens

6import Control.Lens

8import Control.Monad

7import Control.Monad

9import Control.Monad.IO.Class

8import Control.Monad.IO.Class

@@ -14,7 +13,6 @@ import Data.Map (Map)

14import qualified Data.Map as Map

13import qualified Data.Map as Map

15import Data.Maybe

14import Data.Maybe

16import Data.Text (Text)

15import Data.Text (Text)

17−import qualified Data.Text as T

18import Data.Text.Encoding

16import Data.Text.Encoding

19import GHCJS.Foreign

17import GHCJS.Foreign

20import GHCJS.Types

18import GHCJS.Types

@@ -62,9 +60,9 @@ newXMLHttpRequest req cb = do

62 True

60 True

63 (fromMaybe "" $ _xhrRequestConfig_user c)

61 (fromMaybe "" $ _xhrRequestConfig_user c)

64 (fromMaybe "" $ _xhrRequestConfig_password c)

62 (fromMaybe "" $ _xhrRequestConfig_password c)

65− iforM (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

63+ iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

66 maybe (return ()) (xmlHttpRequestSetResponseType xhr . toJSString) (_xhrRequestConfig_responseType c)

64 maybe (return ()) (xmlHttpRequestSetResponseType xhr . toJSString) (_xhrRequestConfig_responseType c)

67− xmlHttpRequestOnreadystatechange xhr $ do

65+ _ <- xmlHttpRequestOnreadystatechange xhr $ do

68 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

66 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

69 if readyState == 4

67 if readyState == 4

70 then do

68 then do

@@ -77,15 +75,15 @@ newXMLHttpRequest req cb = do

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

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

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

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

80− liftIO $ newXMLHttpRequest r cb

78+ _ <- liftIO $ newXMLHttpRequest r cb

81 return ()

79 return ()

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

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

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

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

85− liftIO $ do

83+ _ <- liftIO $ do

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

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

87 resp <- newEmptyMVar

85 resp <- newEmptyMVar

88− newXMLHttpRequest r $ putMVar resp

86+ _ <- newXMLHttpRequest r $ putMVar resp

89 return resp

87 return resp

90 forkIO $ cb =<< forM resps takeMVar

88 forkIO $ cb =<< forM resps takeMVar

91 return ()

89 return ()