git.iko.soy/reflex-dom
on develop help sign in
Handle selectElement selected option in static builder.
700f480Luigy Leon
src/Reflex/Dom/Builder/Static.hs+23−9
compare with develop
unifiedsplit
@@ -36,6 +36,7 @@ import Data.Functor.Misc
36import qualified Data.Map as Map
36import qualified Data.Map as Map
37import Data.Monoid
37import Data.Monoid
38import qualified Data.Set as Set
38import qualified Data.Set as Set
39+import Data.Text (Text)
39import Data.Text.Encoding
40import Data.Text.Encoding
40import Data.Tuple
41import Data.Tuple
41import GHC.Generics
42import GHC.Generics
@@ -50,10 +51,13 @@ import Reflex.PostBuild.Base
50import Reflex.Spider
51import Reflex.Spider
51import Reflex.TriggerEvent.Class
52import Reflex.TriggerEvent.Class
52
53
53−data StaticDomBuilderEnv = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool }
54+data StaticDomBuilderEnv t = StaticDomBuilderEnv
55+ { _staticDomBuilderEnv_shouldEscape :: Bool
56+ , _staticDomBuilderEnv_selectValue :: Maybe (Dynamic t Text)
57+ }
54
58
55newtype StaticDomBuilderT t m a = StaticDomBuilderT
59newtype StaticDomBuilderT t m a = StaticDomBuilderT
56− { unStaticDomBuilderT :: ReaderT StaticDomBuilderEnv (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order
60+ { unStaticDomBuilderT :: ReaderT (StaticDomBuilderEnv t) (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order
57 }
61 }
58 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
62 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
59
63
@@ -64,7 +68,7 @@ instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where
64instance MonadTrans (StaticDomBuilderT t) where
68instance MonadTrans (StaticDomBuilderT t) where
65 lift = StaticDomBuilderT . lift . lift
69 lift = StaticDomBuilderT . lift . lift
66
70
67−runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv -> m (a, Behavior t Builder)
71+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv t -> m (a, Behavior t Builder)
68runStaticDomBuilderT (StaticDomBuilderT a) e = do
72runStaticDomBuilderT (StaticDomBuilderT a) e = do
69 (result, a') <- runStateT (runReaderT a e) []
73 (result, a') <- runStateT (runReaderT a e) []
70 return (result, mconcat $ reverse a')
74 return (result, mconcat $ reverse a')
@@ -181,14 +185,21 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
181 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
185 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
182 StaticDomBuilderT $ do
186 StaticDomBuilderT $ do
183 let shouldEscape = elementTag `Set.notMember` noEscapeElements
187 let shouldEscape = elementTag `Set.notMember` noEscapeElements
184− (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape
188+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing
185 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
189 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
190+ selectValue <- asks _staticDomBuilderEnv_selectValue
191+ let addSelectedAttr attrs sel = case Map.lookup "value" attrs of
192+ Just v | v == sel -> attrs <> Map.singleton "selected" ""
193+ _ -> Map.delete "selected" attrs
194+ let attrs1 = case selectValue of
195+ Nothing -> attrs0
196+ Just sv -> zipDynWith addSelectedAttr attrs0 sv
186− let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
197+ let attrs2 = ffor (current attrs1) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
187 let tagBS = encodeUtf8 elementTag
198 let tagBS = encodeUtf8 elementTag
188 if Set.member elementTag voidElements
199 if Set.member elementTag voidElements
189− then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString " />")]
200+ then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString " />")]
190 else do
201 else do
191− let open = mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString ">")]
202+ let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]
192 let close = constant $ byteString $ "</" <> tagBS <> ">"
203 let close = constant $ byteString $ "</" <> tagBS <> ">"
193 modify $ (:) $ mconcat [open, innerHtml, close]
204 modify $ (:) $ mconcat [open, innerHtml, close]
194 return (Element es (), result)
205 return (Element es (), result)
@@ -222,8 +233,11 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
222 , _textAreaElement_raw = ()
233 , _textAreaElement_raw = ()
223 }
234 }
224 selectElement cfg child = do
235 selectElement cfg child = do
225− (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) child
226 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
236 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
237+ (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do
238+ (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False (Just v)
239+ StaticDomBuilderT $ lift $ modify $ (:) innerHtml
240+ return a
227 let wrapped = SelectElement
241 let wrapped = SelectElement
228 { _selectElement_value = v
242 { _selectElement_value = v
229 , _selectElement_change = never
243 , _selectElement_change = never
@@ -243,7 +257,7 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)
243renderStatic w = do
257renderStatic w = do
244 runSpiderHost $ do
258 runSpiderHost $ do
245 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
259 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
246− let env0 = StaticDomBuilderEnv True
260+ let env0 = StaticDomBuilderEnv True Nothing
247 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
261 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
248 mPostBuildTrigger <- readRef postBuildTriggerRef
262 mPostBuildTrigger <- readRef postBuildTriggerRef
249 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
263 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()