4565246 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add commentNode to DomBuilder

commit4565246c281d5e14ad2beb2aa2136162cbbef380 authorTom Smalley <tfsmalley@gmail.com> dateWed 31 Oct 2018, 17:11 (8 years ago) parent8bde2d7

3 files changed+57−1

compare with develop

unifiedsplit

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

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

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

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

6767 type RawDocument d :: *

6868 type RawTextNode d :: *

69+ type RawCommentNode d :: *

6970 type RawElement d :: *

7071 type RawFile d :: *

7172 type RawInputElement d :: *

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

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

8788 textNode = lift . textNode

8889 {-# 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 #-}

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

90100 default element :: ( MonadTransControl f

91101 , StT f a ~ a

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

175185 { _textNode_raw :: RawTextNode d

176186 }

177187

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+

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

179211

180212mapKeysToAttributeName :: 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)

129129import qualified Data.Some as Some

130130import Data.Text (Text)

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

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

134134import qualified GHCJS.DOM.Element as Element

135135import qualified GHCJS.DOM.Event as Event

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

257257 append $ toNode n

258258 return n

259259

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+

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

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

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

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

384392 type EventSpec GhcjsDomSpace = GhcjsEventSpec

385393 type RawDocument GhcjsDomSpace = DOM.Document

386394 type RawTextNode GhcjsDomSpace = DOM.Text

395+ type RawCommentNode GhcjsDomSpace = DOM.Comment

387396 type RawElement GhcjsDomSpace = DOM.Element

388397 type RawFile GhcjsDomSpace = DOM.File

389398 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement

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

462471 n <- textNodeInternal initialContents

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

464473 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

465479 {-# INLINABLE element #-}

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

467481 {-# INLINABLE inputElement #-}

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

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

141141 type EventSpec StaticDomSpace = StaticEventSpec

142142 type RawDocument StaticDomSpace = ()

143143 type RawTextNode StaticDomSpace = ()

144+ type RawCommentNode StaticDomSpace = ()

144145 type RawElement StaticDomSpace = ()

145146 type RawFile StaticDomSpace = ()

146147 type RawInputElement StaticDomSpace = ()

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

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

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

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

213223 {-# INLINABLE element #-}

214224 element elementTag cfg child = do

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