@@ -36,6 +36,7 @@ import Data.Functor.Misc
3636import qualified Data.Map as Map
3737import Data.Monoid
3838import qualified Data.Set as Set
39+import Data.Text (Text)
3940import Data.Text.Encoding
4041import Data.Tuple
4142import GHC.Generics
@@ -50,10 +51,17 @@ import Reflex.PostBuild.Base
5051import Reflex.Spider
5152import Reflex.TriggerEvent.Class
5253
53−data StaticDomBuilderEnv = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool }
54+data StaticDomBuilderEnv t = StaticDomBuilderEnv
55+ { _staticDomBuilderEnv_shouldEscape :: Bool
56+ , _staticDomBuilderEnv_selectValue :: Maybe (Behavior t Text)
57+ -- ^ When the parent element is a "select" whose value has been set, this value tells us the current value.
58+ -- We use this to add a "selected" attribute to the appropriate "option" child element.
59+ -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.
60+ -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.
61+ }
5462
5563newtype StaticDomBuilderT t m a = StaticDomBuilderT
56− { unStaticDomBuilderT :: ReaderT StaticDomBuilderEnv (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order
64+ { unStaticDomBuilderT :: ReaderT (StaticDomBuilderEnv t) (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order
5765 }
5866 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
5967
@@ -64,7 +72,7 @@ instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where
6472instance MonadTrans (StaticDomBuilderT t) where
6573 lift = StaticDomBuilderT . lift . lift
6674
67−runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv -> m (a, Behavior t Builder)
75+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv t -> m (a, Behavior t Builder)
6876runStaticDomBuilderT (StaticDomBuilderT a) e = do
6977 (result, a') <- runStateT (runReaderT a e) []
7078 return (result, mconcat $ reverse a')
@@ -181,14 +189,21 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
181189 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
182190 StaticDomBuilderT $ do
183191 let shouldEscape = elementTag `Set.notMember` noEscapeElements
184− (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape
192+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing
185193 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
186− let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
194+ selectValue <- asks _staticDomBuilderEnv_selectValue
195+ let addSelectedAttr attrs sel = case Map.lookup "value" attrs of
196+ Just v | v == sel -> attrs <> Map.singleton "selected" ""
197+ _ -> Map.delete "selected" attrs
198+ let attrs1 = case (elementTag, selectValue) of
199+ ("option", Just sv) -> pull $ addSelectedAttr <$> sample (current attrs0) <*> sample sv
200+ _ -> current attrs0
201+ let attrs2 = ffor attrs1 $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
187202 let tagBS = encodeUtf8 elementTag
188203 if Set.member elementTag voidElements
189− then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString " />")]
204+ then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString " />")]
190205 else do
191− let open = mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString ">")]
206+ let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]
192207 let close = constant $ byteString $ "</" <> tagBS <> ">"
193208 modify $ (:) $ mconcat [open, innerHtml, close]
194209 return (Element es (), result)
@@ -222,8 +237,11 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
222237 , _textAreaElement_raw = ()
223238 }
224239 selectElement cfg child = do
225− (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) child
226240 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
241+ (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do
242+ (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)
243+ StaticDomBuilderT $ lift $ modify $ (:) innerHtml
244+ return a
227245 let wrapped = SelectElement
228246 { _selectElement_value = v
229247 , _selectElement_change = never
@@ -243,7 +261,7 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)
243261renderStatic w = do
244262 runSpiderHost $ do
245263 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
246− let env0 = StaticDomBuilderEnv True
264+ let env0 = StaticDomBuilderEnv True Nothing
247265 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
248266 mPostBuildTrigger <- readRef postBuildTriggerRef
249267 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()