src/Reflex/Dom/Widget/Input.hs · reflex-dom

git.iko.soy/reflex-dom

on efaaa52 help sign in

reflex-dom/src/Reflex/Dom/Widget/Input.hs

577 lines 22 kB history raw

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TemplateHaskell #-}

12{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE UndecidableInstances #-}

14module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where

16import Prelude

18import Control.Lens hiding (element, ix)

19import Control.Monad.Fix

20import Control.Monad.IO.Class

21import Control.Monad.Reader

22import qualified Data.Bimap as Bimap

23import Data.Default

24import Data.Dependent.Map (DMap)

25import qualified Data.Dependent.Map as DMap

26import Data.Functor.Misc

27import Data.Map (Map)

28import qualified Data.Map as Map

29import Data.Maybe

30import Data.Semigroup

31import Data.Text (Text)

32import qualified Data.Text as T

33import GHCJS.DOM.Element (castToElement)

34import qualified GHCJS.DOM.Element as Element

35import GHCJS.DOM.EventM (on)

36import qualified GHCJS.DOM.FileList as FileList

37import GHCJS.DOM.HTMLInputElement (HTMLInputElement)

38import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)

39import GHCJS.DOM.Types (File)

40import Reflex.Class

41import Reflex.Dom.Builder.Class

42import Reflex.Dom.Builder.Immediate

43import Reflex.Dom.Class

44import Reflex.Dom.Widget.Basic

45import Reflex.Dynamic

46import Reflex.PostBuild.Class

47import Reflex.TriggerEvent.Class

48import qualified Text.Read as T

50import qualified GHCJS.DOM.Event as Event

51import qualified GHCJS.DOM.HTMLInputElement as Input

53data TextInput t

54 = TextInput { _textInput_value :: Dynamic t Text

55 , _textInput_input :: Event t Text

56 , _textInput_keypress :: Event t Int

57 , _textInput_keydown :: Event t Int

58 , _textInput_keyup :: Event t Int

59 , _textInput_hasFocus :: Dynamic t Bool

60 , _textInput_builderElement :: InputElement EventResult GhcjsDomSpace t

61 }

63_textInput_element :: TextInput t -> HTMLInputElement

64_textInput_element = _inputElement_raw . _textInput_builderElement

66instance 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

70data TextInputConfig t

71 = TextInputConfig { _textInputConfig_inputType :: Text

72 , _textInputConfig_initialValue :: Text

73 , _textInputConfig_setValue :: Event t Text

74 , _textInputConfig_attributes :: Dynamic t (Map Text Text)

75 }

77instance Reflex t => Default (TextInputConfig t) where

78 {-# INLINABLE def #-}

79 def = TextInputConfig { _textInputConfig_inputType = "text"

80 , _textInputConfig_initialValue = ""

81 , _textInputConfig_setValue = never

82 , _textInputConfig_attributes = constDyn mempty

83 }

85-- | Create an input whose value is a string. By default, the "type" attribute is set to "text", but it can be changed using the _textInputConfig_inputType field. Note that only types for which the value is always a string will work - types whose value may be null will not work properly with this widget.

86{-# INLINABLE textInput #-}

87textInput :: (DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace) => TextInputConfig t -> m (TextInput t)

88textInput (TextInputConfig inputType initial eSetValue dAttrs) = do

89 modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.insert "type" inputType) dAttrs

90 i <- inputElement $ def

91 & inputElementConfig_initialValue .~ initial

92 & inputElementConfig_setValue .~ eSetValue

93 & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

94 return $ TextInput

95 { _textInput_value = _inputElement_value i

96 , _textInput_input = _inputElement_input i

97 , _textInput_keypress = domEvent Keypress i

98 , _textInput_keydown = domEvent Keydown i

99 , _textInput_keyup = domEvent Keyup i

100 , _textInput_hasFocus = _inputElement_hasFocus i

101 , _textInput_builderElement = i

102 }

103

104{-# INLINE textInputGetEnter #-}

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

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

107textInputGetEnter = keypress Enter

108

109{-# INLINABLE keypress #-}

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

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

112

113data RangeInputConfig t

114 = RangeInputConfig { _rangeInputConfig_initialValue :: Float

115 , _rangeInputConfig_setValue :: Event t Float

116 , _rangeInputConfig_attributes :: Dynamic t (Map Text Text)

117 }

118

119instance Reflex t => Default (RangeInputConfig t) where

120 {-# INLINABLE def #-}

121 def = RangeInputConfig { _rangeInputConfig_initialValue = 0

122 , _rangeInputConfig_setValue = never

123 , _rangeInputConfig_attributes = constDyn mempty

124 }

125

126data RangeInput t

127 = RangeInput { _rangeInput_value :: Dynamic t Float

128 , _rangeInput_input :: Event t Float

129 , _rangeInput_mouseup :: Event t (Int, Int)

130 , _rangeInput_hasFocus :: Dynamic t Bool

131 , _rangeInput_element :: HTMLInputElement

132 }

133

134-- | Create an input whose value is a float.

135-- https://www.w3.org/wiki/HTML/Elements/input/range

136{-# INLINABLE rangeInput #-}

137rangeInput :: (DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace) => RangeInputConfig t -> m (RangeInput t)

138rangeInput (RangeInputConfig initial eSetValue dAttrs) = do

139 modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.insert "type" "range") dAttrs

140 i <- inputElement $ def

141 & inputElementConfig_initialValue .~ (T.pack . show $ initial)

142 & inputElementConfig_setValue .~ (T.pack . show <$> eSetValue)

143 & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

144 return $ RangeInput

145 { _rangeInput_value = read . T.unpack <$> _inputElement_value i

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

147 , _rangeInput_mouseup = domEvent Mouseup i

148 , _rangeInput_hasFocus = _inputElement_hasFocus i

149 , _rangeInput_element = _inputElement_raw i

150 }

151

152data TextAreaConfig t

153 = TextAreaConfig { _textAreaConfig_initialValue :: Text

154 , _textAreaConfig_setValue :: Event t Text

155 , _textAreaConfig_attributes :: Dynamic t (Map Text Text)

156 }

157

158instance Reflex t => Default (TextAreaConfig t) where

159 {-# INLINABLE def #-}

160 def = TextAreaConfig { _textAreaConfig_initialValue = ""

161 , _textAreaConfig_setValue = never

162 , _textAreaConfig_attributes = constDyn mempty

163 }

164

165data TextArea t

166 = TextArea { _textArea_value :: Dynamic t Text

167 , _textArea_input :: Event t Text

168 , _textArea_hasFocus :: Dynamic t Bool

169 , _textArea_keypress :: Event t Int

170 , _textArea_element :: HTMLTextAreaElement

171 }

172

173{-# INLINABLE textArea #-}

174textArea :: (DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace) => TextAreaConfig t -> m (TextArea t)

175textArea (TextAreaConfig initial eSet attrs) = do

176 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

177 i <- textAreaElement $ def

178 & textAreaElementConfig_initialValue .~ initial

179 & textAreaElementConfig_setValue .~ eSet

180 & textAreaElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

181 return $ TextArea

182 { _textArea_value = _textAreaElement_value i

183 , _textArea_input = _textAreaElement_input i

184 , _textArea_keypress = domEvent Keypress i

185 , _textArea_hasFocus = _textAreaElement_hasFocus i

186 , _textArea_element = _textAreaElement_raw i

187 }

188

189data CheckboxConfig t

190 = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool

191 , _checkboxConfig_attributes :: Dynamic t (Map Text Text)

192 }

193

194instance Reflex t => Default (CheckboxConfig t) where

195 {-# INLINABLE def #-}

196 def = CheckboxConfig { _checkboxConfig_setValue = never

197 , _checkboxConfig_attributes = constDyn mempty

198 }

199

200data Checkbox t

201 = Checkbox { _checkbox_value :: Dynamic t Bool

202 , _checkbox_change :: Event t Bool

203 }

204

205-- | Create an editable checkbox

206-- Note: if the "type" or "checked" attributes are provided as attributes, they will be ignored

207{-# INLINABLE checkbox #-}

208checkbox :: (DomBuilder t m, PostBuild t m) => Bool -> CheckboxConfig t -> m (Checkbox t)

209checkbox checked config = do

210 let permanentAttrs = "type" =: "checkbox"

211 dAttrs = Map.delete "checked" . Map.union permanentAttrs <$> _checkboxConfig_attributes config

212 modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs

213 i <- inputElement $ def

214 & inputElementConfig_initialChecked .~ checked

215 & inputElementConfig_setChecked .~ _checkboxConfig_setValue config

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

217 & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

218 return $ Checkbox

219 { _checkbox_value = _inputElement_checked i

220 , _checkbox_change = _inputElement_checkedChange i

221 }

222

223type family CheckboxViewEventResultType (en :: EventTag) :: * where

224 CheckboxViewEventResultType 'ClickTag = Bool

225 CheckboxViewEventResultType t = EventResultType t

226

227regularToCheckboxViewEventType :: EventName t -> EventResultType t -> CheckboxViewEventResultType t

228regularToCheckboxViewEventType en r = case en of

229 Click -> error "regularToCheckboxViewEventType: EventName Click should never be encountered"

230 Abort -> r

231 Blur -> r

232 Change -> r

233 Contextmenu -> r

234 Dblclick -> r

235 Drag -> r

236 Dragend -> r

237 Dragenter -> r

238 Dragleave -> r

239 Dragover -> r

240 Dragstart -> r

241 Drop -> r

242 Error -> r

243 Focus -> r

244 Input -> r

245 Invalid -> r

246 Keydown -> r

247 Keypress -> r

248 Keyup -> r

249 Load -> r

250 Mousedown -> r

251 Mouseenter -> r

252 Mouseleave -> r

253 Mousemove -> r

254 Mouseout -> r

255 Mouseover -> r

256 Mouseup -> r

257 Mousewheel -> r

258 Scroll -> r

259 Select -> r

260 Submit -> r

261 Wheel -> r

262 Beforecut -> r

263 Cut -> r

264 Beforecopy -> r

265 Copy -> r

266 Beforepaste -> r

267 Paste -> r

268 Reset -> r

269 Search -> r

270 Selectstart -> r

271 Touchstart -> r

272 Touchmove -> r

273 Touchend -> r

274 Touchcancel -> r

275

276newtype CheckboxViewEventResult en = CheckboxViewEventResult { unCheckboxViewEventResult :: CheckboxViewEventResultType en }

277

278--TODO

279{-# INLINABLE checkboxView #-}

280checkboxView :: forall t m. (DomBuilder t m, DomBuilderSpace m ~ GhcjsDomSpace, PostBuild t m, MonadHold t m) => Dynamic t (Map Text Text) -> Dynamic t Bool -> m (Event t Bool)

281checkboxView dAttrs dValue = do

282 let permanentAttrs = "type" =: "checkbox"

283 modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.union permanentAttrs) dAttrs

284 postBuild <- getPostBuild

285 let filters :: DMap EventName (GhcjsEventFilter CheckboxViewEventResult)

286 filters = DMap.singleton Click $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do

287 Just t <- Event.getTarget evt

288 b <- Input.getChecked $ Input.castToHTMLInputElement t

289 return $ (,) preventDefault $ return $ Just $ CheckboxViewEventResult b

290 elementConfig :: ElementConfig CheckboxViewEventResult t m

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

292 { _elementConfig_modifyAttributes = fmap mapKeysToAttributeName modifyAttrs

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

294 , _elementConfig_eventSpec = GhcjsEventSpec

295 { _ghcjsEventSpec_filters = filters

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

297 Click -> error "impossible"

298 _ -> do

299 Just e <- withIsEvent en $ Event.getTarget evt

300 mr <- runReaderT (defaultDomEventHandler (castToElement e) en) evt

301 return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r

302 }

303 }

304 inputElementConfig :: InputElementConfig CheckboxViewEventResult t m

305 inputElementConfig = (def :: InputElementConfig EventResult t m)

306 & inputElementConfig_setChecked .~ leftmost [updated dValue, tag (current dValue) postBuild]

307 & inputElementConfig_elementConfig .~ elementConfig

308 i <- inputElement inputElementConfig

309 return $ unCheckboxViewEventResult <$> select (_element_events $ _inputElement_element i) (WrapArg Click)

310

311data FileInput d t

312 = FileInput { _fileInput_value :: Dynamic t [File]

313 , _fileInput_element :: RawInputElement d

314 }

315

316data FileInputConfig t

317 = FileInputConfig { _fileInputConfig_attributes :: Dynamic t (Map Text Text)

318 }

319

320instance Reflex t => Default (FileInputConfig t) where

321 def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty

322 }

323

324fileInput :: forall t m. (MonadIO m, MonadFix m, MonadHold t m, TriggerEvent t m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)

325 => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)

326fileInput config = do

327 let insertType = Map.insert "type" "file"

328 dAttrs = insertType <$> _fileInputConfig_attributes config

329 modifyAttrs <- dynamicAttributesToModifyAttributes dAttrs

330 let filters = DMap.singleton Change . GhcjsEventFilter $ \_ -> do

331 return . (,) mempty $ return . Just $ EventResult ()

332 elCfg = (def :: ElementConfig EventResult t m)

333 & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

334 & elementConfig_eventSpec . ghcjsEventSpec_filters .~ filters

335 cfg = (def :: InputElementConfig EventResult t m) & inputElementConfig_elementConfig .~ elCfg

336 eRaw <- inputElement cfg

337 let e = _inputElement_raw eRaw

338 eChange <- wrapDomEvent e (`on` Element.change) $ do

339 Just files <- Input.getFiles e

340 len <- FileList.getLength files

341 mapM (fmap (fromMaybe (error "fileInput: fileList.item returned null")) . FileList.item files) [0 .. len-1]

342 dValue <- holdDyn [] eChange

343 return $ FileInput

344 { _fileInput_value = dValue

345 , _fileInput_element = e

346 }

347

348data Dropdown t k

349 = Dropdown { _dropdown_value :: Dynamic t k

350 , _dropdown_change :: Event t k

351 }

352

353data DropdownConfig t k

354 = DropdownConfig { _dropdownConfig_setValue :: Event t k

355 , _dropdownConfig_attributes :: Dynamic t (Map Text Text)

356 }

357

358instance Reflex t => Default (DropdownConfig t k) where

359 def = DropdownConfig { _dropdownConfig_setValue = never

360 , _dropdownConfig_attributes = constDyn mempty

361 }

362

363type family DropdownViewEventResultType (en :: EventTag) :: * where

364 DropdownViewEventResultType 'ChangeTag = Text

365 DropdownViewEventResultType t = EventResultType t

366

367newtype DropdownViewEventResult en = DropdownViewEventResult { unDropdownViewEventResult :: DropdownViewEventResultType en }

368

369regularToDropdownViewEventType :: EventName t -> EventResultType t -> DropdownViewEventResultType t

370regularToDropdownViewEventType en r = case en of

371 Change -> error "regularToDropdownViewEventType: EventName Change should never be encountered"

372 Abort -> r

373 Blur -> r

374 Click -> r

375 Contextmenu -> r

376 Dblclick -> r

377 Drag -> r

378 Dragend -> r

379 Dragenter -> r

380 Dragleave -> r

381 Dragover -> r

382 Dragstart -> r

383 Drop -> r

384 Error -> r

385 Focus -> r

386 Input -> r

387 Invalid -> r

388 Keydown -> r

389 Keypress -> r

390 Keyup -> r

391 Load -> r

392 Mousedown -> r

393 Mouseenter -> r

394 Mouseleave -> r

395 Mousemove -> r

396 Mouseout -> r

397 Mouseover -> r

398 Mouseup -> r

399 Mousewheel -> r

400 Scroll -> r

401 Select -> r

402 Submit -> r

403 Wheel -> r

404 Beforecut -> r

405 Cut -> r

406 Beforecopy -> r

407 Copy -> r

408 Beforepaste -> r

409 Paste -> r

410 Reset -> r

411 Search -> r

412 Selectstart -> r

413 Touchstart -> r

414 Touchmove -> r

415 Touchend -> r

416 Touchcancel -> r

417

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

419-- | Create a dropdown box

420-- 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

421dropdown :: 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)

422dropdown k0 options (DropdownConfig setK attrs) = do

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

424 defaultKey <- holdDyn k0 setK

425 let (indexedOptions, ixKeys) = splitDynPure $ ffor optionsWithAddedKeys $ \os ->

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

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

428 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

429 let cfg = def

430 & selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

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

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

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