Initial commit

.ghci

@@ -0,0 +1,3 @@
+:set -isrc
+:set -hide-package MonadCatchIO-mtl
+:set -hide-package monads-fd

.gitignore

@@ -0,0 +1,31 @@
+dist
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_hi
+*.dyn_o
+*.p_hi
+*.p_o
+*.js_dyn_hi
+*.js_dyn_o
+*.js_p_hi
+*.js_p_o
+*.js_o
+*.js_hi
+.virthualenv
+.hsenv*
+*.*~
+*.swp
+.DS_Store
+backend.pid
+backend.out
+.shelly
+TAGS
+tags
+*~
+*.orig
+hsenv.log
+\#*#
+.#*

default.nix

@@ -0,0 +1,28 @@
+{ cabal, dependentMap, ghcjsDom, lens
+, mtl, reflex, safe, text, these
+, transformers, dataDefault, semigroups
+}:
+
+cabal.mkDerivation (self: {
+  pname = "reflex-dom";
+  version = "0.1";
+  src = ./.;
+  buildDepends = [
+    reflex
+    dependentMap
+    mtl
+    transformers
+    these
+    lens
+    ghcjsDom
+    safe
+    text
+    dataDefault
+    semigroups
+  ];
+  meta = {
+    description = "Functional Reactive DOM widgets";
+    license = self.stdenv.lib.licenses.unfree;
+    platforms = self.ghc.meta.platforms;
+  };
+})

reflex-dom.cabal

@@ -0,0 +1,43 @@
+Name: reflex-dom
+Version: 0.1
+Synopsis: Glitch-free Functional Reactive Programming
+Description: Reflex is a Functional Reactive Programming implementation that provides strong guarantees of deterministic execution and scalable runtime performance
+License: AllRightsReserved
+License-file: LICENSE
+Author: Ryan Trinkle
+Maintainer: ryan.trinkle@gmail.com
+Stability: Experimental
+Category: FRP
+Build-type: Simple
+Cabal-version: >=1.2
+
+library
+  hs-source-dirs: src
+  build-depends:
+    base,
+    reflex,
+    dependent-map,
+    dependent-sum,
+    mtl,
+    transformers,
+    containers,
+    these,
+    lens,
+    ghcjs-dom,
+    safe,
+    text,
+    bytestring,
+    data-default,
+    semigroups
+
+  exposed-modules:
+    Reflex.Dom
+    Reflex.Dom.Class
+    Reflex.Dom.Internal
+    Reflex.Dom.Widget
+    Reflex.Dom.Widget.Basic
+    Reflex.Dom.Widget.Input
+
+  other-extensions: TemplateHaskell
+  ghc-prof-options: -fprof-auto
+  ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2

src/Reflex/Dom.hs

@@ -0,0 +1,8 @@
+module Reflex.Dom ( module Reflex.Dom.Class
+                  , module Reflex.Dom.Internal
+                  , module Reflex.Dom.Widget
+                  ) where
+
+import Reflex.Dom.Class
+import Reflex.Dom.Internal
+import Reflex.Dom.Widget

src/Reflex/Dom/Class.hs

@@ -0,0 +1,440 @@
+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, PolyKinds, TypeOperators, DeriveFunctor, LambdaCase, CPP, ForeignFunctionInterface, DeriveDataTypeable, ConstraintKinds #-}
+module Reflex.Dom.Class where
+
+import Prelude hiding (mapM, mapM_, sequence, concat)
+
+import Reflex
+import Reflex.Host.Class
+
+import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence)
+import Control.Lens hiding ((<|))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Traversable
+import Data.Foldable
+import Control.Monad.Ref
+import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence)
+import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)
+import qualified Data.Dependent.Map as DMap
+import Data.Dependent.Sum (DSum (..))
+import Data.IORef
+import Data.These
+import Data.Align
+import GHCJS.DOM.Types hiding (Event)
+import GHCJS.DOM.Document
+import GHCJS.DOM.Node
+import GHCJS.DOM.NamedNodeMap
+import GHCJS.DOM.Element
+import GHCJS.DOM.HTMLElement
+import GHCJS.DOM.HTMLInputElement
+import GHCJS.DOM.HTMLSelectElement
+import GHCJS.DOM.HTMLTextAreaElement
+import GHCJS.DOM.UIEvent
+import GHCJS.DOM.EventM (event, preventDefault)
+import Data.Dependent.Map (DMap)
+import Safe
+
+-- | Alias for Data.Map.singleton
+(=:) :: k -> a -> Map k a
+(=:) = Map.singleton
+
+keycodeEnter :: Int
+keycodeEnter = 13
+
+keycodeEscape :: Int
+keycodeEscape = 27
+
+class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m
+      , HasDocument m
+      , MonadIO (WidgetHost m), Functor (WidgetHost m), MonadSample t (WidgetHost m)
+      , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)
+      , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO
+      , MonadFix m
+      ) => MonadWidget t m | m -> t where
+  type WidgetHost m :: * -> *
+  type GuiAction m :: * -> *
+  askParent :: m Node
+  subWidget :: Node -> m a -> m a
+  schedulePostBuild :: WidgetHost m () -> m ()
+  addVoidAction :: Event t (WidgetHost m ()) -> m ()
+  getRunWidget :: IsNode n => m (n -> m a -> WidgetHost m (a, Event t (WidgetHost m ())))
+
+class Monad m => HasDocument m where
+  askDocument :: m HTMLDocument
+
+instance HasDocument m => HasDocument (ReaderT r m) where
+  askDocument = lift askDocument
+
+instance HasDocument m => HasDocument (StateT r m) where
+  askDocument = lift askDocument
+
+class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where
+  askPostGui :: m (h () -> IO ())
+  askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())
+
+runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
+runFrameWithTriggerRef r a = do
+  postGui <- askPostGui
+  runWithActions <- askRunWithActions
+  liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef r  
+
+instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where
+  askPostGui = lift askPostGui
+  askRunWithActions = lift askRunWithActions
+
+instance MonadWidget t m => MonadWidget t (ReaderT r m) where
+  type WidgetHost (ReaderT r m) = WidgetHost m
+  type GuiAction (ReaderT r m) = GuiAction m
+  askParent = lift askParent
+  subWidget n w = do
+    r <- ask
+    lift $ subWidget n $ runReaderT w r
+  schedulePostBuild = lift . schedulePostBuild
+  addVoidAction = lift . addVoidAction
+  getRunWidget = do
+    r <- ask
+    runWidget <- lift getRunWidget
+    return $ \rootElement w -> runWidget rootElement $ runReaderT w r
+
+performEvent_ = addVoidAction
+
+performEvent e = do
+  (eResult, reResultTrigger) <- newEventWithTriggerRef
+  addVoidAction $ ffor e $ \o -> do
+    result <- o
+    runFrameWithTriggerRef reResultTrigger result
+  return eResult
+
+performEventAsync :: forall t m a. MonadWidget t m => Event t ((a -> IO ()) -> WidgetHost m ()) -> m (Event t a)
+performEventAsync e = do
+  (eResult, reResultTrigger) <- newEventWithTriggerRef
+  addVoidAction $ ffor e $ \o -> do
+    postGui <- askPostGui
+    runWithActions <- askRunWithActions
+    o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef reResultTrigger
+  return eResult
+
+--------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
+{-
+
+class HasRunFrame t m | m -> t where
+  askRunFrame :: m (DMap (EventTrigger t) -> IO ())
+
+type MonadWidget t h m = (MonadWidget' t h m, MonadWidget' t h (WidgetEventM m))
+
+--TODO: Remove Spider hardcoding
+class (t ~ Spider, Reflex t, MonadHold t m, ReflexHost t, HasRunFrame t h, MonadReflexHost t h, MonadIO h, MonadRef h, Ref h ~ IORef, MonadFix h, HasDocument h, MonadSample t (WidgetEventM m), WidgetEventM m ~ WidgetEventM (WidgetEventM m), MonadFix m) => MonadWidget' t h m | m -> t h where
+
+  type WidgetEventM m :: * -> *
+  -- | Warning: dAttributes should not contain "id" attributes
+  elDynAttr' :: String -> Dynamic t (Map String String) -> m a -> m (El t, a)
+  performEvent :: Event t (h a) -> m (Event t a)
+  performEvent_ :: Event t (h ()) -> m ()
+  getEInit :: m (Event t ())
+  putEChildren :: Event t [Node] -> m ()
+  dyn :: Dynamic t (WidgetEventM m a) -> m (Event t a) --TODO: Should probably return Dynamic t a
+  listWithKey :: (Ord k, Show k) => Dynamic t (Map k v) -> (k -> Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v'))
+  text :: String -> m ()
+  dynText :: Dynamic t String -> m ()
+
+{-# INLINABLE performEventAsync #-}
+performEventAsync :: forall t h m a. (MonadWidget t h m) => Event t ((a -> IO ()) -> h ()) -> m (Event t a)
+performEventAsync eAction = do
+  let setup mAction = do
+        (eResult, reResultTrigger) <- newEventWithTriggerRef
+        runFrame <- askRunFrame
+        let runAction a = a $ \x -> readRef reResultTrigger >>= mapM_ (\eResultTrigger -> runFrame $ DMap.singleton eResultTrigger x)
+        maybe (return ()) runAction mAction
+        return (eResult, runAction)
+  eSetup <- performEvent . fmap (setup . (^?here)) . align eAction =<< getEInit
+  dRunAction <- holdDyn Nothing $ fmap (Just . snd) eSetup
+  performEvent_ $ attachDynWith (\mRunAction a -> maybe (return ()) ($ a) mRunAction) dRunAction eAction -- Note: this will never fire while eInit is firing, but that situation should be handled in setup; this relies on all the results from the first performEvent being fired simultaneously; otherwise, an eAction could potentially sneak in between setup being sent to performEvent and the result coming back
+  switchPromptly never (fmap fst eSetup)
+
+data TextInput t
+  = TextInput { _textInput_value :: Dynamic t String
+              , _textInput_keypress :: Event t Int
+              , _textInput_keydown :: Event t Int
+              , _textInput_keyup :: Event t Int
+              , _textInput_hasFocus :: Dynamic t Bool
+              , _textInput_element :: Dynamic t (Maybe HTMLInputElement)
+              }
+
+textInputGetEnter :: Reflex t => TextInput t -> Event t ()
+textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i
+
+setElementAttributes :: IsElement self => self -> Map String String -> IO ()
+setElementAttributes e attrs = do
+  oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
+  forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet attrs) $ elementRemoveAttribute e
+  iforM_ attrs $ elementSetAttribute e
+
+wrapDomEvent :: (HasRunFrame t h, MonadIO m, MonadReflexHost t h, MonadIO h) => e -> (e -> m () -> IO (IO ())) -> m a -> h (Event t a)
+wrapDomEvent self elementOnevent getValue = do
+  runFrame <- askRunFrame
+  e <- newEventWithTrigger $ \et -> do
+    unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent self $ {-# SCC "c" #-} do
+      v <- {-# SCC "d" #-} getValue
+      liftIO $ runFrame $ DMap.singleton et v
+    return $ liftIO $ do
+      {-# SCC "e" #-} unsubscribe
+  return $! {-# SCC "f" #-} e
+
+{-# INLINABLE input #-}
+input' :: MonadWidget t h m => String -> Event t String -> Dynamic t (Map String String) -> m (TextInput t)
+input' inputType eSetValue dAttrs = do
+  dEffectiveAttrs <- mapDyn (Map.insert "type" inputType) dAttrs
+  let mkSelf (initialValue, initialAttrs) = do
+        doc <- askDocument
+        Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
+        liftIO $ htmlInputElementSetValue e initialValue
+        iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
+        eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
+        runFrame <- askRunFrame
+        eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
+          unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
+            runFrame $ DMap.singleton eChangeFocusTrigger False
+          unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
+            runFrame $ DMap.singleton eChangeFocusTrigger True
+          return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
+        eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
+        eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
+        eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
+        return (e, eChange, eKeypress, eKeydown, eKeyup, eChangeFocus)
+  dInitialValue <- holdDyn "" eSetValue
+  dInitial <- combineDyn (,) dInitialValue dEffectiveAttrs
+  eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
+  dMyElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
+  performEvent_ . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dEffectiveAttrs
+  putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
+  performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlInputElementSetValue e v) $ attachWith (\e v -> case e of
+    Nothing -> Nothing
+    Just e' -> Just (e',v)) (current dMyElement) eSetValue
+  eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
+  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
+  dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
+  eKeypress <- liftM switch $ hold never $ fmap (^. _3) eCreated
+  eKeydown <- liftM switch $ hold never $ fmap (^. _4) eCreated
+  eKeyup <- liftM switch $ hold never $ fmap (^. _5) eCreated
+  return $ TextInput dValue eKeypress eKeydown eKeyup dFocus dMyElement
+
+input :: MonadWidget t h m => String -> Map String String -> m (TextInput t)
+input t as = input' t never (constDyn as)
+
+data TextArea t
+  = TextArea { _textArea_value :: Dynamic t String
+             , _textArea_element :: Dynamic t (Maybe HTMLTextAreaElement)
+             }
+
+textArea' :: MonadWidget t h m => Event t String -> Dynamic t (Map String String) -> m (TextArea t)
+textArea' eSetValue dAttrs = do
+  let mkSelf (initialValue, initialAttrs) = do
+        doc <- askDocument
+        Just e <- liftIO $ liftM (fmap castToHTMLTextAreaElement) $ documentCreateElement doc "textarea"
+        liftIO $ htmlTextAreaElementSetValue e initialValue
+        iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
+        eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e
+        return (e, eChange)
+  dInitialValue <- holdDyn "" eSetValue
+  dInitial <- combineDyn (,) dInitialValue dAttrs
+  eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
+  dMyElement <- holdDyn Nothing $ fmap (Just . fst) eCreated
+  --performEvent . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dAttrs
+  putEChildren $ fmap ((:[]) . toNode . fst) eCreated
+  performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlTextAreaElementSetValue e v) $ attachWith (\e v -> case e of
+    Nothing -> Nothing
+    Just e' -> Just (e',v)) (current dMyElement) eSetValue
+  eChange <- liftM switch $ hold never $ fmap snd eCreated
+  dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
+  return $ TextArea dValue dMyElement
+
+
+data Checkbox t
+  = Checkbox { _checkbox_checked :: Dynamic t Bool
+             }
+
+checkbox :: MonadWidget t h m => Bool -> Map String String -> m (Checkbox t)
+checkbox checked attrs = do
+  let mkSelf = do
+        doc <- askDocument
+        Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
+        liftIO $ elementSetAttribute e "type" "checkbox"
+        iforM_ attrs $ \attr value -> liftIO $ elementSetAttribute e attr value
+        if checked == True then liftIO $ elementSetAttribute e "checked" "true" else return ()
+        eChange <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e
+        return ([toNode e], eChange)
+  eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
+  putEChildren $ fmap (^. _1) eCreated
+  eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
+  dValue <- holdDyn checked eChange
+  return $ Checkbox dValue
+
+checkboxView :: MonadWidget t h m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t ())
+checkboxView dAttrs dValue = do
+  dEffectiveAttrs <- mapDyn (Map.insert "type" "checkbox") dAttrs
+  let mkSelf (initialValue, initialAttrs) = do
+        doc <- askDocument
+        Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
+        iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
+        liftIO $ htmlInputElementSetChecked e initialValue
+        eClicked <- wrapDomEvent e elementOnclick preventDefault
+        return (e, eClicked)
+  dInitial <- combineDyn (,) dValue dEffectiveAttrs
+  eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
+  putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
+  dElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
+  performEvent_ . updated =<< combineDyn (\me a -> forM_ me $ \e -> liftIO $ setElementAttributes e a) dElement dEffectiveAttrs
+  performEvent_ . updated =<< combineDyn (\v me -> maybe (return ()) (\e -> liftIO $ htmlInputElementSetChecked e v) me) dValue dElement
+  liftM switch $ hold never $ fmap (^. _2) eCreated
+
+{-# INLINABLE textInput #-}
+textInput :: MonadWidget t h m => m (TextInput t)
+textInput = input "text" $ Map.singleton "class" "form-control"
+
+data Dropdown t k
+  = Dropdown { _dropdown_value :: Dynamic t k
+             }
+
+setInnerText :: (HasDocument m, IsHTMLElement self, MonadIO m) => self -> String -> m (Maybe Node)
+setInnerText e s = do
+  liftIO $ htmlElementSetInnerHTML e ""
+  doc <- askDocument
+  t <- liftIO $ documentCreateTextNode doc s
+  liftIO $ nodeAppendChild e t
+
+--TODO: Retain set value when allowed values changes
+{-# INLINABLE dropdown #-}
+dropdown :: forall t h m k. (MonadWidget t h m, Show k, Read k) => Dynamic t (Map k String) -> m (Dropdown t (Maybe k))
+dropdown dOptions = do
+  let triggerChange (e, reChangeTrigger) runFrame = do
+        v <- htmlSelectElementGetValue e
+        readRef reChangeTrigger >>= mapM_ (\eChangeTrigger -> runFrame $ DMap.singleton eChangeTrigger $ readMay v)
+  let mkSelf = do
+        doc <- askDocument
+        Just e <- liftIO $ liftM (fmap castToHTMLSelectElement) $ documentCreateElement doc "select"
+        liftIO $ elementSetAttribute e "class" "form-control"
+        runFrame <- askRunFrame
+        reChangeTrigger <- newRef Nothing
+        eChange <- newEventWithTrigger $ \eChangeTrigger -> do
+          writeRef reChangeTrigger $ Just eChangeTrigger
+          unsubscribe <- liftIO $ elementOnchange e $ liftIO $ triggerChange (e, reChangeTrigger) runFrame
+          return $ do
+            writeRef reChangeTrigger Nothing
+            liftIO unsubscribe
+        return ((e, reChangeTrigger), eChange)
+  eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
+  dState <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
+  putEChildren $ fmap ((:[]) . toNode . fst . (^. _1)) eCreated
+  let updateOptions :: Map k String -> Maybe (HTMLSelectElement, Ref h (Maybe (EventTrigger t (Maybe k)))) -> h ()
+      updateOptions options = maybe (return ()) $ \myState@(selectElement, _) -> do
+        doc <- askDocument
+        liftIO $ htmlElementSetInnerHTML selectElement ""
+        iforM_ options $ \k optionText -> do
+          Just optionElement <- liftIO $ liftM (fmap castToHTMLOptionElement) $ documentCreateElement doc "option"
+          liftIO $ elementSetAttribute optionElement "value" $ show k
+          _ <- setInnerText optionElement optionText
+          liftIO $ nodeAppendChild selectElement $ Just optionElement
+        runFrame <- askRunFrame
+        liftIO $ triggerChange myState runFrame
+  performEvent_ . updated =<< combineDyn updateOptions dOptions dState
+  eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
+  dValue <- holdDyn Nothing eChange
+  return $ Dropdown dValue
+
+data Link t
+  = Link { _link_clicked :: Event t ()
+         }
+
+linkClassWithExtraSetup :: MonadWidget t h m => (HTMLElement -> h ()) -> String -> String -> m (Link t)
+linkClassWithExtraSetup extraSetup s c = do
+  let mkSelf = do
+        doc <- askDocument
+        Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "a"
+        _ <- setInnerText e s
+        liftIO $ elementSetAttribute e "class" c
+        eClicked <- wrapDomEvent e elementOnclick $ return ()
+        extraSetup e
+        return ([toNode e], eClicked)
+  eCreated <- performEvent . fmap (const mkSelf) =<< getEInit
+  putEChildren $ fmap (^. _1) eCreated
+  eClicked <- liftM switch $ hold never $ fmap (^. _2) eCreated
+  return $ Link eClicked
+
+{-# INLINABLE linkClass #-}
+linkClass :: MonadWidget t h m => String -> String -> m (Link t)
+linkClass = linkClassWithExtraSetup $ const $ return ()
+
+{-# INLINABLE link #-}
+link :: MonadWidget t h m => String -> m (Link t)
+link s = linkClass s ""
+
+{-# INLINABLE button #-}
+button :: MonadWidget t h m => String -> m (Link t)
+button s = linkClass s "btn btn-primary"
+
+{-# INLINABLE elAttr #-}
+elAttr :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m a
+elAttr elementTag attrs child = liftM snd $ elAttr' elementTag attrs child
+
+{-# INLINABLE el' #-}
+el' :: forall t h m a. MonadWidget t h m => String -> m a -> m (El t, a)
+el' elementTag child = elAttr' elementTag Map.empty child
+
+{-# INLINABLE elAttr' #-}
+elAttr' :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m (El t, a)
+elAttr' elementTag attrs child = do
+  dAttributes <- holdDyn attrs never
+  elDynAttr' elementTag dAttributes child
+
+{-# INLINABLE elDynAttr #-}
+elDynAttr :: forall t h m a. MonadWidget t h m => String -> Dynamic t (Map String String) -> m a -> m a
+elDynAttr elementTag dAttributes child = liftM snd $ elDynAttr' elementTag dAttributes child
+
+{-# INLINABLE el #-}
+el :: forall t h m a. MonadWidget t h m => String -> m a -> m a
+el elementTag child = elAttr elementTag Map.empty child
+
+newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
+
+workflowView :: forall t h m a. MonadWidget t h m => Workflow t (WidgetEventM m) a -> m (Event t a)
+workflowView w0 = do
+  rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
+      eReplace <- liftM switch $ hold never $ fmap snd eResult
+      eResult `seq` eReplace `seq` return ()
+  return $ fmap fst eResult
+
+insertNext :: (Ord k, Enum k) => v -> Map k v -> Map k v
+insertNext v m =
+  let k = case Map.maxViewWithKey m of
+        Nothing -> toEnum 0
+        Just ((k0, _), _) -> succ k0
+  in Map.insert k v m
+
+{-# INLINABLE oldList #-}
+oldList :: (MonadWidget t h m, MonadWidget t h (WidgetEventM m), Ord k, Show k) => Dynamic t (Map k (WidgetEventM m v')) -> m (Dynamic t (Map k ()))
+oldList dm = el "ul" $ list dm (\dv -> el "li" (dyn dv) >> return ())
+
+{-# INLINABLE list #-}
+list :: forall t m h k v v'. (MonadWidget t h m, Ord k, Show k) => Dynamic t (Map k v) -> (Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v'))
+list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
+
+instance MonadWidget' t h m => MonadWidget' t h (ReaderT r m) where
+  type WidgetEventM (ReaderT r m) = ReaderT r (WidgetEventM m)
+  elDynAttr' tag dAttrs = mapReaderT (elDynAttr' tag dAttrs)
+  performEvent = lift . performEvent
+  performEvent_ = lift . performEvent_
+  getEInit = lift getEInit
+  putEChildren = lift . putEChildren
+  dyn d = do
+    r <- ask
+    lift $ dyn =<< mapDyn (flip runReaderT r) d
+  listWithKey d w = do
+    r <- ask
+    lift $ listWithKey d $ \k dv -> runReaderT (w k dv) r
+  text = lift . text
+  dynText = lift . dynText
+
+-}

src/Reflex/Dom/Internal.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, ConstraintKinds #-}
+module Reflex.Dom.Internal where
+
+import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)
+
+import Reflex.Dom.Class
+
+import GHCJS.DOM
+import GHCJS.DOM.Types hiding (Widget, unWidget, Event)
+import GHCJS.DOM.Node
+import GHCJS.DOM.Element
+import GHCJS.DOM.HTMLElement
+import GHCJS.DOM.HTMLInputElement
+import GHCJS.DOM.NamedNodeMap
+import GHCJS.DOM.Document
+import GHCJS.DOM.UIEvent
+import GHCJS.DOM.EventM (event, Signal (..))
+import Reflex.Class
+import Reflex.Dynamic
+import Reflex.Host.Class
+import Reflex.Spider (Spider, SpiderHost (..))
+import qualified Reflex.Spider
+import Control.Lens
+import Control.Applicative
+import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
+import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
+import Control.Monad.Ref
+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Control.Concurrent
+import Data.Dependent.Sum (DSum (..))
+import Data.Dependent.Map (DMap)
+import qualified Data.Dependent.Map as DMap
+import Data.Foldable
+import Data.Traversable
+import Data.IORef
+import Data.Align
+import Data.These
+import Data.ByteString (ByteString)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Data.Monoid ((<>))
+
+import System.IO.Unsafe
+
+data GuiEnv t h
+   = GuiEnv { _guiEnvDocument :: !HTMLDocument
+            , _guiEnvPostGui :: !(h () -> IO ())
+            , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())
+            }
+
+--TODO: Poorly named
+newtype Gui t h m a = Gui { unGui :: ReaderT (GuiEnv t h) m a } deriving (Functor, Monad, MonadIO, MonadFix)
+
+runGui :: Gui t h m a -> GuiEnv t h -> m a
+runGui (Gui g) env = runReaderT g env
+
+instance MonadTrans (Gui t h) where
+  lift = Gui . lift
+
+instance MonadRef m => MonadRef (Gui t h m) where
+  type Ref (Gui t h m) = Ref m
+  newRef = lift . newRef
+  readRef = lift . readRef
+  writeRef r = lift . writeRef r
+  atomicModifyRef r f = lift $ atomicModifyRef r f
+
+instance MonadSample t m => MonadSample t (Gui t h m) where
+  sample b = lift $ sample b
+
+instance MonadHold t m => MonadHold t (Gui t h m) where
+  hold a0 e = lift $ hold a0 e
+
+instance (Reflex t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (Gui t h m) where
+  newEventWithTrigger initializer = lift $ newEventWithTrigger initializer
+
+data WidgetEnv
+   = WidgetEnv { _widgetEnvParent :: !Node
+               }
+
+data WidgetState t m
+   = WidgetState { _widgetStatePostBuild :: !(m ())
+                 , _widgetStateVoidActions :: ![Event t (m ())] --TODO: Would it help to make this a strict list?
+                 }
+
+liftM concat $ mapM makeLenses
+  [ ''WidgetEnv
+  , ''WidgetState
+  , ''GuiEnv
+  ]
+
+instance Monad m => HasDocument (Gui t h m) where
+  askDocument = Gui $ view guiEnvDocument
+
+instance HasDocument m => HasDocument (Widget t m) where
+  askDocument = lift askDocument
+
+instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h m) where
+  askPostGui = Gui $ view guiEnvPostGui
+  askRunWithActions = Gui $ view guiEnvRunWithActions
+
+instance HasPostGui t h m => HasPostGui t h (Widget t m) where
+  askPostGui = lift askPostGui
+  askRunWithActions = lift askRunWithActions
+
+type WidgetInternal t m a = ReaderT WidgetEnv (StateT (WidgetState t m) m) a
+
+instance MonadTrans (Widget t) where
+  lift = Widget . lift . lift
+
+newtype Widget t m a = Widget { unWidget :: WidgetInternal t m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
+
+instance MonadSample t m => MonadSample t (Widget t m) where
+  sample b = lift $ sample b
+
+instance MonadHold t m => MonadHold t (Widget t m) where
+  hold v0 e = lift $ hold v0 e
+
+-- Need to build FRP circuit first, then elements
+  -- Can't read from FRP until the whole thing is built
+--TODO: Use JSString when in JS
+
+instance MonadRef m => MonadRef (Widget t m) where
+  type Ref (Widget t m) = Ref m
+  newRef = lift . newRef
+  readRef = lift . readRef
+  writeRef r = lift . writeRef r
+  atomicModifyRef r f = lift $ atomicModifyRef r f
+
+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Widget t m) where
+  newEventWithTrigger = lift . newEventWithTrigger
+
+instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO
+         , MonadIO m, Functor m
+         , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m
+         , MonadFix m
+         ) => MonadWidget t (Widget t (Gui t h m)) where
+  type WidgetHost (Widget t (Gui t h m)) = Gui t h m
+  type GuiAction (Widget t (Gui t h m)) = h
+  askParent = Widget $ view widgetEnvParent
+  --TODO: Use types to separate cohorts of possibly-recursive events/behaviors
+  -- | Schedule an action to occur after the current cohort has been built; this is necessary because Behaviors built in the current cohort may not be read until after it is complete
+  --schedulePostBuild :: Monad m => m () -> WidgetInternal t m ()
+  schedulePostBuild a = Widget $ widgetStatePostBuild %= (a>>) --TODO: Can this >> be made strict?
+
+  --addVoidAction :: Monad m => Event t (m ()) -> WidgetInternal t m ()
+  addVoidAction a = Widget $ widgetStateVoidActions %= (a:)
+  subWidget n child = Widget $ local (widgetEnvParent .~ toNode n) $ unWidget child
+--  runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))
+  getRunWidget = return runWidget
+
+runWidget rootElement w = do
+  (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])
+  let voidAction = mergeWith (>>) voidActions
+  postBuild --TODO: This should be run some other way; it seems to cause strictness problems when recursion crosses parent/child boundaries
+  return (result, voidAction)
+
+holdOnStartup :: MonadWidget t m => a -> WidgetHost m a -> m (Behavior t a)
+holdOnStartup a0 ma = do
+  (startupDone, startupDoneTriggerRef) <- newEventWithTriggerRef
+  schedulePostBuild $ do
+    a <- ma
+    runFrameWithTriggerRef startupDoneTriggerRef a
+  hold a0 startupDone
+
+mainWidget :: Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()
+mainWidget w = runWebGUI $ \webView -> do
+  Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
+  Just body <- documentGetBody doc
+  attachWidget body w
+
+mainWidgetWithCss css w = runWebGUI $ \webView -> do
+  Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
+  Just head <- liftM (fmap castToHTMLElement) $ documentGetHead doc
+  htmlElementSetInnerHTML head $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
+  Just body <- documentGetBody doc
+  attachWidget body w
+
+attachWidget :: (IsHTMLElement e) => e -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) a -> IO a
+attachWidget rootElement w = runSpiderHost $ do --TODO: It seems to re-run this handler if the URL changes, even if it's only the fragment
+  Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement
+  liftIO $ putStrLn "Using Widget2"
+  frames <- liftIO newChan
+  rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost) runWithActions :: GuiEnv Spider SpiderHost
+          runWithActions dm = do
+            voidActionNeeded <- fireEventsAndRead dm $ do
+              sequence =<< readEvent voidAction
+            runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv
+      Just df <- liftIO $ documentCreateDocumentFragment doc
+      (result, voidAction) <- runHostFrame $ runGui (runWidget df w) guiEnv
+      liftIO $ htmlElementSetInnerHTML rootElement ""
+      liftIO $ nodeAppendChild rootElement $ Just df
+      subscribeEvent voidAction --TODO: Should be unnecessary
+--  currentFrame <- liftIO $ newEmptyMVar
+--  idleAdd (tryTakeMVar currentFrame >>= maybe (return ()) id >> return True) priorityLow --TODO: avoid wasting CPU here
+--  forkIO $ forever $ putMVar currentFrame =<< readChan frames
+  --postGUISync seems to leak memory on GHC (unknown on GHCJS)
+  liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe
+  return result
+
+--type MonadWidget t h m = (t ~ Spider, h ~ Gui Spider SpiderHost (HostFrame Spider), m ~ Widget t h, Monad h, MonadHold t h, HasDocument h, MonadSample t h, MonadRef h, MonadIO h, Functor (Event t), Functor h, Reflex t) -- Locking down these types seems to help a little in GHCJS, but not really in GHC
+

src/Reflex/Dom/Widget.hs

@@ -0,0 +1,6 @@
+module Reflex.Dom.Widget ( module Reflex.Dom.Widget.Basic
+                         , module Reflex.Dom.Widget.Input
+                         ) where
+
+import Reflex.Dom.Widget.Basic
+import Reflex.Dom.Widget.Input

src/Reflex/Dom/Widget/Basic.hs

@@ -0,0 +1,375 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo #-}
+
+module Reflex.Dom.Widget.Basic where
+
+import Reflex.Dom.Class
+
+import Reflex
+import Reflex.Host.Class
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Dependent.Sum (DSum (..))
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Ref
+import GHCJS.DOM.Node
+import GHCJS.DOM.UIEvent
+import GHCJS.DOM.EventM (event, Signal)
+import GHCJS.DOM.Document
+import GHCJS.DOM.Element
+import GHCJS.DOM.HTMLElement
+import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
+import GHCJS.DOM.NamedNodeMap
+import Control.Lens
+import Data.Monoid
+import Data.These
+import Data.Align
+
+import Data.Maybe
+
+type AttributeMap = Map String String
+
+data El t
+  = El { _el_element :: HTMLElement
+       , _el_clicked :: Event t ()
+       , _el_keypress :: Event t Int
+       }
+
+class Attributes m a where
+  addAttributes :: IsElement e => a -> e -> m ()
+
+instance MonadIO m => Attributes m AttributeMap where
+  addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
+
+instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
+  addAttributes attrs e = do
+    schedulePostBuild $ do
+      curAttrs <- sample $ current attrs
+      liftIO $ imapM_ (elementSetAttribute e) curAttrs
+    addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
+      oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
+      forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
+      imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
+
+buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
+buildEmptyElement elementTag attrs = do
+  doc <- askDocument
+  p <- askParent
+  Just e <- liftIO $ documentCreateElement doc elementTag
+  addAttributes attrs e
+  _ <- liftIO $ nodeAppendChild p $ Just e
+  return $ castToHTMLElement e
+
+-- We need to decide what type of attrs we've got statically, because it will often be a recursively defined value, in which case inspecting it will lead to a cycle
+buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
+buildElement elementTag attrs child = do
+  e <- buildEmptyElement elementTag attrs
+  result <- subWidget (toNode e) child
+  return (e, result)
+
+namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
+namedNodeMapGetNames self = do
+  l <- namedNodeMapGetLength self
+  let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around
+  liftM Set.fromList $ forM locations $ \i -> do
+    Just n <- namedNodeMapItem self i
+    nodeGetNodeName n
+
+text :: MonadWidget t m => String -> m ()
+text = void . text'
+
+--TODO: Wrap the result
+text' :: MonadWidget t m => String -> m Text
+text' s = do
+  doc <- askDocument
+  p <- askParent
+  Just n <- liftIO $ documentCreateTextNode doc s
+  _ <- liftIO $ nodeAppendChild p $ Just n
+  return n
+
+dynText :: MonadWidget t m => Dynamic t String -> m ()
+dynText s = do
+  n <- text' ""
+  schedulePostBuild $ do
+    curS <- sample $ current s
+    liftIO $ nodeSetNodeValue n curS
+  addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
+
+--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
+dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
+dyn child = do
+  startPlaceholder <- text' ""
+  endPlaceholder <- text' ""
+  (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
+  let e = fmap snd newChildBuilt --TODO: Get rid of this hack
+  childVoidAction <- hold never e
+  performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack
+  addVoidAction $ switch childVoidAction
+  doc <- askDocument
+  runWidget <- getRunWidget
+  let build c = do
+        Just df <- liftIO $ documentCreateDocumentFragment doc
+        result <- runWidget df c
+        runFrameWithTriggerRef newChildBuiltTriggerRef result
+        Just p <- liftIO $ nodeGetParentNode endPlaceholder
+        liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
+        return ()
+  schedulePostBuild $ do
+    c <- sample $ current child
+    build c
+  addVoidAction $ ffor (updated child) $ \newChild -> do
+    liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
+    build newChild
+  return $ fmap fst newChildBuilt
+
+widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
+widgetHold child0 newChild = do
+  startPlaceholder <- text' ""
+  result0 <- child0
+  endPlaceholder <- text' ""
+  (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
+  childVoidAction <- hold never $ fmap snd newChildBuilt
+  addVoidAction $ switch childVoidAction
+  doc <- askDocument
+  runWidget <- getRunWidget
+  let build c = do
+        Just df <- liftIO $ documentCreateDocumentFragment doc
+        result <- runWidget df c
+        runFrameWithTriggerRef newChildBuiltTriggerRef result
+        Just p <- liftIO $ nodeGetParentNode endPlaceholder
+        liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
+        return ()
+  addVoidAction $ ffor newChild $ \c -> do
+    liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
+    build c
+  holdDyn result0 $ fmap fst newChildBuilt
+
+--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
+listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
+listWithKey vals mkChild = do
+  doc <- askDocument
+  startPlaceholder <- text' ""
+  endPlaceholder <- text' ""
+  (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
+  performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
+  children <- hold Map.empty $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
+  addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
+  runWidget <- getRunWidget
+  let buildChild df k v = runWidget df $ do
+        childStart <- text' ""
+        result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
+        childEnd <- text' ""
+        return (result, (childStart, childEnd))
+  schedulePostBuild $ do
+    Just df <- liftIO $ documentCreateDocumentFragment doc
+    curVals <- sample $ current vals
+    initialState <- iforM curVals $ buildChild df
+    runFrameWithTriggerRef newChildrenTriggerRef initialState --TODO: Do all these in a single runFrame
+    Just p <- liftIO $ nodeGetParentNode endPlaceholder
+    liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
+    return ()
+  addVoidAction $ flip fmap (updated vals) $ \newVals -> do
+    curState <- sample children
+    --TODO: Should we remove the parent from the DOM first to avoid reflows?
+    newState <- liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
+      This ((_, (start, end)), _) -> do
+        liftIO $ putStrLn "Deleting item"
+        liftIO $ deleteBetweenInclusive start end
+        return Nothing
+      That v -> do
+        liftIO $ putStrLn "Creating item"
+        Just df <- liftIO $ documentCreateDocumentFragment doc
+        s <- buildChild df k v
+        let placeholder = case Map.lookupGT k curState of
+              Nothing -> endPlaceholder
+              Just (_, ((_, (start, _)), _)) -> start
+        Just p <- liftIO $ nodeGetParentNode placeholder
+        liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
+        return $ Just s
+      These state _ -> do
+        liftIO $ putStrLn "Leaving item unchanged"
+        return $ Just state
+    liftIO $ putStrLn "Triggering newChildren"
+    liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
+    runFrameWithTriggerRef newChildrenTriggerRef newState
+    liftIO $ putStrLn "Triggering newChildren done"
+  holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
+
+selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) => Dynamic t k -> Dynamic t (Map k v) -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -> m (Event t k)
+selectViewListWithKey_ selection vals mkChild = do
+  let selectionDemux = demux selection -- For good performance, this value must be shared across all children
+  selectChild <- listWithKey vals $ \k v -> do
+    selected <- getDemuxed selectionDemux k
+    selectSelf <- mkChild k v selected
+    return $ fmap (const k) selectSelf
+  liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
+
+--------------------------------------------------------------------------------
+-- Basic DOM manipulation helpers
+--------------------------------------------------------------------------------
+
+-- | s and e must both be children of the same node and s must precede e
+deleteBetweenExclusive s e = do
+  Just currentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
+  let go = do
+        Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
+        when (unNode (toNode s) /= unNode (toNode x)) $ do
+          nodeRemoveChild currentParent $ Just x
+          go
+  go
+
+-- | s and e must both be children of the same node and s must precede e
+deleteBetweenInclusive s e = do
+  Just currentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
+  let go = do
+        Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
+        nodeRemoveChild currentParent $ Just x
+        when (unNode (toNode s) /= unNode (toNode x)) go
+  go
+  nodeRemoveChild currentParent $ Just e
+
+--------------------------------------------------------------------------------
+-- Adapters
+--------------------------------------------------------------------------------
+
+--TODO: Get rid of extra version of this function
+wrapDomEvent element elementOnevent getValue = do
+  postGui <- askPostGui
+  runWithActions <- askRunWithActions
+  e <- newEventWithTrigger $ \et -> do
+        unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
+          v <- {-# SCC "d" #-} getValue
+          liftIO $ postGui $ runWithActions [et :=> v]
+        return $ liftIO $ do
+          {-# SCC "e" #-} unsubscribe
+  return $! {-# SCC "f" #-} e
+
+wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
+wrapElement e = do
+  clicked <- wrapDomEvent e elementOnclick (return ())
+  keypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
+  return $ El e clicked keypress  
+
+elDynAttr' elementTag attrs child = do
+  (e, result) <- buildElement elementTag attrs child
+  e' <- wrapElement e
+  return (e', result)
+
+{-# INLINABLE elAttr #-}
+elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
+elAttr elementTag attrs child = do
+  (_, result) <- buildElement elementTag attrs child
+  return result
+
+{-# INLINABLE el' #-}
+--el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
+el' tag child = elAttr' tag (Map.empty :: AttributeMap) child
+
+{-# INLINABLE elAttr' #-}
+--elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
+elAttr' elementTag attrs child = do
+  (e, result) <- buildElement elementTag attrs child
+  e' <- wrapElement e
+  return (e', result)
+
+{-# INLINABLE elDynAttr #-}
+elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
+elDynAttr elementTag attrs child = do
+  (_, result) <- buildElement elementTag attrs child
+  return result
+
+{-# INLINABLE el #-}
+el :: forall t m a. MonadWidget t m => String -> m a -> m a
+el tag child = elAttr tag Map.empty child
+
+--------------------------------------------------------------------------------
+-- Copied and pasted from Reflex.Widget.Class
+--------------------------------------------------------------------------------
+
+list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
+
+{-
+
+--TODO: Update dynamically
+{-# INLINABLE dynHtml #-}
+dynHtml :: MonadWidget t m => Dynamic t String -> m ()
+dynHtml ds = do
+  let mkSelf h = do
+        doc <- askDocument
+        Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
+        liftIO $ htmlElementSetInnerHTML e h
+        return e
+  eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
+  putEChildren $ fmap ((:[]) . toNode) eCreated
+
+-}
+
+data Link t
+  = Link { _link_clicked :: Event t ()
+         }
+
+linkClass :: MonadWidget t m => String -> String -> m (Link t)
+linkClass s c = do
+  (l,_) <- elAttr' "a" ("class" =: c) $ text s
+  return $ Link $ _el_clicked l
+
+link :: MonadWidget t m => String -> m (Link t)
+link s = linkClass s ""
+
+newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
+
+workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
+workflowView w0 = do
+  rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
+      eReplace <- liftM switch $ hold never $ fmap snd eResult
+      eResult `seq` eReplace `seq` return ()
+  return $ fmap fst eResult
+
+divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
+divClass = elAttr "div" . Map.singleton "class"
+
+dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
+dtdd h w = do
+  el "dt" $ text h
+  el "dd" $ w
+
+blank :: forall t m. MonadWidget t m => m ()
+blank = return ()
+
+tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) => String -> [(String, k -> Dynamic t r -> m v)] -> Dynamic t (Map k r) -> (k -> m (Dynamic t (Map String String))) -> m (Dynamic t (Map k (El t, [v])))
+tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
+    elAttr "table" (Map.singleton "class" klass) $ do
+      el "thead" $ el "tr" $ do
+        mapM (\(h, _) -> el "th" $ text h) cols
+      el "tbody" $ do
+        listWithKey dRows (\k r -> do
+          dAttrs <- rowAttrs k
+          elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
+
+--TODO preselect a tab on open
+tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
+tabDisplay ulClass activeClass tabItems = do
+  rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
+      dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
+        tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
+        let eTabClicks :: Event t k = leftmost tabClicksList
+        holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
+  divClass "" $ do
+    let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
+    listWithKey dTabs (\k dTab -> do
+      dAttrs <- mapDyn (\sel -> do
+        let t1 = listToMaybe $ Map.keys tabItems
+        if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab 
+      elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
+    return ()
+  where
+    headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
+    headerBarLink x k dBool = do
+      dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
+      elDynAttr "li" dAttributes $ do
+        a <- link x
+        return $ fmap (const k) (_link_clicked a)
+
+

src/Reflex/Dom/Widget/Input.hs

@@ -0,0 +1,254 @@
+{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, DataKinds, GADTs, ScopedTypeVariables, FlexibleInstances, RecursiveDo #-}
+module Reflex.Dom.Widget.Input where
+
+import Prelude hiding (forM_)
+
+import Reflex.Dom.Class
+import Reflex.Dom.Widget.Basic
+
+import Reflex
+import Reflex.Host.Class
+import Data.Map (Map)
+import GHCJS.DOM.Document
+import GHCJS.DOM.HTMLInputElement
+import GHCJS.DOM.Node
+import GHCJS.DOM.Element
+import GHCJS.DOM.HTMLSelectElement
+import GHCJS.DOM.EventM
+import GHCJS.DOM.UIEvent
+import Data.Monoid
+import Data.Map as Map
+import Control.Monad hiding (forM_)
+import Control.Monad.IO.Class
+import Control.Lens
+import Data.Default
+import Data.Maybe
+import Safe
+import Data.Dependent.Sum (DSum (..))
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Foldable
+
+input' :: MonadWidget t m => String -> String -> Event t String -> Dynamic t (Map String String) -> m (TextInput t)
+input' inputType initial eSetValue dAttrs = do
+  e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs
+  liftIO $ htmlInputElementSetValue e initial
+  performEvent_ $ fmap (liftIO . htmlInputElementSetValue e) eSetValue
+  eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
+  postGui <- askPostGui
+  runWithActions <- askRunWithActions
+  eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
+    unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
+      postGui $ runWithActions [eChangeFocusTrigger :=> False]
+    unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
+      postGui $ runWithActions [eChangeFocusTrigger :=> True]
+    return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
+  dFocus <- holdDyn False eChangeFocus
+  eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
+  eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
+  eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
+  dValue <- holdDyn initial $ leftmost [eSetValue, eChange]
+  return $ TextInput dValue eKeypress eKeydown eKeyup dFocus e
+
+{-  
+  dSetValue <- holdDyn "" eSetValue
+  dynText =<< combineDyn (\v a -> "Input placeholder: " <> show (inputType, v, a)) dSetValue dAttrs
+  return $ TextInput (constDyn "") never never never (constDyn False) (constDyn Nothing)
+
+input' inputType eSetValue dAttrs = do
+  dEffectiveAttrs <- mapDyn (Map.insert "type" inputType) dAttrs
+  let mkSelf (initialValue, initialAttrs) = do
+        doc <- askDocument
+        Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input"
+        liftIO $ htmlInputElementSetValue e initialValue
+        iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value
+        eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
+        runFrame <- askRunFrame
+        eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
+          unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
+            runFrame $ DMap.singleton eChangeFocusTrigger False
+          unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
+            runFrame $ DMap.singleton eChangeFocusTrigger True
+          return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
+        eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
+        eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event
+        eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event
+        return (e, eChange, eKeypress, eKeydown, eKeyup, eChangeFocus)
+  dInitialValue <- holdDyn "" eSetValue
+  dInitial <- combineDyn (,) dInitialValue dEffectiveAttrs
+  eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit
+  dMyElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated
+  performEvent_ . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dEffectiveAttrs
+  putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated
+  performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlInputElementSetValue e v) $ attachWith (\e v -> case e of
+    Nothing -> Nothing
+    Just e' -> Just (e',v)) (current dMyElement) eSetValue
+  eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated
+  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
+  dValue <- holdDyn "" $ leftmost [eSetValue, eChange]
+  eKeypress <- liftM switch $ hold never $ fmap (^. _3) eCreated
+  eKeydown <- liftM switch $ hold never $ fmap (^. _4) eCreated
+  eKeyup <- liftM switch $ hold never $ fmap (^. _5) eCreated
+  return $ TextInput dValue eKeypress eKeydown eKeyup dFocus dMyElement
+-}
+
+data TextInput t
+  = TextInput { _textInput_value :: Dynamic t String
+              , _textInput_keypress :: Event t Int
+              , _textInput_keydown :: Event t Int
+              , _textInput_keyup :: Event t Int
+              , _textInput_hasFocus :: Dynamic t Bool
+              , _textInput_element :: HTMLInputElement
+              }
+
+textInput :: MonadWidget t m => m (TextInput t)
+textInput = input' "text" "" never (constDyn $ Map.empty)
+
+textInputGetEnter :: Reflex t => TextInput t -> Event t ()
+textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i
+
+{-
+type family Controller sm t a where
+  Controller Edit t a = (a, Event t a) -- Initial value and setter
+  Controller View t a = Dynamic t a -- Value (always)
+
+type family Output sm t a where
+  Output Edit t a = Dynamic t a -- Value (always)
+  Output View t a = Event t a -- Requested changes
+
+data CheckboxConfig sm t
+   = CheckboxConfig { _checkbox_input :: Controller sm t Bool
+                    , _checkbox_attributes :: Attributes
+                    }
+
+instance Reflex t => Default (CheckboxConfig Edit t) where
+  def = CheckboxConfig (False, never) mempty
+
+data Checkbox sm t
+  = Checkbox { _checkbox_output :: Output sm t Bool
+             }
+
+data StateMode = Edit | View
+
+--TODO: There must be a more generic way to get this witness and allow us to case on the type-level StateMode
+data StateModeWitness (sm :: StateMode) where
+  EditWitness :: StateModeWitness Edit
+  ViewWitness :: StateModeWitness View
+
+class HasStateModeWitness (sm :: StateMode) where
+  stateModeWitness :: StateModeWitness sm
+
+instance HasStateModeWitness Edit where
+  stateModeWitness = EditWitness
+
+instance HasStateModeWitness View where
+  stateModeWitness = ViewWitness
+-}
+
+data Checkbox t
+  = Checkbox { _checkbox_value :: Dynamic t Bool
+             }
+
+--TODO: Make attributes possibly dynamic
+-- | Create an editable checkbox
+--   Note: if the "type" or "checked" attributes are provided as attributes, they will be ignored
+checkbox :: MonadWidget t m => Bool -> Map String String -> m (Checkbox t)
+checkbox checked attrs = do
+  e <- liftM castToHTMLInputElement $ buildEmptyElement "input" $ Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") attrs
+  eChange <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e
+  dValue <- holdDyn checked eChange
+  return $ Checkbox dValue
+
+checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool)
+checkboxView dAttrs dValue = do
+  e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs
+  eClicked <- wrapDomEvent e elementOnclick $ do
+    preventDefault
+    liftIO $ htmlInputElementGetChecked e
+  schedulePostBuild $ do
+    v <- sample $ current dValue
+    when v $ liftIO $ htmlInputElementSetChecked e True
+  performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e v) $ updated dValue
+  return eClicked
+
+checkboxWithLabel :: forall t m. MonadWidget t m => String -> m (Checkbox t)
+checkboxWithLabel l = checkboxWithLabelAttrs l Map.empty
+
+checkboxWithLabelAttrs :: forall t m. MonadWidget t m => String -> Map String String -> m (Checkbox t)
+checkboxWithLabelAttrs l attrs = elAttr "label" attrs $ do
+  c <- checkbox False Map.empty
+  text $ " " <> l
+  return c
+
+
+data Dropdown t k
+   = Dropdown { _dropdown_value :: Dynamic t k
+              }
+
+--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map
+--TODO: Don't bake in any CSS classes
+--TODO: Get rid of Show k and Read k by indexing the possible values ourselves
+-- | Create a dropdown box
+--   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
+dropdown :: forall k t m. (MonadWidget t m, Ord k, Show k, Read k) => k -> Dynamic t (Map k String) -> m (Dropdown t k)
+dropdown k0 options = do
+  (eRaw, _) <- elAttr' "select" ("class" =: "form-control") $ do
+    optionsWithDefault <- mapDyn (`Map.union` (k0 =: "")) options
+    listWithKey optionsWithDefault $ \k v -> do
+      elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ dynText v
+  let e = castToHTMLSelectElement $ _el_element eRaw
+  eChange <- wrapDomEvent e elementOnchange $ do
+    kStr <- liftIO $ htmlSelectElementGetValue e
+    return $ readMay kStr
+  let readKey opts mk = fromMaybe k0 $ do
+        k <- mk
+        guard $ Map.member k opts
+        return k
+  dValue <- combineDyn readKey options =<< holdDyn (Just k0) eChange
+  return $ Dropdown dValue
+
+--TODO: Get rid of Show k and Read k by indexing the possible values ourselves
+dropdown' :: forall k t m. (MonadWidget t m, Eq k, Show k, Read k) => k -> NonEmpty (k, String) -> m (Dropdown t k)
+dropdown' k0 ks = do
+  (eRaw, _) <- elAttr' "select" ("class" =: "form-control") $ do
+    forM_ ks $ \(k, name) -> do
+      elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ text name
+  let e = castToHTMLSelectElement $ _el_element eRaw
+  eChange <- wrapDomEvent e elementOnchange $ do
+    kStr <- liftIO $ htmlSelectElementGetValue e
+    return $ readMay kStr
+  let readKey mk = fromMaybe k0 mk
+  dValue <- mapDyn readKey =<< holdDyn (Just k0) eChange
+  return $ Dropdown dValue
+
+--TODO Remove CSS Classes
+searchInputResult :: forall t m a. MonadWidget t m => Dynamic t (String, a) -> m (Event t (String, a))
+searchInputResult r = el "li" $ do
+  (li, _) <- elAttr' "a" (Map.singleton "style" "cursor: pointer;") $ dynText =<< mapDyn fst r
+  return $ tag (current r) (_el_clicked li)
+
+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))
+searchInput initial results = searchInput' initial results searchInputResultsList
+
+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))
+searchInput' initial results listBuilder = do
+  rec input <- input' "text" "" eSetValue $ constDyn $ Map.fromList [("class", "form-control"), ("placeholder", "Search")]
+      dResults <- holdDyn initial $ leftmost [eClearResults, results]
+      eMadeChoice <- listBuilder dResults
+      let eSetValue = fmap fst eMadeChoice
+          eSelectionMade = fmap (const Nothing) eSetValue
+          eInputChanged = fmapMaybe id $ leftmost [eSelectionMade, fmap Just (updated $ _textInput_value input)]
+          eInputEmpty = fmapMaybe id $ fmap (\i -> if i == "" then Just Map.empty else Nothing) eInputChanged
+          eClearResults = leftmost [eInputEmpty, fmap (const Map.empty) eMadeChoice]
+  return (eInputChanged, eMadeChoice)
+
+searchInputResultsList :: forall t m a k. (MonadWidget t m, Ord k) => Dynamic t (Map k (String, a)) -> m (Event t (String, a))
+searchInputResultsList results = searchInputResultsList' results (flip list searchInputResult)
+
+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))
+searchInputResultsList' results builder = do
+  let hideDropdown = Map.fromList [("class", "dropdown-menu"), ("style", "display: none;")]
+      showDropdown = Map.fromList [("class", "dropdown-menu"), ("style", "display: block;")]
+  attrs <- mapDyn (\rs -> if Map.null rs then hideDropdown else showDropdown) results
+  resultsList <- elDynAttr "ul" attrs $ builder results
+  liftM switch $ hold never $ fmap (leftmost . Map.elems) (updated resultsList)
+