@@ -23,7 +23,7 @@ import Control.Monad.Identity
2323import Control.Monad.Primitive
2424import Control.Monad.Ref
2525import Control.Monad.State.Strict
26−import Control.Monad.Trans.Control
26+import Control.Monad.Trans.Reader
2727import Data.ByteString (ByteString)
2828import Data.ByteString.Builder (Builder, byteString, toLazyByteString)
2929import qualified Data.ByteString.Lazy as LBS
@@ -50,8 +50,10 @@ import Reflex.PostBuild.Base
5050import Reflex.Spider
5151import Reflex.TriggerEvent.Class
5252
53+data StaticDomBuilderEnv = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool }
54+
5355newtype StaticDomBuilderT t m a = StaticDomBuilderT
54− { unStaticDomBuilderT :: StateT [Behavior t Builder] m a -- Accumulated Html will be in reversed order
56+ { unStaticDomBuilderT :: ReaderT StaticDomBuilderEnv (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order
5557 }
5658 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
5759
@@ -59,17 +61,12 @@ instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where
5961 type PrimState (StaticDomBuilderT x m) = PrimState m
6062 primitive = lift . primitive
6163
62−instance MonadTransControl (StaticDomBuilderT t) where
63− type StT (StaticDomBuilderT t) a = StT (StateT [Behavior t Builder]) a
64− liftWith = defaultLiftWith StaticDomBuilderT unStaticDomBuilderT
65− restoreT = defaultRestoreT StaticDomBuilderT
66−
6764instance MonadTrans (StaticDomBuilderT t) where
68− lift = StaticDomBuilderT . lift
65+ lift = StaticDomBuilderT . lift . lift
6966
70−runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> m (a, Behavior t Builder)
71−runStaticDomBuilderT (StaticDomBuilderT a) = do
72− (result, a') <- runStateT a []
67+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv -> m (a, Behavior t Builder)
68+runStaticDomBuilderT (StaticDomBuilderT a) e = do
69+ (result, a') <- runStateT (runReaderT a e) []
7370 return (result, mconcat $ reverse a')
7471
7572instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where
@@ -140,14 +137,16 @@ instance DomSpace StaticDomSpace where
140137
141138instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where
142139 runWithReplace a0 a' = do
143− (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0) (runStaticDomBuilderT <$> a')
140+ e <- StaticDomBuilderT ask
141+ (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
144142 o <- hold (snd result0) $ snd <$> result'
145143 StaticDomBuilderT $ modify $ (:) $ join o
146144 return (fst result0, fst <$> result')
147145 sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do
148− let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v)) dm0
146+ e <- StaticDomBuilderT ask
147+ let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v e)) dm0
149148 loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
150− mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap swap . runStaticDomBuilderT) mv)) p
149+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap swap . flip runStaticDomBuilderT e) mv)) p
151150 (children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
152151 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
153152 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
@@ -169,24 +168,27 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
169168 {-# INLINABLE textNode #-}
170169 textNode (TextNodeConfig initialContents setContents) = StaticDomBuilderT $ do
171170 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
172− let escape = fromHtmlEscapedText
171+ shouldEscape <- asks _staticDomBuilderEnv_shouldEscape
172+ let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8
173173 modify . (:) <=< hold (escape initialContents) $ fmap escape setContents
174174 return $ TextNode ()
175175 {-# INLINABLE element #-}
176176 element elementTag cfg child = do
177177 -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements
178178 let voidElements = Set.fromList ["area", "base", "br", "col", "command", "embed", "hr", "img", "input", "keygen", "link", "meta", "param", "source", "track", "wbr"]
179+ let noEscapeElements = Set.fromList ["style", "script"]
179180 let toAttr (AttributeName _mns k) v = byteString (encodeUtf8 k) <> byteString "=\"" <> fromHtmlEscapedText v <> byteString "\""
180181 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
181182 StaticDomBuilderT $ do
182− (result, innerHtml) <- lift $ runStaticDomBuilderT child
183+ let shouldEscape = elementTag `Set.notMember` noEscapeElements
184+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape
183185 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
184186 let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
185187 let tagBS = encodeUtf8 elementTag
186188 if Set.member elementTag voidElements
187189 then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString " />")]
188190 else do
189− let open = mconcat [constant ("<" <> byteString tagBS <> " "), attrs1, constant (byteString ">")]
191+ let open = mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString ">")]
190192 let close = constant $ byteString $ "</" <> tagBS <> ">"
191193 modify $ (:) $ mconcat [open, innerHtml, close]
192194 return (Element es (), result)
@@ -241,7 +243,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)
241243renderStatic w = do
242244 runSpiderHost $ do
243245 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
244− ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild)
246+ let env0 = StaticDomBuilderEnv True
247+ ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
245248 mPostBuildTrigger <- readRef postBuildTriggerRef
246249 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
247250 bs' <- sample bs