4565246 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Add commentNode to DomBuilder

4565246Tom Smalley8 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+32

compare with develop

unifiedsplit

@@ -66,6 +66,7 @@ class Default (EventSpec d EventResult) => DomSpace d where

66 type EventSpec d :: (EventTag -> *) -> *

67 type RawDocument d :: *

68 type RawTextNode d :: *

69+ type RawCommentNode d :: *

69 type RawElement d :: *

70 type RawElement d :: *

70 type RawFile d :: *

71 type RawFile d :: *

71 type RawInputElement d :: *

72 type RawInputElement d :: *

@@ -86,6 +87,15 @@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), NotReady t m, Adjustable

86 => TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

87 => TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

87 textNode = lift . textNode

88 textNode = lift . textNode

88 {-# INLINABLE textNode #-}

89 {-# INLINABLE textNode #-}

90+ commentNode :: CommentNodeConfig t -> m (CommentNode (DomBuilderSpace m) t)

91+ default commentNode :: ( MonadTrans f

92+ , m ~ f m'

93+ , DomBuilderSpace m' ~ DomBuilderSpace m

94+ , DomBuilder t m'

95+ )

96+ => CommentNodeConfig t -> m (CommentNode (DomBuilderSpace m) t)

97+ commentNode = lift . commentNode

98+ {-# INLINABLE commentNode #-}

89 element :: Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)

99 element :: Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)

90 default element :: ( MonadTransControl f

100 default element :: ( MonadTransControl f

91 , StT f a ~ a

101 , StT f a ~ a

@@ -175,6 +185,28 @@ newtype TextNode d t = TextNode

175 { _textNode_raw :: RawTextNode d

185 { _textNode_raw :: RawTextNode d

176 }

186 }

177

187

188+data CommentNodeConfig t

189+ = CommentNodeConfig { _commentNodeConfig_initialContents :: {-# UNPACK #-} !Text

190+ , _commentNodeConfig_setContents :: !(Maybe (Event t Text))

191+ }

192+

193+#ifndef USE_TEMPLATE_HASKELL

194+commentNodeConfig_initialContents :: Lens' (CommentNodeConfig t) Comment

195+commentNodeConfig_initialContents f (CommentNodeConfig a b) = (\a' -> CommentNodeConfig a' b) <$> f a

196+{-# INLINE commentNodeConfig_initialContents #-}

197+#endif

198+

199+instance (Reflex t) => Default (CommentNodeConfig t) where

200+ {-# INLINABLE def #-}

201+ def = CommentNodeConfig

202+ { _commentNodeConfig_initialContents = mempty

203+ , _commentNodeConfig_setContents = Nothing

204+ }

205+

206+newtype CommentNode d t = CommentNode

207+ { _commentNode_raw :: RawCommentNode d

208+ }

209+

178data AttributeName = AttributeName !(Maybe Namespace) !Text deriving (Show, Read, Eq, Ord)

210data AttributeName = AttributeName !(Maybe Namespace) !Text deriving (Show, Read, Eq, Ord)

179

211

180mapKeysToAttributeName :: Map Text v -> Map AttributeName v

212mapKeysToAttributeName :: Map Text v -> Map AttributeName v

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+15−1

@@ -129,7 +129,7 @@ import Data.Some (Some)

129import qualified Data.Some as Some

130import Data.Text (Text)

131import qualified GHCJS.DOM as DOM

132−import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)

132+import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

133import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

134import qualified GHCJS.DOM.Element as Element

135import qualified GHCJS.DOM.Event as Event

@@ -257,6 +257,14 @@ textNodeInternal !t = do

257 append $ toNode n

258 return n

259

260+{-# INLINABLE commentNodeInternal #-}

261+commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Comment

262+commentNodeInternal !t = do

263+ doc <- askDocument

264+ n <- liftJSM $ createComment doc t

265+ append $ toNode n

266+ return n

267+

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

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

261-- all nodes between s and e will be removed, but s and e will not be removed

269-- all nodes between s and e will be removed, but s and e will not be removed

262deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

270deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

@@ -384,6 +392,7 @@ instance DomSpace GhcjsDomSpace where

384 type EventSpec GhcjsDomSpace = GhcjsEventSpec

392 type EventSpec GhcjsDomSpace = GhcjsEventSpec

385 type RawDocument GhcjsDomSpace = DOM.Document

393 type RawDocument GhcjsDomSpace = DOM.Document

386 type RawTextNode GhcjsDomSpace = DOM.Text

394 type RawTextNode GhcjsDomSpace = DOM.Text

395+ type RawCommentNode GhcjsDomSpace = DOM.Comment

387 type RawElement GhcjsDomSpace = DOM.Element

396 type RawElement GhcjsDomSpace = DOM.Element

388 type RawFile GhcjsDomSpace = DOM.File

397 type RawFile GhcjsDomSpace = DOM.File

389 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement

398 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement

@@ -462,6 +471,11 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

462 n <- textNodeInternal initialContents

471 n <- textNodeInternal initialContents

463 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

472 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

464 return $ TextNode n

473 return $ TextNode n

474+ {-# INLINABLE commentNode #-}

475+ commentNode (CommentNodeConfig initialContents mSetContents) = do

476+ n <- commentNodeInternal initialContents

477+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

478+ return $ CommentNode n

465 {-# INLINABLE element #-}

479 {-# INLINABLE element #-}

466 element elementTag cfg child = fst <$> makeElement elementTag cfg child

480 element elementTag cfg child = fst <$> makeElement elementTag cfg child

467 {-# INLINABLE inputElement #-}

481 {-# INLINABLE inputElement #-}

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+10

@@ -141,6 +141,7 @@ instance DomSpace StaticDomSpace where

141 type EventSpec StaticDomSpace = StaticEventSpec

142 type RawDocument StaticDomSpace = ()

143 type RawTextNode StaticDomSpace = ()

144+ type RawCommentNode StaticDomSpace = ()

144 type RawElement StaticDomSpace = ()

145 type RawElement StaticDomSpace = ()

145 type RawFile StaticDomSpace = ()

146 type RawFile StaticDomSpace = ()

146 type RawInputElement StaticDomSpace = ()

147 type RawInputElement StaticDomSpace = ()

@@ -210,6 +211,15 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

210 Nothing -> return (pure (escape initialContents))

211 Nothing -> return (pure (escape initialContents))

211 Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on

212 Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on

212 return $ TextNode ()

213 return $ TextNode ()

214+ {-# INLINABLE commentNode #-}

215+ commentNode (CommentNodeConfig initialContents mSetContents) = StaticDomBuilderT $ do

216+ --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5

217+ shouldEscape <- asks _staticDomBuilderEnv_shouldEscape

218+ let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8

219+ modify . (:) =<< (\c -> "") <$> case mSetContents of

220+ Nothing -> return (pure (escape initialContents))

221+ Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on

222+ return $ CommentNode ()

213 {-# INLINABLE element #-}

223 {-# INLINABLE element #-}

214 element elementTag cfg child = do

224 element elementTag cfg child = do

215 -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements

225 -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements