68e10ee · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add selectElement primitive; various other cleanup

commit68e10ee7e368ac42b397d6efb898be2606712b00 authorRyan Trinkle <ryan.trinkle@gmail.com> dateTue 16 Aug 2016, 20:43 (10 years ago) parentd8cb71e

6 files changed+213−113

compare with develop

unifiedsplit

src/Reflex/Dom/Builder/Class.hs+127−39 src/Reflex/Dom/Builder/Immediate.hs+39−8 src/Reflex/Dom/Builder/Static.hs+13−1 src/Reflex/Dom/Old.hs+2−2 src/Reflex/Dom/Widget/Basic.hs+2−28 src/Reflex/Dom/Widget/Input.hs+30−35

src/Reflex/Dom/Builder/Class.hs+127−39

@@ -41,6 +41,7 @@ import Data.Map (Map)

4141import qualified Data.Map as Map

4242import Data.Proxy

4343import Data.Semigroup

44+import Data.String

4445import Data.Text (Text)

4546import Data.Traversable

4647import Data.Type.Coercion

@@ -52,20 +53,97 @@ class Default (EventSpec d EventResult) => DomSpace d where

5253 type RawElement d :: *

5354 type RawInputElement d :: *

5455 type RawTextAreaElement d :: *

56+ type RawSelectElement d :: *

5557 addEventSpecFlags :: proxy d -> EventName en -> (Maybe (er en) -> EventFlags) -> EventSpec d er -> EventSpec d er

5658

57−-- | @'DomBuildek' t m@ indicates that @m@ is a 'Monad' capable of building dynamic DOM in the 'Reflex' timeline @t@

59+{-# INLINABLE liftElementConfig #-}

60+liftElementConfig :: (DomBuilderSpace (f m) ~ DomBuilderSpace m) => ElementConfig er t (f m) -> ElementConfig er t m

61+liftElementConfig cfg = cfg

62+ { _elementConfig_eventSpec = _elementConfig_eventSpec cfg

63+ }

64+

65+-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building

66+-- dynamic DOM in the 'Reflex' timeline @t@

5867class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBuilder t m | m -> t where

5968 type DomBuilderSpace m :: *

6069 textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

70+ default textNode :: ( MonadTrans f

71+ , m ~ f m'

72+ , DomBuilderSpace m' ~ DomBuilderSpace m

73+ , DomBuilder t m'

74+ )

75+ => TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

76+ textNode = lift . textNode

77+ {-# INLINABLE textNode #-}

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

79+ default element :: ( MonadTransControl f

80+ , StT f a ~ a

81+ , m ~ f m'

82+ , DomBuilderSpace m' ~ DomBuilderSpace m

83+ , DomBuilder t m'

84+ )

85+ => Text -> ElementConfig er t m -> m a -> m (Element er (DomBuilderSpace m) t, a)

86+ element t cfg child = liftWith $ \run -> element t (liftElementConfig cfg) $ run child

87+ {-# INLINABLE element #-}

6288 -- | Create a placeholder in the DOM, with the ability to insert new DOM before it

6389 -- The provided DOM will be executed after the current frame, so it will not be affected by any occurrences that are concurrent with the occurrence that created it

6490 placeholder :: PlaceholderConfig above t m -> m (Placeholder above t)

6591 inputElement :: InputElementConfig er t m -> m (InputElement er (DomBuilderSpace m) t)

92+ default inputElement :: ( MonadTransControl f

93+ , m ~ f m'

94+ , DomBuilderSpace m' ~ DomBuilderSpace m

95+ , DomBuilder t m'

96+ )

97+ => InputElementConfig er t m -> m (InputElement er (DomBuilderSpace m) t)

98+ inputElement cfg = lift $ inputElement $ cfg

99+ { _inputElementConfig_elementConfig = liftElementConfig $ _inputElementConfig_elementConfig cfg

100+ }

101+ {-# INLINABLE inputElement #-}

66102 textAreaElement :: TextAreaElementConfig er t m -> m (TextAreaElement er (DomBuilderSpace m) t)

103+ default textAreaElement :: ( MonadTransControl f

104+ , m ~ f m'

105+ , DomBuilderSpace m' ~ DomBuilderSpace m

106+ , DomBuilder t m'

107+ )

108+ => TextAreaElementConfig er t m -> m (TextAreaElement er (DomBuilderSpace m) t)

109+ textAreaElement cfg = lift $ textAreaElement $ cfg

110+ { _textAreaElementConfig_elementConfig = liftElementConfig $ _textAreaElementConfig_elementConfig cfg

111+ }

112+ {-# INLINABLE textAreaElement #-}

113+ selectElement :: SelectElementConfig er t m -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)

114+ default selectElement :: ( MonadTransControl f

115+ , StT f a ~ a

116+ , m ~ f m'

117+ , DomBuilderSpace m' ~ DomBuilderSpace m

118+ , DomBuilder t m'

119+ )

120+ => SelectElementConfig er t m -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)

121+ selectElement cfg child = do

122+ let cfg' = cfg

123+ { _selectElementConfig_elementConfig = liftElementConfig $ _selectElementConfig_elementConfig cfg

124+ }

125+ liftWith $ \run -> selectElement cfg' $ run child

126+ {-# INLINABLE selectElement #-}

67127 placeRawElement :: RawElement (DomBuilderSpace m) -> m ()

128+ default placeRawElement :: ( MonadTrans f

129+ , m ~ f m'

130+ , DomBuilderSpace m' ~ DomBuilderSpace m

131+ , DomBuilder t m'

132+ )

133+ => RawElement (DomBuilderSpace m) -> m ()

134+ placeRawElement = lift . placeRawElement

135+ {-# INLINABLE placeRawElement #-}

68136 wrapRawElement :: RawElement (DomBuilderSpace m) -> RawElementConfig er t m -> m (Element er (DomBuilderSpace m) t)

137+ default wrapRawElement :: ( MonadTrans f

138+ , m ~ f m'

139+ , DomBuilderSpace m' ~ DomBuilderSpace m

140+ , DomBuilder t m'

141+ )

142+ => RawElement (DomBuilderSpace m) -> RawElementConfig er t m -> m (Element er (DomBuilderSpace m) t)

143+ wrapRawElement e cfg = lift $ wrapRawElement e $ cfg

144+ { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

145+ }

146+ {-# INLINABLE wrapRawElement #-}

69147

70148type Namespace = Text

71149

@@ -85,7 +163,11 @@ data TextNode d t = TextNode

85163 { _textNode_raw :: RawTextNode d

86164 }

87165

88−type AttributeName = (Maybe Namespace, Text)

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

167+

168+-- | By default, AttributeNames are unnamespaced

169+instance IsString AttributeName where

170+ fromString = AttributeName Nothing . fromString

89171

90172data Propagation

91173 = Propagation_Continue

@@ -220,12 +302,36 @@ instance (Reflex t, DomSpace (DomBuilderSpace m)) => Default (RawElementConfig E

220302 , _rawElementConfig_eventSpec = def

221303 }

222304

223−makeLenses ''TextNodeConfig

224−makeLenses ''ElementConfig

225−makeLenses ''PlaceholderConfig

226−makeLenses ''InputElementConfig

227−makeLenses ''TextAreaElementConfig

228−makeLenses ''RawElementConfig

305+data SelectElementConfig er t m = SelectElementConfig

306+ { _selectElementConfig_initialValue :: Text

307+ , _selectElementConfig_setValue :: Event t Text

308+ , _selectElementConfig_elementConfig :: ElementConfig er t m

309+ }

310+

311+instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (SelectElementConfig er t m) where

312+ def = SelectElementConfig

313+ { _selectElementConfig_initialValue = ""

314+ , _selectElementConfig_setValue = never

315+ , _selectElementConfig_elementConfig = def

316+ }

317+

318+data SelectElement er d t = SelectElement

319+ { _selectElement_element :: Element er d t

320+ , _selectElement_value :: Dynamic t Text

321+ , _selectElement_change :: Event t Text -- ^ Fires when the value is changed by the user, but not when it is set by setValue

322+ , _selectElement_hasFocus :: Dynamic t Bool

323+ , _selectElement_raw :: RawSelectElement d

324+ }

325+

326+concat <$> mapM makeLenses

327+ [ ''TextNodeConfig

328+ , ''ElementConfig

329+ , ''PlaceholderConfig

330+ , ''InputElementConfig

331+ , ''TextAreaElementConfig

332+ , ''SelectElementConfig

333+ , ''RawElementConfig

334+ ]

229335

230336class CanDeleteSelf t a | a -> t where

231337 deleteSelf :: Lens' a (Event t ())

@@ -290,24 +396,8 @@ instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (ElementConfig

290396 , _elementConfig_eventSpec = def

291397 }

292398

293−{-# INLINABLE liftPostBuildTElementConfig #-}

294−liftPostBuildTElementConfig :: ElementConfig er t (PostBuildT t m) -> ElementConfig er t m

295−liftPostBuildTElementConfig cfg = cfg

296− { _elementConfig_eventSpec = _elementConfig_eventSpec cfg

297− }

298−

299−{-# INLINABLE liftDynamicWriterTElementConfig #-}

300−liftDynamicWriterTElementConfig :: ElementConfig er t (DynamicWriterT t w m) -> ElementConfig er t m

301−liftDynamicWriterTElementConfig cfg = cfg

302− { _elementConfig_eventSpec = _elementConfig_eventSpec cfg

303− }

304−

305399instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (PostBuildT t m) where

306400 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m

307− {-# INLINABLE textNode #-}

308− textNode = lift . textNode

309− {-# INLINABLE element #-}

310− element t cfg child = liftWith $ \run -> element t (liftPostBuildTElementConfig cfg) $ run child

311401 {-# INLINABLE placeholder #-}

312402 placeholder cfg = lift $ do

313403 rec childPostBuild <- deletable (_placeholder_deletedSelf p) $ performEvent $ return () <$ _placeholder_insertedAbove p

@@ -315,11 +405,6 @@ instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBui

315405 { _placeholderConfig_insertAbove = ffor (_placeholderConfig_insertAbove cfg) $ \a -> runPostBuildT a =<< headE childPostBuild

316406 }

317407 return p

318− {-# INLINABLE inputElement #-}

319− inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftPostBuildTElementConfig

320− {-# INLINABLE textAreaElement #-}

321− textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftPostBuildTElementConfig

322− placeRawElement = lift . placeRawElement

323408 wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg

324409

325410instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where

@@ -327,7 +412,7 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (

327412 textNode = liftTextNode

328413 element elementTag cfg (DynamicWriterT child) = DynamicWriterT $ do

329414 s <- get

330− let cfg' = liftDynamicWriterTElementConfig cfg

415+ let cfg' = liftElementConfig cfg

331416 (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s

332417 put newS

333418 return (el, a)

@@ -357,8 +442,14 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (

357442 return $ p

358443 { _placeholder_insertedAbove = result

359444 }

360− inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftDynamicWriterTElementConfig

361− textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftDynamicWriterTElementConfig

445+ inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftElementConfig

446+ textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftElementConfig

447+ selectElement cfg (DynamicWriterT child) = DynamicWriterT $ do

448+ s <- get

449+ let cfg' = cfg & selectElementConfig_elementConfig %~ liftElementConfig

450+ (el, (a, newS)) <- lift $ selectElement cfg' $ runStateT child s

451+ put newS

452+ return (el, a)

362453 placeRawElement = lift . placeRawElement

363454 wrapRawElement e cfg = lift $ wrapRawElement e $ cfg

364455 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

@@ -393,6 +484,10 @@ instance Functor1 (TextAreaElementConfig er t) where

393484 type Functor1Constraint (TextAreaElementConfig er t) a b = Functor1Constraint (ElementConfig er t) a b

394485 fmap1 f cfg = cfg & textAreaElementConfig_elementConfig %~ fmap1 f

395486

487+instance Functor1 (SelectElementConfig er t) where

488+ type Functor1Constraint (SelectElementConfig er t) a b = Functor1Constraint (ElementConfig er t) a b

489+ fmap1 f cfg = cfg & selectElementConfig_elementConfig %~ fmap1 f

490+

396491instance Functor1 (RawElementConfig er t) where

397492 type Functor1Constraint (RawElementConfig er t) a b = DomBuilderSpace a ~ DomBuilderSpace b

398493 {-# INLINABLE fmap1 #-}

@@ -421,14 +516,7 @@ instance Reflex t => HasDomEvent t (TextAreaElement EventResult d t) en where

421516

422517instance DomBuilder t m => DomBuilder t (ReaderT r m) where

423518 type DomBuilderSpace (ReaderT r m) = DomBuilderSpace m

424− {-# INLINABLE textNode #-}

425− textNode = liftTextNode

426− element = liftElement

427519 placeholder = liftPlaceholder

428− inputElement = liftInputElement

429− textAreaElement = liftTextAreaElement

430− placeRawElement = lift . placeRawElement

431− wrapRawElement = liftWrapRawElement

432520

433521type LiftDomBuilder t f m =

434522 ( Reflex t

src/Reflex/Dom/Builder/Immediate.hs+39−8

@@ -47,12 +47,14 @@ import qualified GHCJS.DOM.Event as Event

4747import GHCJS.DOM.EventM (EventM, event, on)

4848import qualified GHCJS.DOM.EventM as DOM

4949import qualified GHCJS.DOM.HTMLInputElement as Input

50+import qualified GHCJS.DOM.HTMLSelectElement as Select

5051import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

5152import GHCJS.DOM.MouseEvent

5253import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,

5354 removeChild, setNodeValue, toNode)

5455import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,

55− WheelEvent, castToHTMLInputElement, castToHTMLTextAreaElement)

56+ WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,

57+ castToHTMLTextAreaElement)

5658import qualified GHCJS.DOM.Types as DOM

5759import GHCJS.DOM.UIEvent

5860import qualified GHCJS.DOM.Window as Window

@@ -133,7 +135,7 @@ newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IOR

133135wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)

134136wrap e cfg = do

135137 events <- askEvents

136− lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(mAttrNamespace, n) mv -> case mAttrNamespace of

138+ lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

137139 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

138140 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv

139141 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftIO $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do

@@ -175,7 +177,7 @@ makeElement elementTag cfg child = do

175177 Just e <- ImmediateDomBuilderT $ fmap DOM.castToHTMLElement <$> case cfg ^. namespace of

176178 Nothing -> createElement doc (Just elementTag)

177179 Just ens -> createElementNS doc (Just ens) (Just elementTag)

178− ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(mAttrNamespace, n) v -> case mAttrNamespace of

180+ ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

179181 Nothing -> setAttribute e n v

180182 Just ans -> setAttributeNS e (Just ans) n v

181183 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv

@@ -201,6 +203,7 @@ instance DomSpace GhcjsDomSpace where

201203 type RawElement GhcjsDomSpace = DOM.HTMLElement

202204 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement

203205 type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement

206+ type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement

204207 addEventSpecFlags _ en f es = es

205208 { _ghcjsEventSpec_filters =

206209 let f' = Just . GhcjsEventFilter . \case

@@ -309,11 +312,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

309312 [ valueChangedBySetValue

310313 , valueChangedByUI

311314 ]

312− let initialFocus = False --TODO: Is this correct?

313− hasFocus <- holdDyn initialFocus $ leftmost

314− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

315− , True <$ Reflex.select (_element_events e) (WrapArg Focus)

316− ]

315+ hasFocus <- mkHasFocus e

317316 return $ TextAreaElement

318317 { _textAreaElement_value = v

319318 , _textAreaElement_input = valueChangedByUI

@@ -321,9 +320,41 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

321320 , _textAreaElement_element = e

322321 , _textAreaElement_raw = domTextAreaElement

323322 }

323+ {-# INLINABLE selectElement #-}

324+ selectElement cfg child = do

325+ ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child

326+ let domSelectElement = castToHTMLSelectElement domElement

327+ Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)

328+ Just v0 <- Select.getValue domSelectElement

329+ let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement

330+ valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Select)

331+ valueChangedBySetValue <- performEvent $ ffor (cfg ^. selectElementConfig_setValue) $ \v' -> do

332+ Select.setValue domSelectElement $ Just v'

333+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

334+ v <- holdDyn v0 $ leftmost

335+ [ valueChangedBySetValue

336+ , valueChangedByUI

337+ ]

338+ hasFocus <- mkHasFocus e

339+ let wrapped = SelectElement

340+ { _selectElement_value = v

341+ , _selectElement_change = valueChangedByUI

342+ , _selectElement_hasFocus = hasFocus

343+ , _selectElement_element = e

344+ , _selectElement_raw = domSelectElement

345+ }

346+ return (wrapped, result)

324347 placeRawElement = append

325348 wrapRawElement = wrap

326349

350+mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

351+mkHasFocus e = do

352+ let initialFocus = False --TODO: Actually get the initial focus of the element

353+ holdDyn initialFocus $ leftmost

354+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

355+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)

356+ ]

357+

327358{-# INLINABLE insertImmediateAbove #-}

328359insertImmediateAbove :: (Reflex t, IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)

329360insertImmediateAbove n toInsertAbove = do

src/Reflex/Dom/Builder/Static.hs+13−1

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

123123 type RawElement StaticDomSpace = ()

124124 type RawInputElement StaticDomSpace = ()

125125 type RawTextAreaElement StaticDomSpace = ()

126+ type RawSelectElement StaticDomSpace = ()

126127 addEventSpecFlags _ _ _ _ = StaticEventSpec

127128

128129instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where

@@ -135,7 +136,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

135136 return $ TextNode ()

136137 {-# INLINABLE element #-}

137138 element elementTag cfg child = do

138− let toAttr (_mns, k) v = encodeUtf8 k <> "=\"" <> BL.toStrict (toLazyByteString $ fromHtmlEscapedText v) <> "\""

139+ let toAttr (AttributeName _mns k) v = encodeUtf8 k <> "=\"" <> BL.toStrict (toLazyByteString $ fromHtmlEscapedText v) <> "\""

139140 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

140141 StaticDomBuilderT $ do

141142 (result, innerHtml) <- lift $ runStaticDomBuilderT child

@@ -180,6 +181,17 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

180181 , _textAreaElement_element = e

181182 , _textAreaElement_raw = ()

182183 }

184+ selectElement cfg child = do

185+ (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) child

186+ v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)

187+ let wrapped = SelectElement

188+ { _selectElement_value = v

189+ , _selectElement_change = never

190+ , _selectElement_hasFocus = constDyn False --TODO: How do we make sure this is correct?

191+ , _selectElement_element = e

192+ , _selectElement_raw = ()

193+ }

194+ return (wrapped, result)

183195 placeRawElement () = return ()

184196 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

185197

src/Reflex/Dom/Old.hs+2−2

@@ -133,7 +133,7 @@ instance Attributes m (Map Text Text) t where

133133

134134addStaticAttributes :: Applicative m => Map Text Text -> ElementConfig er t m -> m (ElementConfig er t m)

135135addStaticAttributes attrs cfg = do

136− let initialAttrs = Map.fromList $ first ((,) Nothing) <$> Map.toList attrs

136+ let initialAttrs = Map.fromList $ first (AttributeName Nothing) <$> Map.toList attrs

137137 pure $ cfg & elementConfig_initialAttributes .~ initialAttrs

138138

139139instance PostBuild t m => Attributes m (Dynamic t (Map Text Text)) t where

@@ -261,7 +261,7 @@ elStopPropagationNS ns elementTag en child = do

261261

262262elDynHtmlAttr' :: MonadWidget t m => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)

263263elDynHtmlAttr' elementTag attrs html = do

264− let cfg = def & initialAttributes .~ Map.mapKeys ((,) Nothing) attrs

264+ let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs

265265 (e, _) <- element elementTag cfg $ return ()

266266 postBuild <- getPostBuild

267267 performEvent_ $ Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]

src/Reflex/Dom/Widget/Basic.hs+2−28

@@ -215,32 +215,6 @@ selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t

215215 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

216216selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild

217217

218−{-

219−{-# INLINABLE elWith #-}

220−elWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m a

221−elWith elementTag cfg child = do

222− (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child

223− return result

224−

225−{-# INLINABLE elWith' #-}

226−elWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m (El t, a)

227−elWith' elementTag cfg child = do

228− (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child

229− e' <- wrapElement defaultDomEventHandler e

230− return (e', result)

231−

232−{-# INLINABLE emptyElWith #-}

233−emptyElWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m ()

234−emptyElWith elementTag cfg = do

235− _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)

236− return ()

237−

238−{-# INLINABLE emptyElWith' #-}

239−emptyElWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m (El t)

240−emptyElWith' elementTag cfg = do

241− wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)

242−-}

243−

244218{-# INLINABLE el #-}

245219el :: forall t m a. DomBuilder t m => Text -> m a -> m a

246220el elementTag child = snd <$> el' elementTag child

@@ -268,7 +242,7 @@ el' elementTag = element elementTag def

268242{-# INLINABLE elAttr' #-}

269243elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

270244elAttr' elementTag attrs = element elementTag $ def

271− & initialAttributes .~ Map.mapKeys (\k -> (Nothing, k)) attrs

245+ & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs

272246

273247{-# INLINABLE elClass' #-}

274248elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

@@ -300,7 +274,7 @@ dynamicAttributesToModifyAttributes d = do

300274 That new -> do

301275 old <- sample $ current d

302276 return $ diffMap old new

303− return $ Map.fromList . fmap (\(k, v) -> ((Nothing, k), v)) . Map.toList <$> modificationsNeeded

277+ return $ Map.fromList . fmap (first (AttributeName Nothing)) . Map.toList <$> modificationsNeeded

304278

305279--------------------------------------------------------------------------------

306280-- Copied and pasted from Reflex.Widget.Class

src/Reflex/Dom/Widget/Input.hs+30−35

@@ -34,10 +34,8 @@ import GHCJS.DOM.Element (castToElement)

3434import qualified GHCJS.DOM.Element as Element

3535import GHCJS.DOM.EventM (on)

3636import qualified GHCJS.DOM.FileList as FileList

37−import GHCJS.DOM.HTMLInputElement (HTMLInputElement, castToHTMLInputElement)

38−import GHCJS.DOM.HTMLSelectElement (castToHTMLSelectElement)

39−import qualified GHCJS.DOM.HTMLSelectElement as HTMLSelectElement

40−import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement, castToHTMLTextAreaElement)

37+import GHCJS.DOM.HTMLInputElement (HTMLInputElement)

38+import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)

4139import GHCJS.DOM.Types (File)

4240import Reflex.Class

4341import Reflex.Dynamic

@@ -59,9 +57,16 @@ data TextInput t

5957 , _textInput_keydown :: Event t Int

6058 , _textInput_keyup :: Event t Int

6159 , _textInput_hasFocus :: Dynamic t Bool

62− , _textInput_element :: HTMLInputElement

60+ , _textInput_builderElement :: InputElement EventResult GhcjsDomSpace t

6361 }

6462

63+_textInput_element :: TextInput t -> HTMLInputElement

64+_textInput_element = _inputElement_raw . _textInput_builderElement

65+

66+instance Reflex t => HasDomEvent t (TextInput t) en where

67+ type DomEventType (TextInput t) en = DomEventType (InputElement EventResult GhcjsDomSpace t) en

68+ domEvent en = domEvent en . _textInput_builderElement

69+

6570data TextInputConfig t

6671 = TextInputConfig { _textInputConfig_inputType :: Text

6772 , _textInputConfig_initialValue :: Text

@@ -93,12 +98,17 @@ textInput (TextInputConfig inputType initial eSetValue dAttrs) = do

9398 , _textInput_keydown = domEvent Keydown i

9499 , _textInput_keyup = domEvent Keyup i

95100 , _textInput_hasFocus = _inputElement_hasFocus i

96− , _textInput_element = castToHTMLInputElement $ _element_raw $ _inputElement_element i

101+ , _textInput_builderElement = i

97102 }

98103

99−{-# INLINABLE textInputGetEnter #-}

104+{-# INLINE textInputGetEnter #-}

105+{-# DEPRECATED textInputGetEnter "Use 'keypress Enter' instead" #-}

100106textInputGetEnter :: Reflex t => TextInput t -> Event t ()

101−textInputGetEnter i = fmapMaybe (\n -> if keyCodeLookup n == Enter then Just () else Nothing) $ _textInput_keypress i

107+textInputGetEnter = keypress Enter

108+

109+{-# INLINABLE keypress #-}

110+keypress :: (Reflex t, HasDomEvent t e 'KeypressTag, DomEventType e 'KeypressTag ~ Int) => Key -> e -> Event t ()

111+keypress key i = fmapMaybe (\n -> if keyCodeLookup n == key then Just () else Nothing) $ domEvent Keypress i

102112

103113data RangeInputConfig t

104114 = RangeInputConfig { _rangeInputConfig_initialValue :: Float

@@ -136,7 +146,7 @@ rangeInput (RangeInputConfig initial eSetValue dAttrs) = do

136146 , _rangeInput_input = read . T.unpack <$> _inputElement_input i

137147 , _rangeInput_mouseup = domEvent Mouseup i

138148 , _rangeInput_hasFocus = _inputElement_hasFocus i

139− , _rangeInput_element = castToHTMLInputElement $ _element_raw $ _inputElement_element i

149+ , _rangeInput_element = _inputElement_raw i

140150 }

141151

142152data TextAreaConfig t

@@ -173,7 +183,7 @@ textArea (TextAreaConfig initial eSet attrs) = do

173183 , _textArea_input = _textAreaElement_input i

174184 , _textArea_keypress = domEvent Keypress i

175185 , _textArea_hasFocus = _textAreaElement_hasFocus i

176− , _textArea_element = castToHTMLTextAreaElement $ _element_raw $ _textAreaElement_element i

186+ , _textArea_element = _textAreaElement_raw i

177187 }

178188

179189data CheckboxConfig t

@@ -203,7 +213,7 @@ checkbox checked config = do

203213 i <- inputElement $ def

204214 & inputElementConfig_initialChecked .~ checked

205215 & inputElementConfig_setChecked .~ _checkboxConfig_setValue config

206− & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ Map.mapKeys ((,) Nothing) permanentAttrs

216+ & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ Map.mapKeys (AttributeName Nothing) permanentAttrs

207217 & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ modifyAttrs

208218 return $ Checkbox

209219 { _checkbox_value = _inputElement_checked i

@@ -280,7 +290,7 @@ checkboxView dAttrs dValue = do

280290 elementConfig :: ElementConfig CheckboxViewEventResult t m

281291 elementConfig = (def :: ElementConfig EventResult t m)

282292 { _elementConfig_modifyAttributes = modifyAttrs

283− , _elementConfig_initialAttributes = Map.mapKeys ((,) Nothing) permanentAttrs

293+ , _elementConfig_initialAttributes = Map.mapKeys (AttributeName Nothing) permanentAttrs

284294 , _elementConfig_eventSpec = GhcjsEventSpec

285295 { _ghcjsEventSpec_filters = filters

286296 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of

@@ -408,7 +418,7 @@ regularToDropdownViewEventType en r = case en of

408418--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map

409419-- | Create a dropdown box

410420-- The first argument gives the initial value of the dropdown; if it is not present in the map of options provided, it will be added with an empty string as its text

411−dropdown :: forall k t m. (DomBuilder t m, MonadFix m, MonadHold t m, PerformEvent t m, MonadIO (Performable m), MonadIO m, TriggerEvent t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace, Ord k) => k -> Dynamic t (Map k Text) -> DropdownConfig t k -> m (Dropdown t k)

421+dropdown :: forall k t m. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m, Ord k) => k -> Dynamic t (Map k Text) -> DropdownConfig t k -> m (Dropdown t k)

412422dropdown k0 options (DropdownConfig setK attrs) = do

413423 optionsWithAddedKeys <- fmap (zipDynWith Map.union options) $ foldDyn Map.union (k0 =: "") $ fmap (=: "") setK

414424 defaultKey <- holdDyn k0 setK

@@ -416,31 +426,16 @@ dropdown k0 options (DropdownConfig setK attrs) = do

416426 let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os

417427 in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs)

418428 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

419− let cfg = (def :: ElementConfig EventResult t m)

420− { _elementConfig_modifyAttributes = modifyAttrs

421− , _elementConfig_eventSpec = GhcjsEventSpec

422− { _ghcjsEventSpec_filters = DMap.singleton Change $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do

423− Just t <- Event.getTarget evt

424− Just v <- HTMLSelectElement.getValue $ HTMLSelectElement.castToHTMLSelectElement t

425− return $ (,) mempty $ return $ Just $ DropdownViewEventResult v

426− , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of

427− Click -> error "impossible"

428− _ -> do

429− Just e <- withIsEvent en $ Event.getTarget evt

430− mr <- runReaderT (defaultDomEventHandler (castToElement e) en) evt

431− return $ ffor mr $ \(EventResult r) -> DropdownViewEventResult $ regularToDropdownViewEventType en r

432− }

433− }

434− (eRaw, _) <- element "select" cfg $ listWithKey indexedOptions $ \(ix, k) v -> do

429+ let cfg = def

430+ & selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ modifyAttrs

431+ & selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)

432+ (eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do

435433 let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey

436434 elDynAttr "option" optionAttrs $ dynText v

437− let e = castToHTMLSelectElement $ _element_raw eRaw

438− performEvent_ $ HTMLSelectElement.setValue e . Just . show <$> attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK

439− let lookupSelected ks value = do

440− v <- value

441− key <- T.readMaybe v

435+ let lookupSelected ks v = do

436+ key <- T.readMaybe $ T.unpack v

442437 Bimap.lookup key ks

443− eChange <- attachPromptlyDynWith lookupSelected ixKeys <$> wrapDomEvent e (`on` Element.change) (HTMLSelectElement.getValue e)

438+ let eChange = attachPromptlyDynWith lookupSelected ixKeys $ _selectElement_change eRaw

444439 let readKey keys mk = fromMaybe k0 $ do

445440 k <- mk

446441 guard $ Bimap.memberR k keys