@@ -1,5 +1,5 @@
11{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, DataKinds, GADTs, ScopedTypeVariables, FlexibleInstances, RecursiveDo, TemplateHaskell #-}
2−module Reflex.Dom.Widget.Input where
2+module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where
33
44import Prelude
55
@@ -23,11 +23,32 @@ import Data.Default
2323import Data.Maybe
2424import Safe
2525import Data.Dependent.Sum (DSum (..))
26−import Data.List.NonEmpty (NonEmpty (..))
27−import Data.Foldable
2826
29−input' :: MonadWidget t m => String -> String -> Event t String -> Dynamic t (Map String String) -> m (TextInput t)
30−input' inputType initial eSetValue dAttrs = do
27+data TextInput t
28+ = TextInput { _textInput_value :: Dynamic t String
29+ , _textInput_keypress :: Event t Int
30+ , _textInput_keydown :: Event t Int
31+ , _textInput_keyup :: Event t Int
32+ , _textInput_hasFocus :: Dynamic t Bool
33+ , _textInput_element :: HTMLInputElement
34+ }
35+
36+data TextInputConfig t
37+ = TextInputConfig { _textInputConfig_inputType :: String
38+ , _textInputConfig_initialValue :: String
39+ , _textInputConfig_setValue :: Event t String
40+ , _textInputConfig_attributes :: Dynamic t (Map String String)
41+ }
42+
43+instance Reflex t => Default (TextInputConfig t) where
44+ def = TextInputConfig { _textInputConfig_inputType = "text"
45+ , _textInputConfig_initialValue = ""
46+ , _textInputConfig_setValue = never
47+ , _textInputConfig_attributes = constDyn mempty
48+ }
49+
50+textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t)
51+textInput (TextInputConfig inputType initial eSetValue dAttrs) = do
3152 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs
3253 liftIO $ htmlInputElementSetValue e initial
3354 performEvent_ $ fmap (liftIO . htmlInputElementSetValue e) eSetValue
@@ -41,82 +62,20 @@ input' inputType initial eSetValue dAttrs = do
4162 postGui $ runWithActions [eChangeFocusTrigger :=> True]
4263 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
4364 dFocus <- holdDyn False eChangeFocus
44− eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
45− eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
46− eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
65+ eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent
66+ eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent
67+ eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent
4768 dValue <- holdDyn initial $ leftmost [eSetValue, eChange]
4869 return $ TextInput dValue eKeypress eKeydown eKeyup dFocus e
4970
50−{-
51− dSetValue <- holdDyn "" eSetValue
52− dynText =<< combineDyn (\v a -> "Input placeholder: " <> show (inputType, v, a)) dSetValue dAttrs
53− return $ TextInput (constDyn "") never never never (constDyn False) (constDyn Nothing)
54−
55−input' inputType eSetValue dAttrs = do
56− dEffectiveAttrs <- mapDyn (Map.insert "type" inputType) dAttrs
57− let mkSelf (initialValue, initialAttrs) = do
58− doc <- askDocument
59− Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
60− liftIO $ htmlInputElementSetValue e initialValue
61− iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
62− eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
63− runFrame <- askRunFrame
64− eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
65− unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
66− runFrame $ DMap.singleton eChangeFocusTrigger False
67− unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
68− runFrame $ DMap.singleton eChangeFocusTrigger True
69− return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
70− eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
71− eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
72− eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
73− return (e, eChange, eKeypress, eKeydown, eKeyup, eChangeFocus)
74− dInitialValue <- holdDyn "" eSetValue
75− dInitial <- combineDyn (,) dInitialValue dEffectiveAttrs
76− eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
77− dMyElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
78− performEvent_ . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dEffectiveAttrs
79− putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
80− performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlInputElementSetValue e v) $ attachWith (\e v -> case e of
81− Nothing -> Nothing
82− Just e' -> Just (e',v)) (current dMyElement) eSetValue
83− eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
84− dFocus <- holdDyn False . switch =<< hold never (fmap (^. _6) eCreated) --TODO: Check that 'False' is always the correct starting value - i.e.: an element will always receive an 'onfocus' event, even if it gets focus immediately
85− dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
86− eKeypress <- liftM switch $ hold never $ fmap (^. _3) eCreated
87− eKeydown <- liftM switch $ hold never $ fmap (^. _4) eCreated
88− eKeyup <- liftM switch $ hold never $ fmap (^. _5) eCreated
89− return $ TextInput dValue eKeypress eKeydown eKeyup dFocus dMyElement
90−-}
91−
92−class HasValue a where
93− type Value a :: *
94− value :: a -> Value a
95−
96−data TextInput t
97− = TextInput { _textInput_value :: Dynamic t String
98− , _textInput_keypress :: Event t Int
99− , _textInput_keydown :: Event t Int
100− , _textInput_keyup :: Event t Int
101− , _textInput_hasFocus :: Dynamic t Bool
102− , _textInput_element :: HTMLInputElement
103− }
104−
105−instance HasValue (TextInput t) where
106− type Value (TextInput t) = Dynamic t String
107− value = _textInput_value
108−
109−textInput :: MonadWidget t m => m (TextInput t)
110−textInput = input' "text" "" never (constDyn $ Map.empty)
111−
11271textInputGetEnter :: Reflex t => TextInput t -> Event t ()
11372textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i
11473
11574data TextAreaConfig t
116− = TextAreaConfig { _textAreaConfig_initialValue :: String
117− , _textAreaConfig_setValue :: Event t String
118− , _textAreaConfig_attributes :: Dynamic t (Map String String)
119− }
75+ = TextAreaConfig { _textAreaConfig_initialValue :: String
76+ , _textAreaConfig_setValue :: Event t String
77+ , _textAreaConfig_attributes :: Dynamic t (Map String String)
78+ }
12079
12180instance Reflex t => Default (TextAreaConfig t) where
12281 def = TextAreaConfig { _textAreaConfig_initialValue = ""
@@ -125,15 +84,11 @@ instance Reflex t => Default (TextAreaConfig t) where
12584 }
12685
12786data TextArea t
128− = TextArea { _textArea_value :: Dynamic t String
129− , _textArea_element :: HTMLTextAreaElement
130− , _textArea_hasFocus :: Dynamic t Bool
131− , _textArea_keypress :: Event t Int
132− }
133−
134−instance HasValue (TextArea t) where
135− type Value (TextArea t) = Dynamic t String
136− value = _textArea_value
87+ = TextArea { _textArea_value :: Dynamic t String
88+ , _textArea_element :: HTMLTextAreaElement
89+ , _textArea_hasFocus :: Dynamic t Bool
90+ , _textArea_keypress :: Event t Int
91+ }
13792
13893textArea :: MonadWidget t m => TextAreaConfig t -> m (TextArea t)
13994textArea (TextAreaConfig initial eSet attrs) = do
@@ -150,68 +105,31 @@ textArea (TextAreaConfig initial eSet attrs) = do
150105 performEvent_ $ fmap (liftIO . htmlTextAreaElementSetValue e) eSet
151106 f <- holdDyn False eChangeFocus
152107 ev <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e
153− v <- holdDyn "" $ leftmost [eSet, ev]
154− eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
108+ v <- holdDyn initial $ leftmost [eSet, ev]
109+ eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent
155110 return $ TextArea v e f eKeypress
156111
157−{-
158−type family Controller sm t a where
159− Controller Edit t a = (a, Event t a) -- Initial value and setter
160− Controller View t a = Dynamic t a -- Value (always)
161−
162−type family Output sm t a where
163− Output Edit t a = Dynamic t a -- Value (always)
164− Output View t a = Event t a -- Requested changes
165−
166−data CheckboxConfig sm t
167− = CheckboxConfig { _checkbox_input :: Controller sm t Bool
168− , _checkbox_attributes :: Attributes
169− }
170−
171−instance Reflex t => Default (CheckboxConfig Edit t) where
172− def = CheckboxConfig (False, never) mempty
173−
174−data Checkbox sm t
175− = Checkbox { _checkbox_output :: Output sm t Bool
176− }
177−
178−data StateMode = Edit | View
179−
180−--TODO: There must be a more generic way to get this witness and allow us to case on the type-level StateMode
181−data StateModeWitness (sm :: StateMode) where
182− EditWitness :: StateModeWitness Edit
183− ViewWitness :: StateModeWitness View
184−
185−class HasStateModeWitness (sm :: StateMode) where
186− stateModeWitness :: StateModeWitness sm
187−
188−instance HasStateModeWitness Edit where
189− stateModeWitness = EditWitness
190−
191−instance HasStateModeWitness View where
192− stateModeWitness = ViewWitness
193−-}
194−
195112data CheckboxConfig t
196− = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool
197− , _checkboxConfig_attributes :: Map String String
198− }
113+ = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool
114+ , _checkboxConfig_attributes :: Dynamic t (Map String String)
115+ }
199116
200117instance Reflex t => Default (CheckboxConfig t) where
201118 def = CheckboxConfig { _checkboxConfig_setValue = never
202− , _checkboxConfig_attributes = Map.empty
119+ , _checkboxConfig_attributes = constDyn mempty
203120 }
204121
205122data Checkbox t
206− = Checkbox { _checkbox_value :: Dynamic t Bool
207− }
123+ = Checkbox { _checkbox_value :: Dynamic t Bool
124+ }
208125
209126--TODO: Make attributes possibly dynamic
210127-- | Create an editable checkbox
211128-- Note: if the "type" or "checked" attributes are provided as attributes, they will be ignored
212129checkbox :: MonadWidget t m => Bool -> CheckboxConfig t -> m (Checkbox t)
213130checkbox checked config = do
214− e <- liftM castToHTMLInputElement $ buildEmptyElement "input" $ Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") (_checkboxConfig_attributes config)
131+ attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config)
132+ e <- liftM castToHTMLInputElement $ buildEmptyElement "input" attrs
215133 eClick <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e
216134 performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ _checkboxConfig_setValue config
217135 dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick]
@@ -229,26 +147,26 @@ checkboxView dAttrs dValue = do
229147 performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ updated dValue
230148 return eClicked
231149
232−checkboxWithLabel :: forall t m. MonadWidget t m => String -> m (Checkbox t)
233−checkboxWithLabel l = checkboxWithLabelAttrs l Map.empty
234−
235−checkboxWithLabelAttrs :: forall t m. MonadWidget t m => String -> Map String String -> m (Checkbox t)
236−checkboxWithLabelAttrs l attrs = elAttr "label" attrs $ do
237− c <- checkbox False def
238− text $ " " <> l
239− return c
150+data Dropdown t k
151+ = Dropdown { _dropdown_value :: Dynamic t k
152+ }
240153
154+data DropdownConfig t k
155+ = DropdownConfig { _dropdownConfig_setValue :: Event t k
156+ , _dropdownConfig_attributes :: Dynamic t (Map String String)
157+ }
241158
242−data Dropdown t k
243− = Dropdown { _dropdown_value :: Dynamic t k
244− }
159+instance (Reflex t, Ord k, Show k, Read k) => Default (DropdownConfig t k) where
160+ def = DropdownConfig { _dropdownConfig_setValue = never
161+ , _dropdownConfig_attributes = constDyn mempty
162+ }
245163
246164--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map
247165--TODO: Get rid of Show k and Read k by indexing the possible values ourselves
248166-- | Create a dropdown box
249167-- 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
250−dropdownDynAttr :: forall k t m. (MonadWidget t m, Ord k, Show k, Read k) => Dynamic t (Map String String) -> k -> Event t k -> Dynamic t (Map k String) -> m (Dropdown t k)
251−dropdownDynAttr attrs k0 setK options = do
168+dropdown :: forall k t m. (MonadWidget t m, Ord k, Show k, Read k) => k -> Dynamic t (Map k String) -> DropdownConfig t k -> m (Dropdown t k)
169+dropdown k0 options (DropdownConfig setK attrs) = do
252170 (eRaw, _) <- elDynAttr' "select" attrs $ do
253171 optionsWithDefault <- mapDyn (`Map.union` (k0 =: "")) options
254172 listWithKey optionsWithDefault $ \k v -> do
@@ -265,65 +183,15 @@ dropdownDynAttr attrs k0 setK options = do
265183 dValue <- combineDyn readKey options =<< holdDyn (Just k0) (leftmost [eChange, fmap Just setK])
266184 return $ Dropdown dValue
267185
268−dropdown :: forall k t m. (MonadWidget t m, Ord k, Show k, Read k) => k -> Dynamic t (Map k String) -> m (Dropdown t k)
269−dropdown k = dropdownDynAttr (constDyn Map.empty) k never
270−
271−--TODO: Get rid of Show k and Read k by indexing the possible values ourselves
272−dropdown' :: forall k t m. (MonadWidget t m, Eq k, Show k, Read k) => k -> NonEmpty (k, String) -> m (Dropdown t k)
273−dropdown' k0 ks = do
274− (eRaw, _) <- elAttr' "select" ("class" =: "form-control") $ do
275− forM_ ks $ \(k, name) -> do
276− elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ text name
277− let e = castToHTMLSelectElement $ _el_element eRaw
278− eChange <- wrapDomEvent e elementOnchange $ do
279− kStr <- liftIO $ htmlSelectElementGetValue e
280− return $ readMay kStr
281− let readKey mk = fromMaybe k0 mk
282− dValue <- mapDyn readKey =<< holdDyn (Just k0) eChange
283− return $ Dropdown dValue
284−
285−listDropdown :: (MonadWidget t m) => Dynamic t [a] -> (a -> String) -> Dynamic t (Map String String) -> String -> m (Dynamic t (Maybe a))
286−listDropdown xs f attrs defS = do
287− m <- mapDyn (Map.fromList . zip [(1::Int)..]) xs
288− sel <- liftM _dropdown_value $ dropdownDynAttr attrs 0 never =<< mapDyn ((Map.insert 0 defS) . Map.map f) m
289− combineDyn Map.lookup sel m
290−
291−--TODO Remove CSS Classes
292−searchInputResult :: forall t m a. MonadWidget t m => Dynamic t (String, a) -> m (Event t (String, a))
293−searchInputResult r = el "li" $ do
294− (li, _) <- elAttr' "a" (Map.singleton "style" "cursor: pointer;") $ dynText =<< mapDyn fst r
295− return $ tag (current r) (_el_clicked li)
296−
297−searchInput :: forall t m a k. (MonadWidget t m, Ord k) => Map k (String, a) -> Event t (Map k (String, a)) -> m (Event t String, Event t (String, a))
298−searchInput initial results = searchInput' initial results searchInputResultsList
299−
300−searchInput' :: forall t m a k. (MonadWidget t m, Ord k) => Map k (String, a) -> Event t (Map k (String, a)) -> (Dynamic t (Map k (String, a)) -> m (Event t (String, a))) -> m (Event t String, Event t (String, a))
301−searchInput' initial results listBuilder = do
302− rec input <- input' "text" "" eSetValue $ constDyn $ Map.fromList [("class", "form-control"), ("placeholder", "Search")]
303− dResults <- holdDyn initial $ leftmost [eClearResults, results]
304− eMadeChoice <- listBuilder dResults
305− let eSetValue = fmap fst eMadeChoice
306− eSelectionMade = fmap (const Nothing) eSetValue
307− eInputChanged = fmapMaybe id $ leftmost [eSelectionMade, fmap Just (updated $ _textInput_value input)]
308− eInputEmpty = fmapMaybe id $ fmap (\i -> if i == "" then Just Map.empty else Nothing) eInputChanged
309− eClearResults = leftmost [eInputEmpty, fmap (const Map.empty) eMadeChoice]
310− return (eInputChanged, eMadeChoice)
311−
312−searchInputResultsList :: forall t m a k. (MonadWidget t m, Ord k) => Dynamic t (Map k (String, a)) -> m (Event t (String, a))
313−searchInputResultsList results = searchInputResultsList' results (flip list searchInputResult)
314−
315−searchInputResultsList' :: forall t m a k. (MonadWidget t m, Ord k) => Dynamic t (Map k (String, a)) -> (Dynamic t (Map k (String, a)) -> m (Dynamic t (Map k (Event t (String, a))))) -> m (Event t (String, a))
316−searchInputResultsList' results builder = do
317− let hideDropdown = Map.fromList [("class", "dropdown-menu"), ("style", "display: none;")]
318− showDropdown = Map.fromList [("class", "dropdown-menu"), ("style", "display: block;")]
319− attrs <- mapDyn (\rs -> if Map.null rs then hideDropdown else showDropdown) results
320− resultsList <- elDynAttr "ul" attrs $ builder results
321− liftM switch $ hold never $ fmap (leftmost . Map.elems) (updated resultsList)
322−
323186liftM concat $ mapM makeLenses
324187 [ ''TextAreaConfig
325188 , ''TextArea
189+ , ''TextInputConfig
326190 , ''TextInput
191+ , ''DropdownConfig
192+ , ''Dropdown
193+ , ''CheckboxConfig
194+ , ''Checkbox
327195 ]
328196
329197class HasAttributes a where
@@ -334,6 +202,18 @@ instance HasAttributes (TextAreaConfig t) where
334202 type Attrs (TextAreaConfig t) = Dynamic t (Map String String)
335203 attributes = textAreaConfig_attributes
336204
205+instance HasAttributes (TextInputConfig t) where
206+ type Attrs (TextInputConfig t) = Dynamic t (Map String String)
207+ attributes = textInputConfig_attributes
208+
209+instance HasAttributes (DropdownConfig t k) where
210+ type Attrs (DropdownConfig t k) = Dynamic t (Map String String)
211+ attributes = dropdownConfig_attributes
212+
213+instance HasAttributes (CheckboxConfig t) where
214+ type Attrs (CheckboxConfig t) = Dynamic t (Map String String)
215+ attributes = checkboxConfig_attributes
216+
337217class HasSetValue a where
338218 type SetValue a :: *
339219 setValue :: Lens' a (SetValue a)
@@ -341,3 +221,74 @@ class HasSetValue a where
341221instance HasSetValue (TextAreaConfig t) where
342222 type SetValue (TextAreaConfig t) = Event t String
343223 setValue = textAreaConfig_setValue
224+
225+instance HasSetValue (TextInputConfig t) where
226+ type SetValue (TextInputConfig t) = Event t String
227+ setValue = textInputConfig_setValue
228+
229+instance HasSetValue (DropdownConfig t k) where
230+ type SetValue (DropdownConfig t k) = Event t k
231+ setValue = dropdownConfig_setValue
232+
233+instance HasSetValue (CheckboxConfig t) where
234+ type SetValue (CheckboxConfig t) = Event t Bool
235+ setValue = checkboxConfig_setValue
236+
237+class HasValue a where
238+ type Value a :: *
239+ value :: a -> Value a
240+
241+instance HasValue (TextArea t) where
242+ type Value (TextArea t) = Dynamic t String
243+ value = _textArea_value
244+
245+instance HasValue (TextInput t) where
246+ type Value (TextInput t) = Dynamic t String
247+ value = _textInput_value
248+
249+instance HasValue (Dropdown t k) where
250+ type Value (Dropdown t k) = Dynamic t k
251+ value = _dropdown_value
252+
253+instance HasValue (Checkbox t) where
254+ type Value (Checkbox t) = Dynamic t Bool
255+ value = _checkbox_value
256+
257+{-
258+type family Controller sm t a where
259+ Controller Edit t a = (a, Event t a) -- Initial value and setter
260+ Controller View t a = Dynamic t a -- Value (always)
261+
262+type family Output sm t a where
263+ Output Edit t a = Dynamic t a -- Value (always)
264+ Output View t a = Event t a -- Requested changes
265+
266+data CheckboxConfig sm t
267+ = CheckboxConfig { _checkbox_input :: Controller sm t Bool
268+ , _checkbox_attributes :: Attributes
269+ }
270+
271+instance Reflex t => Default (CheckboxConfig Edit t) where
272+ def = CheckboxConfig (False, never) mempty
273+
274+data Checkbox sm t
275+ = Checkbox { _checkbox_output :: Output sm t Bool
276+ }
277+
278+data StateMode = Edit | View
279+
280+--TODO: There must be a more generic way to get this witness and allow us to case on the type-level StateMode
281+data StateModeWitness (sm :: StateMode) where
282+ EditWitness :: StateModeWitness Edit
283+ ViewWitness :: StateModeWitness View
284+
285+class HasStateModeWitness (sm :: StateMode) where
286+ stateModeWitness :: StateModeWitness sm
287+
288+instance HasStateModeWitness Edit where
289+ stateModeWitness = EditWitness
290+
291+instance HasStateModeWitness View where
292+ stateModeWitness = ViewWitness
293+-}
294+