packages feed

reflex-dom (empty) → 0.1

raw patch · 14 files changed

+2313/−0 lines, 14 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, data-default, dependent-map, dependent-sum, ghcjs-base, ghcjs-dom, glib, gtk3, lens, mtl, ref-tf, reflex, safe, semigroups, text, these, time, transformers, webkitgtk3, webkitgtk3-javascriptcore

Files

+ LICENSE view
@@ -0,0 +1,12 @@+Copyright (c) 2015, Obsidian Systems LLC+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ reflex-dom.cabal view
@@ -0,0 +1,65 @@+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: BSD3+License-file: LICENSE+Author: Ryan Trinkle+Maintainer: ryan.trinkle@gmail.com+Stability: Experimental+Category: FRP+Build-type: Simple+Cabal-version: >=1.9.2++library+  hs-source-dirs: src+  build-depends:+    base >= 4.7 && < 4.9,+    reflex == 0.2.*,+    dependent-sum == 0.2.*,+    dependent-map == 0.1.*,+    semigroups == 0.16.*,+    mtl >= 2.1 && < 2.3,+    containers == 0.5.*,+    these == 0.4.*,+    ref-tf == 0.4.*,+    transformers == 0.4.*,+    lens >= 4.7 && < 4.10,+    ghcjs-dom >= 0.1.1.3 && < 0.2,+    safe == 0.3.*,+    text == 1.2.*,+    bytestring == 0.10.*,+    data-default == 0.5.*,+    aeson == 0.8.*,+    time == 1.5.*++  if impl(ghcjs)+    hs-source-dirs: src-ghcjs+    cpp-options: -D__GHCJS__+    build-depends:+      ghcjs-base+  else+    hs-source-dirs: src-ghc+    build-depends:+      glib == 0.13.*,+      gtk3 == 0.13.*,+      webkitgtk3 == 0.13.*,+      webkitgtk3-javascriptcore == 0.13.*++  exposed-modules:+    Reflex.Dom+    Reflex.Dom.Class+    Reflex.Dom.Internal+    Reflex.Dom.Widget+    Reflex.Dom.Widget.Basic+    Reflex.Dom.Widget.Input+    Reflex.Dom.Widget.Lazy+    Reflex.Dom.Xhr+    Reflex.Dom.Time+  other-modules:+    Reflex.Dom.Internal.Foreign+    Reflex.Dom.Xhr.Foreign++  other-extensions: TemplateHaskell+  ghc-prof-options: -fprof-auto+  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+ src-ghcjs/Reflex/Dom/Internal/Foreign.hs view
@@ -0,0 +1,9 @@+module Reflex.Dom.Internal.Foreign (runWebGUI) where++import GHCJS.DOM+import GHCJS.DOM.Types+import GHCJS.Types+import Data.Function++instance Eq Node where+  (==) = eqRef `on` unNode
+ src-ghcjs/Reflex/Dom/Xhr/Foreign.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++module Reflex.Dom.Xhr.Foreign where++import GHCJS.Types+import GHCJS.Foreign+import GHCJS.Marshal+import qualified Data.Text as T+import Data.Text (Text)+import Data.Word+import GHCJS.DOM.Types hiding (Text)+import Control.Applicative ((<$>))+import GHCJS.DOM.EventM+import GHCJS.DOM+import Data.Function++prepareWebView :: WebView -> IO ()+prepareWebView _ = return ()++foreign import javascript unsafe "h$isInstanceOf $1 $2"+    typeInstanceIsA' :: JSRef a -> JSRef GType -> Bool++typeInstanceIsA :: JSRef a -> GType -> Bool+typeInstanceIsA o (GType t) = typeInstanceIsA' o t++castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String+                                                -> (obj -> obj')+castTo gtype objTypeName obj =+  case toGObject obj of+    gobj@(GObject objRef)+      | typeInstanceIsA objRef gtype+                  -> unsafeCastGObject gobj+      | otherwise -> error $ "Cannot cast object to " ++ objTypeName+++newtype XMLHttpRequest = XMLHttpRequest { unXMLHttpRequest :: JSRef XMLHttpRequest }++instance Eq XMLHttpRequest where+  (==) = eqRef `on` unXMLHttpRequest++instance ToJSRef XMLHttpRequest where+  toJSRef = return . unXMLHttpRequest+  {-# INLINE toJSRef #-}++instance FromJSRef XMLHttpRequest where+  fromJSRef = return . fmap XMLHttpRequest . maybeJSNull+  {-# INLINE fromJSRef #-}++class GObjectClass o => IsXMLHttpRequest o+toXMLHttpRequest :: IsXMLHttpRequest o => o -> XMLHttpRequest+toXMLHttpRequest = unsafeCastGObject . toGObject++instance IsXMLHttpRequest XMLHttpRequest+instance GObjectClass XMLHttpRequest where+  toGObject = GObject . castRef . unXMLHttpRequest+  unsafeCastGObject = XMLHttpRequest . castRef . unGObject++castToXMLHttpRequest :: GObjectClass obj => obj -> XMLHttpRequest+castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"++foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpRequest' :: JSRef GType+gTypeXMLHttpRequest :: GType+gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'+++newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }++instance Eq XMLHttpRequestUpload where+  (==) = eqRef `on` unXMLHttpRequestUpload++instance ToJSRef XMLHttpRequestUpload where+  toJSRef = return . unXMLHttpRequestUpload+  {-# INLINE toJSRef #-}++instance FromJSRef XMLHttpRequestUpload where+  fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull+  {-# INLINE fromJSRef #-}++class GObjectClass o => IsXMLHttpRequestUpload o+toXMLHttpRequestUpload :: IsXMLHttpRequestUpload o => o -> XMLHttpRequestUpload+toXMLHttpRequestUpload = unsafeCastGObject . toGObject++instance IsXMLHttpRequestUpload XMLHttpRequestUpload+instance GObjectClass XMLHttpRequestUpload where+  toGObject = GObject . castRef . unXMLHttpRequestUpload+  unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject++castToXMLHttpRequestUpload :: GObjectClass obj => obj -> XMLHttpRequestUpload+castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"++foreign import javascript unsafe "window[\"XMLHttpRequestUpload\"]" gTypeXMLHttpRequestUpload' :: JSRef GType+gTypeXMLHttpRequestUpload :: GType+gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'++foreign import javascript unsafe "new XMLHttpRequest()"+        ghcjs_dom_xml_http_request_new ::+        IO (JSRef XMLHttpRequest)++xmlHttpRequestNew :: a -> IO XMLHttpRequest+xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new++foreign import javascript unsafe "$1[\"open\"]($2, $3, $4, $5, $6)"+        ghcjs_dom_xml_http_request_open ::+        JSRef XMLHttpRequest -> JSString -> JSString -> JSBool -> JSString -> JSString -> IO ()++xmlHttpRequestOpen ::+                   (IsXMLHttpRequest self, ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>+                     self -> method -> url -> Bool -> user -> password -> IO ()+xmlHttpRequestOpen self method url async user password+  = ghcjs_dom_xml_http_request_open+      (unXMLHttpRequest (toXMLHttpRequest self))+      (toJSString method)+      (toJSString url)+      (toJSBool async)+      (toJSString user)+      (toJSString password)++foreign import javascript unsafe "($2===null)?$1[\"send\"]():$1[\"send\"]($2)"+        ghcjs_dom_xml_http_request_send ::+        JSRef XMLHttpRequest -> JSString -> IO ()++xmlHttpRequestSend ::+                   (IsXMLHttpRequest self, ToJSString payload) =>+                     self -> Maybe payload -> IO ()+xmlHttpRequestSend self payload+  = ghcjs_dom_xml_http_request_send+      (unXMLHttpRequest (toXMLHttpRequest self))+      (case payload of+            Just p -> toJSString p+            Nothing -> jsNull)+++foreign import javascript unsafe "$1[\"setRequestHeader\"]($2, $3)"+        ghcjs_dom_xml_http_request_set_request_header ::+        JSRef XMLHttpRequest -> JSString -> JSString -> IO ()++xmlHttpRequestSetRequestHeader ::+                               (IsXMLHttpRequest self, ToJSString header, ToJSString value) =>+                                 self -> header -> value -> IO ()+xmlHttpRequestSetRequestHeader self header value+  = ghcjs_dom_xml_http_request_set_request_header+      (unXMLHttpRequest (toXMLHttpRequest self))+      (toJSString header)+      (toJSString value)++foreign import javascript unsafe "$1[\"abort\"]()"+        ghcjs_dom_xml_http_request_abort :: JSRef XMLHttpRequest -> IO ()++xmlHttpRequestAbort :: (IsXMLHttpRequest self) => self -> IO ()+xmlHttpRequestAbort self+  = ghcjs_dom_xml_http_request_abort+      (unXMLHttpRequest (toXMLHttpRequest self))++foreign import javascript unsafe "$1[\"getAllResponseHeaders\"]()"+        ghcjs_dom_xml_http_request_get_all_response_headers ::+        JSRef XMLHttpRequest -> IO JSString++xmlHttpRequestGetAllResponseHeaders ::+                                    (IsXMLHttpRequest self, FromJSString result) =>+                                      self -> IO result+xmlHttpRequestGetAllResponseHeaders self+  = fromJSString <$>+      (ghcjs_dom_xml_http_request_get_all_response_headers+         (unXMLHttpRequest (toXMLHttpRequest self)))++foreign import javascript unsafe "$1[\"getResponseHeader\"]($2)"+        ghcjs_dom_xml_http_request_get_response_header ::+        JSRef XMLHttpRequest -> JSString -> IO JSString++xmlHttpRequestGetResponseHeader ::+                                (IsXMLHttpRequest self, ToJSString header, FromJSString result) =>+                                  self -> header -> IO result+xmlHttpRequestGetResponseHeader self header+  = fromJSString <$>+      (ghcjs_dom_xml_http_request_get_response_header+         (unXMLHttpRequest (toXMLHttpRequest self))+         (toJSString header))++foreign import javascript unsafe "$1[\"overrideMimeType\"]($2)"+        ghcjs_dom_xml_http_request_override_mime_type ::+        JSRef XMLHttpRequest -> JSString -> IO ()++xmlHttpRequestOverrideMimeType ::+                               (IsXMLHttpRequest self, ToJSString override) =>+                                 self -> override -> IO ()+xmlHttpRequestOverrideMimeType self override+  = ghcjs_dom_xml_http_request_override_mime_type+      (unXMLHttpRequest (toXMLHttpRequest self))+      (toJSString override)++foreign import javascript unsafe+        "($1[\"dispatchEvent\"]($2) ? 1 : 0)"+        ghcjs_dom_xml_http_request_dispatch_event ::+        JSRef XMLHttpRequest -> JSRef Event -> IO Bool++xmlHttpRequestDispatchEvent ::+                            (IsXMLHttpRequest self, IsEvent evt) =>+                              self -> Maybe evt -> IO Bool+xmlHttpRequestDispatchEvent self evt+  = ghcjs_dom_xml_http_request_dispatch_event+      (unXMLHttpRequest (toXMLHttpRequest self))+      (maybe jsNull (unEvent . toEvent) evt)++cUNSENT :: Integer+cUNSENT = 0++cOPENED :: Integer+cOPENED = 1++cHEADERS_RECEIVED :: Integer+cHEADERS_RECEIVED = 2++cLOADING :: Integer+cLOADING = 3++cDONE :: Integer+cDONE = 4++xmlHttpRequestOnabort ::+                      (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())+xmlHttpRequestOnabort = (connect "abort")++xmlHttpRequestOnerror ::+                      (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())+xmlHttpRequestOnerror = (connect "error")++xmlHttpRequestOnload ::+                     (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())+xmlHttpRequestOnload = (connect "load")++xmlHttpRequestOnloadend ::+                        (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())+xmlHttpRequestOnloadend = (connect "loadend")++xmlHttpRequestOnloadstart ::+                          (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())+xmlHttpRequestOnloadstart = (connect "loadstart")++xmlHttpRequestOnprogress ::+                         (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())+xmlHttpRequestOnprogress = (connect "progress")++xmlHttpRequestOntimeout ::+                        (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())+xmlHttpRequestOntimeout = (connect "timeout")++xmlHttpRequestOnreadystatechange ::+                                 (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())+xmlHttpRequestOnreadystatechange = (connect "readystatechange")++foreign import javascript unsafe "$1[\"timeout\"] = $2;"+        ghcjs_dom_xml_http_request_set_timeout ::+        JSRef XMLHttpRequest -> Word -> IO ()++xmlHttpRequestSetTimeout ::+                         (IsXMLHttpRequest self) => self -> Word -> IO ()+xmlHttpRequestSetTimeout self val+  = ghcjs_dom_xml_http_request_set_timeout+      (unXMLHttpRequest (toXMLHttpRequest self))+      val++foreign import javascript unsafe "$1[\"timeout\"]"+        ghcjs_dom_xml_http_request_get_timeout ::+        JSRef XMLHttpRequest -> IO Word++xmlHttpRequestGetTimeout ::+                         (IsXMLHttpRequest self) => self -> IO Word+xmlHttpRequestGetTimeout self+  = ghcjs_dom_xml_http_request_get_timeout+      (unXMLHttpRequest (toXMLHttpRequest self))++foreign import javascript unsafe "$1[\"readyState\"]"+        ghcjs_dom_xml_http_request_get_ready_state ::+        JSRef XMLHttpRequest -> IO Word++xmlHttpRequestGetReadyState ::+                            (IsXMLHttpRequest self) => self -> IO Word+xmlHttpRequestGetReadyState self+  = ghcjs_dom_xml_http_request_get_ready_state+      (unXMLHttpRequest (toXMLHttpRequest self))++foreign import javascript unsafe "$1[\"withCredentials\"] = $2;"+        ghcjs_dom_xml_http_request_set_with_credentials ::+        JSRef XMLHttpRequest -> Bool -> IO ()++xmlHttpRequestSetWithCredentials ::+                                 (IsXMLHttpRequest self) => self -> Bool -> IO ()+xmlHttpRequestSetWithCredentials self val+  = ghcjs_dom_xml_http_request_set_with_credentials+      (unXMLHttpRequest (toXMLHttpRequest self))+      val++foreign import javascript unsafe+        "($1[\"withCredentials\"] ? 1 : 0)"+        ghcjs_dom_xml_http_request_get_with_credentials ::+        JSRef XMLHttpRequest -> IO Bool++xmlHttpRequestGetWithCredentials ::+                                 (IsXMLHttpRequest self) => self -> IO Bool+xmlHttpRequestGetWithCredentials self+  = ghcjs_dom_xml_http_request_get_with_credentials+      (unXMLHttpRequest (toXMLHttpRequest self))++foreign import javascript unsafe "$1[\"upload\"]"+        ghcjs_dom_xml_http_request_get_upload ::+        JSRef XMLHttpRequest -> IO (JSRef XMLHttpRequestUpload)++xmlHttpRequestGetUpload ::+                        (IsXMLHttpRequest self) => self -> IO (Maybe XMLHttpRequestUpload)+xmlHttpRequestGetUpload self+  = fmap XMLHttpRequestUpload . maybeJSNull <$>+      (ghcjs_dom_xml_http_request_get_upload+         (unXMLHttpRequest (toXMLHttpRequest self)))++foreign import javascript unsafe "$1[\"responseText\"]"+        ghcjs_dom_xml_http_request_get_response_text ::+        JSRef XMLHttpRequest -> IO JSString++xmlHttpRequestGetResponseText ::+                             (IsXMLHttpRequest self, FromJSString result) => self -> IO (Maybe result)+xmlHttpRequestGetResponseText self+  = fmap fromJSString . maybeJSNull <$>+      (ghcjs_dom_xml_http_request_get_response_text+         (unXMLHttpRequest (toXMLHttpRequest self)))++responseTextToText :: (Maybe JSString) -> Maybe Text+responseTextToText r = fmap (T.pack . fromJSString) r++foreign import javascript unsafe "$1[\"responseXML\"]"+        ghcjs_dom_xml_http_request_get_response_xml ::+        JSRef XMLHttpRequest -> IO (JSRef Document)++xmlHttpRequestGetResponseXML ::+                             (IsXMLHttpRequest self) => self -> IO (Maybe Document)+xmlHttpRequestGetResponseXML self+  = fmap Document . maybeJSNull <$>+      (ghcjs_dom_xml_http_request_get_response_xml+         (unXMLHttpRequest (toXMLHttpRequest self)))++foreign import javascript unsafe "$1[\"responseType\"] = $2;"+        ghcjs_dom_xml_http_request_set_response_type ::+        JSRef XMLHttpRequest -> JSString -> IO ()++xmlHttpRequestSetResponseType ::+                              (IsXMLHttpRequest self, ToJSString val) => self -> val -> IO ()+xmlHttpRequestSetResponseType self val+  = ghcjs_dom_xml_http_request_set_response_type+      (unXMLHttpRequest (toXMLHttpRequest self))+      (toJSString val)++toResponseType :: (ToJSString a) => a -> JSString+toResponseType = toJSString++foreign import javascript unsafe "$1[\"responseType\"]"+        ghcjs_dom_xml_http_request_get_response_type ::+        JSRef XMLHttpRequest -> IO JSString++xmlHttpRequestGetResponseType ::+                              (IsXMLHttpRequest self, FromJSString result) => self -> IO result+xmlHttpRequestGetResponseType self+  = fromJSString <$>+      (ghcjs_dom_xml_http_request_get_response_type+         (unXMLHttpRequest (toXMLHttpRequest self)))++foreign import javascript unsafe "$1[\"status\"]"+        ghcjs_dom_xml_http_request_get_status ::+        JSRef XMLHttpRequest -> IO Word++xmlHttpRequestGetStatus ::+                        (IsXMLHttpRequest self) => self -> IO Word+xmlHttpRequestGetStatus self+  = ghcjs_dom_xml_http_request_get_status+      (unXMLHttpRequest (toXMLHttpRequest self))++foreign import javascript unsafe "$1[\"statusText\"]"+        ghcjs_dom_xml_http_request_get_status_text ::+        JSRef XMLHttpRequest -> IO JSString++xmlHttpRequestGetStatusText ::+                            (IsXMLHttpRequest self, FromJSString result) => self -> IO result+xmlHttpRequestGetStatusText self+  = fromJSString <$>+      (ghcjs_dom_xml_http_request_get_status_text+         (unXMLHttpRequest (toXMLHttpRequest self)))++foreign import javascript unsafe "$1[\"responseURL\"]"+        ghcjs_dom_xml_http_request_get_response_url ::+        JSRef XMLHttpRequest -> IO JSString++xmlHttpRequestGetResponseURL ::+                             (IsXMLHttpRequest self, FromJSString result) => self -> IO result+xmlHttpRequestGetResponseURL self+  = fromJSString <$>+      (ghcjs_dom_xml_http_request_get_response_url+         (unXMLHttpRequest (toXMLHttpRequest self)))+
+ src/Reflex/Dom.hs view
@@ -0,0 +1,14 @@+module Reflex.Dom ( module Reflex+                  , module Reflex.Dom.Class+                  , module Reflex.Dom.Internal+                  , module Reflex.Dom.Widget+                  , module Reflex.Dom.Xhr+                  , module Reflex.Dom.Time+                  ) where++import Reflex+import Reflex.Dom.Class+import Reflex.Dom.Internal+import Reflex.Dom.Widget+import Reflex.Dom.Xhr+import Reflex.Dom.Time
+ src/Reflex/Dom/Class.hs view
@@ -0,0 +1,458 @@+{-# 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 Data.Map (Map)+import qualified Data.Map as Map+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 Data.Dependent.Sum (DSum (..))+import GHCJS.DOM.Types hiding (Event)+import GHCJS.DOM (WebView)++-- | 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, HasWebView m, HasWebView (WidgetHost m), HasWebView (GuiAction m)+      , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)+      , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, HasPostGui t (GuiAction m) (GuiAction 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+  subWidgetWithVoidActions :: Node -> m a -> m (a, Event t (WidgetHost m ()))+  liftWidgetHost :: WidgetHost m a -> m a --TODO: Is this a good idea?+  schedulePostBuild :: WidgetHost m () -> m ()+  addVoidAction :: Event t (WidgetHost m ()) -> m ()+  getRunWidget :: IsNode n => m (n -> m a -> WidgetHost m (a, WidgetHost m (), 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 Monad m => HasWebView m where+  askWebView :: m WebView++instance HasWebView m => HasWebView (ReaderT r m) where+  askWebView = lift askWebView++instance HasWebView m => HasWebView (StateT r m) where+  askWebView = lift askWebView++newtype Restore m = Restore { restore :: forall a. m a -> IO a }++class Monad m => MonadIORestore m where+  askRestore :: m (Restore m)++instance MonadIORestore m => MonadIORestore (ReaderT r m) where+  askRestore = do+    r <- ask+    parentRestore <- lift askRestore+    return $ Restore $ \a -> restore parentRestore $ runReaderT a r++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+  subWidgetWithVoidActions n w = do+    r <- ask+    lift $ subWidgetWithVoidActions n $ runReaderT w r+  liftWidgetHost = lift . liftWidgetHost+  schedulePostBuild = lift . schedulePostBuild+  addVoidAction = lift . addVoidAction+  getRunWidget = do+    r <- ask+    runWidget <- lift getRunWidget+    return $ \rootElement w -> do+      (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r+      return (a, postBuild, voidActions)++performEvent_ :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()+performEvent_ = addVoidAction++performEvent :: (MonadWidget t m, Ref m ~ Ref IO) => Event t (WidgetHost m a) -> m (Event t a)+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++getPostBuild :: MonadWidget t m => m (Event t ())+getPostBuild = do+  (e, trigger) <- newEventWithTriggerRef+  schedulePostBuild $ runFrameWithTriggerRef trigger ()+  return e++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+{-++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 view
@@ -0,0 +1,260 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, ConstraintKinds, CPP #-}+module Reflex.Dom.Internal where++import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)++import Reflex.Dom.Internal.Foreign+import Reflex.Dom.Class++import GHCJS.DOM hiding (runWebGUI)+import GHCJS.DOM.Types hiding (Widget, unWidget, Event)+import GHCJS.DOM.Node+import GHCJS.DOM.HTMLElement+import GHCJS.DOM.Document+import Reflex.Class+import Reflex.Host.Class+import Reflex.Spider (Spider, SpiderHost (..))+import Control.Lens+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_, get)+import Control.Concurrent+import Control.Applicative+import Data.ByteString (ByteString)+import Data.Dependent.Sum (DSum (..))+import Data.Foldable+import Data.Traversable+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Monoid ((<>))++data GuiEnv t h+   = GuiEnv { _guiEnvDocument :: !HTMLDocument+            , _guiEnvPostGui :: !(h () -> IO ())+            , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())+            , _guiEnvWebView :: !WebView+            }++--TODO: Poorly named+newtype Gui t h m a = Gui { unGui :: ReaderT (GuiEnv t h) m a } deriving (Functor, Applicative, 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++instance MonadAtomicRef m => MonadAtomicRef (Gui t h m) where+  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 Monad m => HasWebView (Gui t h m) where+  askWebView = Gui $ view guiEnvWebView++instance MonadIORestore m => MonadIORestore (Gui t h m) where+  askRestore = Gui $ do+    r <- askRestore+    return $ Restore $ restore r . unGui++instance HasWebView m => HasWebView (Widget t m) where+  askWebView = lift askWebView++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++instance MonadAtomicRef m => MonadAtomicRef (Widget t m) where+  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, MonadIO h, Functor m+         , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m+         , MonadFix m, HasWebView h, HasPostGui t h h+         ) => 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 ()+  liftWidgetHost = Widget . lift . lift+  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+  subWidgetWithVoidActions n child = Widget $ do+    oldActions <- use widgetStateVoidActions+    widgetStateVoidActions .= []+    result <- local (widgetEnvParent .~ toNode n) $ unWidget child+    actions <- use widgetStateVoidActions+    widgetStateVoidActions .= oldActions+    return (result, mergeWith (>>) actions)+--  runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))+  getRunWidget = return runWidget++runWidget :: (Monad m, Reflex t, IsNode n) => n -> Widget t (Gui t h m) a -> WidgetHost (Widget t (Gui t h m)) (a, WidgetHost (Widget t (Gui t h m)) (), Event t (WidgetHost (Widget t (Gui t h m)) ()))+runWidget rootElement w = do+  (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])+  let voidAction = mergeWith (>>) voidActions+  return (result, postBuild, 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 (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()+mainWidget w = runWebGUI $ \webView -> do+  Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView+  Just body <- documentGetBody doc+  attachWidget body webView w++mainWidgetWithHead :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()+mainWidgetWithHead h b = runWebGUI $ \webView -> do+  Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView+  Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc+  attachWidget headElement webView h+  Just body <- documentGetBody doc+  attachWidget body webView b++mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()+mainWidgetWithCss css w = runWebGUI $ \webView -> do+  Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView+  Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc+  htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this+  Just body <- documentGetBody doc+  attachWidget body webView w++newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)++instance (Monad m) => HasWebView (WithWebView m) where+  askWebView = WithWebView ask++instance HasPostGui t h m => HasPostGui t (WithWebView h) (WithWebView m) where+  askPostGui = do+    postGui <- lift askPostGui+    webView <- askWebView+    return $ \h -> postGui $ runWithWebView h webView+  askRunWithActions = do+    runWithActions <- lift askRunWithActions+    return $ lift . runWithActions++instance HasPostGui Spider SpiderHost SpiderHost where+  askPostGui = return $ \h -> liftIO $ runSpiderHost h+  askRunWithActions = return fireEvents++instance MonadTrans WithWebView where+  lift = WithWebView . lift++instance MonadRef m => MonadRef (WithWebView m) where+  type Ref (WithWebView m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r++instance MonadAtomicRef m => MonadAtomicRef (WithWebView m) where+  atomicModifyRef r = lift . atomicModifyRef r++deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView m)+instance MonadReflexHost t m => MonadReflexHost t (WithWebView m) where+  fireEventsAndRead dm a = lift $ fireEventsAndRead dm a+  subscribeEvent = lift . subscribeEvent+  runFrame = lift . runFrame+  runHostFrame = lift . runHostFrame++runWithWebView :: WithWebView m a -> WebView -> m a+runWithWebView = runReaderT . unWithWebView++attachWidget :: (IsHTMLElement e) => e -> WebView -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) a -> IO a+attachWidget rootElement wv w = runSpiderHost $ flip runWithWebView wv $ 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+  frames <- liftIO newChan+  rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv :: GuiEnv Spider (WithWebView SpiderHost)+          runWithActions dm = do+            voidActionNeeded <- fireEventsAndRead dm $ do+              sequence =<< readEvent voidActionHandle+            runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv+      Just df <- liftIO $ documentCreateDocumentFragment doc+      (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do+        (r, postBuild, va) <- runWidget df w+        postBuild -- This probably shouldn't be run inside the frame; we need to make sure we don't run a frame inside of a frame+        return (r, va)+      liftIO $ htmlElementSetInnerHTML rootElement ""+      _ <- liftIO $ nodeAppendChild rootElement $ Just df+      voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary+  --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/Time.hs view
@@ -0,0 +1,50 @@+module Reflex.Dom.Time where++import Reflex+import Reflex.Dom.Class++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Data.Fixed+import Data.Time.Clock++data TickInfo+  = TickInfo { _tickInfo_lastUTC :: UTCTime+             -- ^ UTC time immediately after the last tick.+             , _tickInfo_n :: Integer+             -- ^ Number of time periods since t0+             , _tickInfo_alreadyElapsed :: NominalDiffTime+             -- ^ Amount of time already elapsed in the current tick period.+             }+  deriving (Eq)++-- | Special case of tickLossyFrom that uses the post-build event to start the+--   tick thread.+tickLossy :: MonadWidget t m => NominalDiffTime -> UTCTime -> m (Event t TickInfo)+tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild++-- | Send events over time with the given basis time and interval+--   If the system starts running behind, occurrences will be dropped rather than buffered+--   Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time+tickLossyFrom+    :: MonadWidget t m+    => NominalDiffTime+    -> UTCTime+    -> Event t a+    -- ^ Event that starts a tick generation thread.  Usually you want this to+    -- be something like the result of getPostBuild that only fires once.  But+    -- there could be uses for starting multiple timer threads.+    -> m (Event t TickInfo)+tickLossyFrom dt t0 e = performEventAsync $ fmap callAtNextInterval e+  where callAtNextInterval _ cb = void $ liftIO $ forkIO $ forever $ do+          t <- getCurrentTime+          let offset = t `diffUTCTime` t0+              (n, alreadyElapsed) = offset `divMod'` dt+          threadDelay $ ceiling $ (dt - alreadyElapsed) * 1000000+          cb $ TickInfo t n alreadyElapsed++delay :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)+delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do+  threadDelay $ ceiling $ dt * 1000000+  cb a
+ src/Reflex/Dom/Widget.hs view
@@ -0,0 +1,8 @@+module Reflex.Dom.Widget ( module Reflex.Dom.Widget.Basic+                         , module Reflex.Dom.Widget.Input+                         , module Reflex.Dom.Widget.Lazy+                         ) where++import Reflex.Dom.Widget.Basic+import Reflex.Dom.Widget.Input+import Reflex.Dom.Widget.Lazy
+ src/Reflex/Dom/Widget/Basic.hs view
@@ -0,0 +1,558 @@+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo #-}++module Reflex.Dom.Widget.Basic where++import Reflex.Dom.Class+import Reflex.Dom.Internal.Foreign ()++import Prelude hiding (mapM, mapM_, sequence, sequence_)+import Reflex+import Reflex.Host.Class+import Data.Functor.Misc+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 Data.Foldable+import Data.Traversable+import Control.Monad.Trans+import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)+import GHCJS.DOM.Node+import GHCJS.DOM.UIEvent+import GHCJS.DOM.EventM (event, EventM)+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 hiding (element, children)+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+       , _el_scrolled :: 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++display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()+display a = dynText =<< mapDyn show a++--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, postBuild, voidActions) <- runWidget df c+        runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)+        postBuild+        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 -- I'm pretty sure this is wrong; the void actions should get removed when the child is swapped out+  endPlaceholder <- text' ""+  (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef+  performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack+  childVoidAction <- hold never $ fmap snd newChildBuilt+  addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?+  doc <- askDocument+  runWidget <- getRunWidget+  let build c = do+        Just df <- liftIO $ documentCreateDocumentFragment doc+        (result, postBuild, voidActions) <- runWidget df c+        runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)+        postBuild+        mp <- liftIO $ nodeGetParentNode endPlaceholder+        case mp of+          Nothing -> return () --TODO: Is this right?+          Just p -> do+            _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)+            return ()+        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+  endPlaceholder <- text' ""+  (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef+  performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack+  children <- hold Map.empty  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 $ \k v -> do+      (result, postBuild, voidAction) <- buildChild df k v+      return ((result, voidAction), postBuild)+    runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame+    sequence_ $ fmap snd initialState+    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, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case+      This ((_, (start, end)), _) -> do+        liftIO $ deleteBetweenInclusive start end+        return Nothing+      That v -> do+        Just df <- liftIO $ documentCreateDocumentFragment doc+        (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v+        let s = (childResult, childVoidAction)+        modify (>>childPostBuild)+        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+        return $ Just state+    runFrameWithTriggerRef newChildrenTriggerRef newState+    postBuild+  holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren++listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))+listWithKey' initialVals valsChanged mkChild = do+  doc <- askDocument+  endPlaceholder <- text' ""+  (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef+--  performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack+  runWidget <- getRunWidget+  let childValChangedSelector :: EventSelector t (Const2 k v)+      childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged+      buildChild df k v = runWidget df $ wrapChild k v+      wrapChild k v = do+        childStart <- text' ""+        result <- mkChild k v $ select childValChangedSelector $ Const2 k+        childEnd <- text' ""+        return (result, (childStart, childEnd))+  Just dfOrig <- liftIO $ documentCreateDocumentFragment doc+  initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode dfOrig) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read+  children <- holdDyn initialState newChildren+  addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children+  Just pOrig <- liftIO $ nodeGetParentNode endPlaceholder+  _ <- liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)+  addVoidAction $ flip fmap valsChanged $ \newVals -> do+    curState <- sample $ current children+    --TODO: Should we remove the parent from the DOM first to avoid reflows?+    (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case+      These ((_, (start, end)), _) Nothing -> do -- Deleting child+        liftIO $ deleteBetweenInclusive start end+        return Nothing+      These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child+        liftIO $ deleteBetweenExclusive start end+        Just df <- liftIO $ documentCreateDocumentFragment doc+        (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v+        let s = (childResult, childVoidAction)+        modify (>>childPostBuild)+        Just p <- liftIO $ nodeGetParentNode end+        _ <- liftIO $ nodeInsertBefore p (Just df) (Just end)+        return $ Just s+      That Nothing -> return Nothing -- Deleting non-existent child+      That (Just v) -> do -- Creating new child+        Just df <- liftIO $ documentCreateDocumentFragment doc+        (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v+        let s = (childResult, childVoidAction)+        modify (>>childPostBuild)+        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+      This state -> do -- No change+        return $ Just state+    runFrameWithTriggerRef newChildrenTriggerRef newState+    postBuild+  mapDyn (fmap (fst . fst)) children++--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value+listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))+listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild++listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))+listViewWithKey' vals mkChild = do+  doc <- askDocument+  endPlaceholder <- text' ""+  (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef+  performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack+  children <- hold Map.empty 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 $ \k v -> do+      (result, postBuild, voidAction) <- buildChild df k v+      return ((result, voidAction), postBuild)+    runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame+    sequence_ $ fmap snd initialState+    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, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case+      This ((_, (start, end)), _) -> do+        liftIO $ deleteBetweenInclusive start end+        return Nothing+      That v -> do+        Just df <- liftIO $ documentCreateDocumentFragment doc+        (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v+        let s = (childResult, childVoidAction)+        modify (>>childPostBuild)+        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+        return $ Just state+    runFrameWithTriggerRef newChildrenTriggerRef newState+    postBuild+  return $ fmap (fmap (fst . fst)) children++--TODO: Deduplicate the various list*WithKey* implementations++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 :: (IsNode start, IsNode end) => start -> end -> IO ()+deleteBetweenExclusive s e = do+  mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment+  case mCurrentParent of+    Nothing -> return () --TODO: Is this the right behavior?+    Just currentParent -> do+      let go = do+            Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first+            when (toNode s /= 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 :: (IsNode start, IsNode end) => start -> end -> IO ()+deleteBetweenInclusive s e = do+  mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment+  case mCurrentParent of+    Nothing -> return () --TODO: Is this the right behavior?+    Just currentParent -> do+      let go = do+            Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first+            _ <- nodeRemoveChild currentParent $ Just x+            when (toNode s /= toNode x) go+      go+      _ <- nodeRemoveChild currentParent $ Just e+      return ()++--------------------------------------------------------------------------------+-- Adapters+--------------------------------------------------------------------------------++wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e a -> m (Event t a)+wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue++wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e (Maybe a) -> m (Event t a)+wrapDomEventMaybe element elementOnevent getValue = do+  postGui <- askPostGui+  runWithActions <- askRunWithActions+  e <- newEventWithTrigger $ \et -> do+        unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do+          mv <- {-# SCC "d" #-} getValue+          forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]+        return $ liftIO $ do+          {-# SCC "e" #-} unsubscribe+  return $! {-# SCC "f" #-} e++getKeyEvent :: EventM UIEvent e Int+getKeyEvent = do+  e <- event+  liftIO $ do+    which <- uiEventGetWhich e+    if which /= 0 then return which else do+      charCode <- uiEventGetCharCode e+      if charCode /= 0 then return charCode else+        uiEventGetKeyCode 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 getKeyEvent+  scrolled <- wrapDomEvent e elementOnscroll $ liftIO $ elementGetScrollTop e+  return $ El e clicked keypress scrolled++elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)+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' elementTag child = elAttr' elementTag (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 elementTag child = elAttr elementTag Map.empty child++elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a+elClass elementTag c child = elAttr elementTag ("class" =: c) child++--------------------------------------------------------------------------------+-- Copied and pasted from Reflex.Widget.Class+--------------------------------------------------------------------------------++list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))+list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)++simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])+simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs++elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)+elDynHtml' elementTag html = do+  e <- buildEmptyElement elementTag (Map.empty :: Map String String)+  schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)+  addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html+  wrapElement e++elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)+elDynHtmlAttr' elementTag attrs html = do+  e <- buildEmptyElement elementTag attrs+  schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)+  addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html+  wrapElement e++{-++--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 ""++button :: MonadWidget t m => String -> m (Event t ())+button s = do+  (e, _) <- el' "button" $ text s+  return $ _el_clicked e++newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }++workflow :: forall t m a. MonadWidget t m => Workflow t m a -> m (Dynamic t a)+workflow w0 = do+  rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult+  mapDyn fst eResult++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+  return $ fmap fst eResult++divClass :: forall t m a. MonadWidget t m => String -> m a -> m a+divClass = elClass "div"++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)++-- | Place an element into the DOM and wrap it with Reflex event handlers.  Note: undefined behavior may result if the element is placed multiple times, removed from the DOM after being placed, or in other situations.  Don't use this unless you understand the internals of MonadWidget.+unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)+unsafePlaceElement e = do+  p <- askParent+  _ <- liftIO $ nodeAppendChild p $ Just e+  wrapElement e
+ src/Reflex/Dom/Widget/Input.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, DataKinds, GADTs, ScopedTypeVariables, FlexibleInstances, RecursiveDo, TemplateHaskell #-}+module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where++import Prelude++import Reflex.Dom.Class+import Reflex.Dom.Widget.Basic++import Reflex+import Reflex.Host.Class+import GHCJS.DOM.HTMLInputElement+import GHCJS.DOM.HTMLTextAreaElement+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.Lens+import Control.Monad hiding (forM_)+import Control.Monad.IO.Class+import Data.Default+import Data.Maybe+import Safe+import Data.Dependent.Sum (DSum (..))++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+               }++data TextInputConfig t+    = TextInputConfig { _textInputConfig_inputType :: String+                      , _textInputConfig_initialValue :: String+                      , _textInputConfig_setValue :: Event t String+                      , _textInputConfig_attributes :: Dynamic t (Map String String)+                      }++instance Reflex t => Default (TextInputConfig t) where+  def = TextInputConfig { _textInputConfig_inputType = "text"+                        , _textInputConfig_initialValue = ""+                        , _textInputConfig_setValue = never+                        , _textInputConfig_attributes = constDyn mempty+                        }++textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t)+textInput (TextInputConfig 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 getKeyEvent+  eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent+  eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent+  dValue <- holdDyn initial $ leftmost [eSetValue, eChange]+  return $ TextInput dValue eKeypress eKeydown eKeyup dFocus e++textInputGetEnter :: Reflex t => TextInput t -> Event t ()+textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i++data TextAreaConfig t+   = TextAreaConfig { _textAreaConfig_initialValue :: String+                    , _textAreaConfig_setValue :: Event t String+                    , _textAreaConfig_attributes :: Dynamic t (Map String String)+                    }++instance Reflex t => Default (TextAreaConfig t) where+  def = TextAreaConfig { _textAreaConfig_initialValue = ""+                       , _textAreaConfig_setValue = never+                       , _textAreaConfig_attributes = constDyn mempty+                       }++data TextArea t+   = TextArea { _textArea_value :: Dynamic t String+              , _textArea_element :: HTMLTextAreaElement+              , _textArea_hasFocus :: Dynamic t Bool+              , _textArea_keypress :: Event t Int+              }++textArea :: MonadWidget t m => TextAreaConfig t -> m (TextArea t)+textArea (TextAreaConfig initial eSet attrs) = do+  e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs+  liftIO $ htmlTextAreaElementSetValue e initial+  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+  performEvent_ $ fmap (liftIO . htmlTextAreaElementSetValue e) eSet+  f <- holdDyn False eChangeFocus+  ev <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e+  v <- holdDyn initial $ leftmost [eSet, ev]+  eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent+  return $ TextArea v e f eKeypress++data CheckboxConfig t+    = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool+                     , _checkboxConfig_attributes :: Dynamic t (Map String String)+                     }++instance Reflex t => Default (CheckboxConfig t) where+  def = CheckboxConfig { _checkboxConfig_setValue = never+                       , _checkboxConfig_attributes = constDyn mempty+                       }++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 -> CheckboxConfig t -> m (Checkbox t)+checkbox checked config = do+  attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config)+  e <- liftM castToHTMLInputElement $ buildEmptyElement "input" attrs+  eClick <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e+  performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ _checkboxConfig_setValue config+  dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick]+  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++data Dropdown t k+    = Dropdown { _dropdown_value :: Dynamic t k+               }++data DropdownConfig t k+   = DropdownConfig { _dropdownConfig_setValue :: Event t k+                    , _dropdownConfig_attributes :: Dynamic t (Map String String)+                    }++instance (Reflex t, Ord k, Show k, Read k) => Default (DropdownConfig t k) where+  def = DropdownConfig { _dropdownConfig_setValue = never+                       , _dropdownConfig_attributes = constDyn mempty+                       }++--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map+--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) -> DropdownConfig t k -> m (Dropdown t k)+dropdown k0 options (DropdownConfig setK attrs) = do+  (eRaw, _) <- elDynAttr' "select" attrs $ 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+  performEvent_ $ fmap (liftIO . htmlSelectElementSetValue e . show) setK+  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) (leftmost [eChange, fmap Just setK])+  return $ Dropdown dValue++liftM concat $ mapM makeLenses+  [ ''TextAreaConfig+  , ''TextArea+  , ''TextInputConfig+  , ''TextInput+  , ''DropdownConfig+  , ''Dropdown+  , ''CheckboxConfig+  , ''Checkbox+  ]++class HasAttributes a where+  type Attrs a :: *+  attributes :: Lens' a (Attrs a)++instance HasAttributes (TextAreaConfig t) where+  type Attrs (TextAreaConfig t) = Dynamic t (Map String String)+  attributes = textAreaConfig_attributes++instance HasAttributes (TextInputConfig t) where+  type Attrs (TextInputConfig t) = Dynamic t (Map String String)+  attributes = textInputConfig_attributes++instance HasAttributes (DropdownConfig t k) where+  type Attrs (DropdownConfig t k) = Dynamic t (Map String String)+  attributes = dropdownConfig_attributes++instance HasAttributes (CheckboxConfig t) where+  type Attrs (CheckboxConfig t) = Dynamic t (Map String String)+  attributes = checkboxConfig_attributes++class HasSetValue a where+  type SetValue a :: *+  setValue :: Lens' a (SetValue a)++instance HasSetValue (TextAreaConfig t) where+  type SetValue (TextAreaConfig t) = Event t String+  setValue = textAreaConfig_setValue++instance HasSetValue (TextInputConfig t) where+  type SetValue (TextInputConfig t) = Event t String+  setValue = textInputConfig_setValue++instance HasSetValue (DropdownConfig t k) where+  type SetValue (DropdownConfig t k) = Event t k+  setValue = dropdownConfig_setValue++instance HasSetValue (CheckboxConfig t) where+  type SetValue (CheckboxConfig t) = Event t Bool+  setValue = checkboxConfig_setValue++class HasValue a where+  type Value a :: *+  value :: a -> Value a++instance HasValue (TextArea t) where+  type Value (TextArea t) = Dynamic t String+  value = _textArea_value++instance HasValue (TextInput t) where+  type Value (TextInput t) = Dynamic t String+  value = _textInput_value++instance HasValue (Dropdown t k) where+  type Value (Dropdown t k) = Dynamic t k+  value = _dropdown_value++instance HasValue (Checkbox t) where+  type Value (Checkbox t) = Dynamic t Bool+  value = _checkbox_value++{-+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+-}+
+ src/Reflex/Dom/Widget/Lazy.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}++module Reflex.Dom.Widget.Lazy where++import Reflex+import Reflex.Dom.Class+import Reflex.Dom.Widget.Basic++import Control.Monad.IO.Class+import Data.Fixed+import Data.Monoid+import qualified Data.Map as Map+import Data.Map (Map)+import GHCJS.DOM.Element++-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.+virtualListWithSelection :: forall t m k v. (MonadWidget t m, Ord k)+  => Int -- ^ The height of the visible region in pixels+  -> Int -- ^ The height of each row in pixels+  -> Dynamic t Int -- ^ The total number of items+  -> Int -- ^ The index of the row to scroll to on initialization+  -> Event t Int -- ^ An 'Event' containing a row index. Used to scroll to the given index.+  -> String -- ^ The element tag for the list+  -> Dynamic t (Map String String) -- ^ The attributes of the list+  -> String -- ^ The element tag for a row+  -> Dynamic t (Map String String) -- ^ The attributes of each row+  -> (k -> Dynamic t v -> m ()) -- ^ The row child element builder+  -> Dynamic t (Map k v) -- ^ The 'Map' of items+  -> m (Dynamic t (Int, Int), Event t k) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and an 'Event' of the selected key+virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTag rowAttrs itemBuilder items = do+  totalHeightStyle <- mapDyn (toHeightStyle . (*) rowPx) maxIndex+  rec (container, itemList) <- elAttr "div" outerStyle $ elAttr' "div" containerStyle $ do+        currentTop <- mapDyn (listWrapperStyle . fst) window+        (_, lis) <- elDynAttr "div" totalHeightStyle $ tagWrapper listTag listAttrs currentTop $ listWithKey itemsInWindow $ \k v -> do+            (li,_) <- tagWrapper rowTag rowAttrs (constDyn $ toHeightStyle rowPx) $ itemBuilder k v+            return $ fmap (const k) (_el_clicked li)+        return lis+      scrollPosition <- holdDyn 0 $ _el_scrolled container+      window <- mapDyn (findWindow heightPx rowPx) scrollPosition+      itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ take num $ drop idx $ Map.toList is) window items+  postBuild <- getPostBuild+  performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]+  indexAndLength <- mapDyn snd window+  sel <- mapDyn (leftmost . Map.elems) itemList+  return (indexAndLength, switch $ current sel)+  where+    toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)+    outerStyle = toStyleAttr $ "position" =: "relative" <>+                               "height" =: (show heightPx <> "px")+    containerStyle = toStyleAttr $ "overflow" =: "auto" <>+                                   "position" =: "absolute" <>+                                   "left" =: "0" <>+                                   "right" =: "0" <>+                                   "height" =: (show heightPx <> "px")+    listWrapperStyle t = toStyleAttr $ "position" =: "relative" <>+                                       "top" =: (show t <> "px")+    toHeightStyle h = toStyleAttr ("height" =: (show h <> "px"))+    tagWrapper elTag attrs attrsOverride c = do+      attrs' <- combineDyn Map.union attrsOverride attrs+      elDynAttr' elTag attrs' c+    findWindow windowSize sizeIncrement startingPosition =+      let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement+          topPx = startingPosition - topOffsetPx+          numItems = windowSize `div` sizeIncrement + 1+          preItems = min startingIndex numItems+      in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))+
+ src/Reflex/Dom/Xhr.hs view
@@ -0,0 +1,120 @@+module Reflex.Dom.Xhr+  ( module Reflex.Dom.Xhr+  , XMLHttpRequest+  , responseTextToText+  , xmlHttpRequestGetReadyState+  , xmlHttpRequestGetResponseText+  , xmlHttpRequestGetStatus+  , xmlHttpRequestGetStatusText+  , xmlHttpRequestNew+  , xmlHttpRequestOnreadystatechange+  , xmlHttpRequestOpen+  , xmlHttpRequestSend+  , xmlHttpRequestSetRequestHeader+  , xmlHttpRequestSetResponseType+  )+where++import Control.Concurrent+import Control.Lens+import Control.Monad hiding (forM)+import Control.Monad.IO.Class+import Data.Aeson+import qualified Data.ByteString.Lazy as BL+import Data.Default+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Text (Text)+import Data.Text.Encoding+import Data.Traversable+import Reflex+import Reflex.Dom.Class+import Reflex.Dom.Xhr.Foreign++data XhrRequest+   = XhrRequest { _xhrRequest_method :: String+                , _xhrRequest_url :: String+                , _xhrRequest_config :: XhrRequestConfig+                }++data XhrRequestConfig+   = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String+                      , _xhrRequestConfig_user :: Maybe String+                      , _xhrRequestConfig_password :: Maybe String+                      , _xhrRequestConfig_responseType :: Maybe String+                      , _xhrRequestConfig_sendData :: Maybe String+                      }++data XhrResponse+   = XhrResponse { _xhrResponse_body :: Maybe Text+                 }++instance Default XhrRequestConfig where+  def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty+                         , _xhrRequestConfig_user = Nothing+                         , _xhrRequestConfig_password  = Nothing+                         , _xhrRequestConfig_responseType  = Nothing+                         , _xhrRequestConfig_sendData  = Nothing+                         }++xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest+xhrRequest = XhrRequest++newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest+newXMLHttpRequest req cb = do+  wv <- askWebView+  postGui <- askPostGui+  liftIO $ do+    xhr <- xmlHttpRequestNew wv+    let c = _xhrRequest_config req+    xmlHttpRequestOpen+      xhr+      (_xhrRequest_method req)+      (_xhrRequest_url req)+      True+      (fromMaybe "" $ _xhrRequestConfig_user c)+      (fromMaybe "" $ _xhrRequestConfig_password c)+    iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr+    maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)+    _ <- xmlHttpRequestOnreadystatechange xhr $ do+      readyState <- liftIO $ xmlHttpRequestGetReadyState xhr+      if readyState == 4+          then do+            r <- liftIO $ xmlHttpRequestGetResponseText xhr+            _ <- liftIO $ postGui $ cb $ XhrResponse $ responseTextToText r+            return ()+          else return ()+    _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)+    return xhr++performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)+performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do+  _ <- newXMLHttpRequest r $ liftIO . cb+  return ()++performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))+performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do+  resps <- forM rs $ \r -> do+    resp <- liftIO newEmptyMVar+    _ <- newXMLHttpRequest r $ liftIO . putMVar resp+    return resp+  _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar+  return ()++getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))+getAndDecode url = do+  r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url+  return $ fmap decodeXhrResponse r++getMay :: MonadWidget t m => (Event t a -> m (Event t b)) -> Event t (Maybe a) -> m (Event t (Maybe b))+getMay f e = do+    e' <- f (fmapMaybe id e)+    return $ leftmost [fmap Just e', fmapMaybe (maybe (Just Nothing) (const Nothing)) e]++decodeText :: FromJSON a => Text -> Maybe a+decodeText = decode . BL.fromStrict . encodeUtf8++decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a+decodeXhrResponse = join . fmap decodeText . _xhrResponse_body+