glazier-react 0.6.0.0 → 1.0.0.0

raw patch · 39 files changed

+2645/−922 lines, 39 filesdep +alternatorsdep +data-diversedep +data-diverse-lensdep −disposabledep −freedep −mmorphdep ~containersdep ~deepseqdep ~dlistPVP ok

version bump matches the API change (PVP)

Dependencies added: alternators, data-diverse, data-diverse-lens, lens-misc, newtype-generics, tagged, unliftio, unliftio-core

Dependencies removed: disposable, free, mmorph, pipes-concurrency, profunctors, semigroupoids, text, unordered-containers

Dependency ranges changed: containers, deepseq, dlist, ghcjs-base-stub, glazier, javascript-extras, lens, mtl, stm, transformers

API changes (from Hackage documentation)

Files

• README.md +6/−6
• glazier-react.cabal +46/−29
• jsbits/react.js +80/−33
• jsbits/registry.js +1/−1
• src/Glazier/React.hs +63/−0
• src/Glazier/React/Command.hs +0/−27
• src/Glazier/React/Command/Run.hs +0/−35
• src/Glazier/React/Component.hs +5/−38
• src/Glazier/React/Component/Internal.hs +69/−0
• src/Glazier/React/Element.hs +26/−20
• src/Glazier/React/Entity.hs +26/−0
• src/Glazier/React/Event.hs +0/−334
• src/Glazier/React/Event/HashChange.hs +59/−0
• src/Glazier/React/Event/Keyboard.hs +73/−0
• src/Glazier/React/Event/Mouse.hs +81/−0
• src/Glazier/React/Event/Synthetic.hs +54/−0
• src/Glazier/React/EventTarget.hs +8/−0
• src/Glazier/React/EventTarget/Internal.hs +39/−0
• src/Glazier/React/Gadget.hs +34/−0
• src/Glazier/React/Maker.hs +0/−69
• src/Glazier/React/Maker/Run.hs +0/−54
• src/Glazier/React/Markup.hs +108/−83
• src/Glazier/React/Model.hs +0/−105
• src/Glazier/React/NativeEvent.hs +7/−0
• src/Glazier/React/NativeEvent/Internal.hs +39/−0
• src/Glazier/React/Notice.hs +10/−0
• src/Glazier/React/Notice/Internal.hs +120/−0
• src/Glazier/React/ReactDOM.hs +8/−7
• src/Glazier/React/ReactId.hs +6/−0
• src/Glazier/React/ReactId/Internal.hs +28/−0
• src/Glazier/React/Reactor.hs +375/−0
• src/Glazier/React/Reactor/Exec.hs +746/−0
• src/Glazier/React/ReadIORef.hs +7/−0
• src/Glazier/React/ReadIORef/Internal.hs +34/−0
• src/Glazier/React/Scene.hs +143/−0
• src/Glazier/React/Subject.hs +8/−0
• src/Glazier/React/Subject/Internal.hs +43/−0
• src/Glazier/React/Widget.hs +193/−81
• src/Glazier/React/Window.hs +100/−0

@@ -62,13 +62,13 @@ bh (strJS "footer") [("className", strJS "footer")] $ do     bh (strJS "span") [ ("className", strJS "todo-count")                       , ("key", strJS "todo-count")] $ do-            bh (strJS "strong") [("key", strJS "items")]+            bh (strJS "strong") [("key", strJS "pieces")]                 (s ^. activeCount . to (txt . pack . show))-            txt " items left"+            txt " pieces left" ```  ## Event handling-React re-uses SyntheticEvent from a pool, which means it may no longer be valid if we lazily parse it. However, we still want lazy parsing so we don't parse unnecessary fields.+React re-uses Notice from a pool, which means it may no longer be valid if we lazily parse it. However, we still want lazy parsing so we don't parse unnecessary fields.  Additionally, we don't want to block during the event handling.The reason this is a problem is because Javascript is single threaded, but Haskell is lazy. Therefore GHCJS threads are a strange mixture of synchronous and asynchronous threads, where a synchronous thread might be converted to an asynchronous thread if a "black hole" is encountered.@@ -83,7 +83,7 @@ ```  This safe interface requires two input functions:-1. a function to reduce SyntheticEvent to a NFData. The mkEventCallback will ensure that the NFData is forced which will ensure all the required fields from Synthetic event has been parsed. This function must not block.+1. a function to reduce Notice to a NFData. The mkEventCallback will ensure that the NFData is forced which will ensure all the required fields from Synthetic event has been parsed. This function must not block. 2. a second function that uses the NFData. This function is allowed to block.   mkEventHandler results in a function that you can safely pass into 'GHC.Foreign.Callback.syncCallback1' with 'GHCJS.Foreign.Callback.ContinueAsync'.@@ -156,11 +156,11 @@ ``` The rendering instructions for that widget: ```-window:: WindowT (Scene Model Plan) (ReactMlT Identity) ()+window:: WindowT (Scene Model Plan) ReactMl () ``` The state changes from `Action` events: ```-gadget :: GadgetT Action (Gizmo Model Plan) Identity (DList Command)+gadget :: Gadget () Action (Gizmo Model Plan) (DList Command) ``` This is everything you need in order to serialize, deserialize, create, render and interact with a widget. 

@@ -1,8 +1,7 @@ name:                glazier-react-version:             0.6.0.0-synopsis:            ReactJS binding using Glazier and Pipes.Fluid-description:         ReactJS binding using Glazier and Pipes.Fluid, which is-                     more functional and composable than Elm/Flux.+version:             1.0.0.0+synopsis:            ReactJS binding using Glazier.Command.+description:         ReactJS binding using Glazier.Commmand. Please see README.md. homepage:            https://github.com/louispan/glazier-react#readme license:             BSD3 license-file:        LICENSE@@ -18,42 +17,60 @@   hs-source-dirs:      src   js-sources:          jsbits/react.js                        jsbits/registry.js-  exposed-modules:     Glazier.React.Command-                       Glazier.React.Command.Run+  exposed-modules:     Glazier.React                        Glazier.React.Component+                       Glazier.React.Component.Internal                        Glazier.React.Element-                       Glazier.React.Event-                       Glazier.React.Maker-                       Glazier.React.Maker.Run+                       Glazier.React.Entity+                       Glazier.React.Event.HashChange+                       Glazier.React.Event.Keyboard+                       Glazier.React.Event.Mouse+                       Glazier.React.Event.Synthetic+                       Glazier.React.EventTarget+                       Glazier.React.EventTarget.Internal+                       Glazier.React.Gadget                        Glazier.React.Markup-                       Glazier.React.Model+                       Glazier.React.NativeEvent+                       Glazier.React.NativeEvent.Internal+                       Glazier.React.Notice+                       Glazier.React.Notice.Internal                        Glazier.React.ReactDOM+                       Glazier.React.ReactId+                       Glazier.React.ReactId.Internal+                       Glazier.React.Reactor+                       Glazier.React.Reactor.Exec+                       Glazier.React.ReadIORef+                       Glazier.React.ReadIORef.Internal+                       Glazier.React.Scene+                       Glazier.React.Subject+                       Glazier.React.Subject.Internal                        Glazier.React.Widget+                       Glazier.React.Window   build-depends:       base >= 4.7 && < 5-                     , containers >= 0.5 && < 0.6-                     , deepseq >= 1.4 && < 1.5-                     , disposable >= 0.2.0.4 && < 1-                     , dlist >= 0.8 && < 0.9-                     , free >= 4.12 && < 5-                     , glazier >= 0.10 && < 1-                     , javascript-extras >= 0.3.0.0 && < 1-                     , lens >= 4 && < 5-                     , mmorph >= 1 && < 2-                     , mtl >= 2 && < 3-                     , pipes-concurrency >= 2 && < 3-                     , profunctors >= 5 && < 6-                     , semigroupoids >= 5 && < 6-                     , stm >= 2.4 && < 3-                     , text >= 1.2 && < 1.3-                     , transformers >= 0.4 && < 0.6-                     , unordered-containers >= 0.2.7 && < 0.3+                     , alternators >= 1.0+                     , containers >= 0.5+                     , data-diverse >= 4.6+                     , data-diverse-lens >= 4.3+                     , deepseq >= 1.4+                     , dlist >= 0.8+                     , glazier >= 1.0+                     , javascript-extras >= 0.5+                     , lens >= 4+                     , lens-misc >= 0+                     , mtl >= 2+                     , newtype-generics >= 0.5+                     , stm >= 2.4.5+                     , tagged >= 0.8+                     , transformers >= 0.4+                     , unliftio >= 0.2+                     , unliftio-core >= 0.1   default-language:    Haskell2010   default-extensions:  ApplicativeDo-  ghc-options:         -Wall+  ghc-options:         -Wall -Wredundant-constraints   if impl(ghcjs)     build-depends: ghcjs-base   if !impl(ghcjs)-    build-depends: ghcjs-base-stub >= 0.1.0.1 && < 1+    build-depends: ghcjs-base-stub >= 0.2  source-repository head   type:     git

@@ -1,39 +1,86 @@-// This function requires that React is in scope by the time this is called.-// Using React.createClass for now since not all browsers support ES6 classes-// It is the equivalent of the following:-// import React from 'react';+// Node module dependencies+// Example package.json:+// {+//   "dependencies": {+//     "react": "^15.4.2",+//     "react-dom": "^15.4.2"+//   }+// }+var hgr$React_ = null;+function hgr$React() {+    if (!hgr$React_) {+        hgr$React_ = require('react');+    }+    return hgr$React_;+} -// // Inheriting from Component means every call to this.setState will result in a render-// // Inheriting from PureComponet means a shallow comparison will be made-// class Shim extends React.PureComponent {+var hgr$ReactDOM_ = null;+function hgr$ReactDOM() {+    if (!hgr$ReactDOM_) {+        hgr$ReactDOM_ = require('react-dom');+    }+    return hgr$ReactDOM_;+} -//     componentDidUpdate() {-//         if (this.props['componentDidUpdate'])-//             this.props['componentDidUpdate'](this.state);-//     }+var hgr$shimComponent_ = null;+function hgr$shimComponent() {+    if (!hgr$shimComponent_) {+        // The state in the Shim contains+        //   frame :: A GHCJS.Foreign.Export of the haskell state to render.+        // Inheriting from Component means every call to this.setState will result in a render.+        // Inheriting from PureComponet means a shallow comparison will be made.+        // Protect "PureComponent" from closure compiler because it's not in the official externs.+        var ReactPureComponent = hgr$React()["PureComponent"]; -//     render() {-//         if (this.props['render'])-//             return this.props['render'](this.state);-//         return null;-//     }-// }-// export default Shim;-function hgr$mkClass() {-    const specs = {};-    specs['componentDidUpdate'] = function() {-        if (this.props['componentDidUpdate'])-            this.props['componentDidUpdate'](this.state);-    };-    specs['render'] = function() {-        if (this.props['render'])-            return this.props['render'](this.state);-        return null;-    };-    const cl = React.createClass(specs);-    cl.prototype.isPureReactComponent = true;+        class Shim extends ReactPureComponent { -    return cl;+            constructor(props) {+                super(props);+                this.state = { frameNum: 0 };+            }++            rerender() {+                this.setState(function(prevState, props) {+                    var newFrameNum = this.safeIncrement(prevState.frameNum);+                    return {+                        frameNum: newFrameNum+                    };+                });+            }++            safeIncrement(i) {+                if (i >= Number.MAX_SAFE_INTEGER) {+                        return Number.MIN_SAFE_INTEGER+                    }+                    else {+                        return i + 1;+                }+            }++            componentDidUpdate(prevProps, prevState) {+                // componentDidUpdate is not called on initial render.+                // ignore prevProps, prevState and forward to a custom callback+                if (this.props['rendered'])+                    this.props['rendered']();+            }++            componentDidMount() {+                // Also forward to updated so it gets a callback on initial render.+                if (this.props['mounted'])+                    this.props['mounted']();+                if (this.props['rendered'])+                    this.props['rendered']();+            }++            render() {+                if (this.props['render'])+                    return this.props['render']();+                return null;+            }+        }+        hgr$shimComponent_ = Shim;+    }+    return hgr$shimComponent_; }  // Convert a list of ReactElements into a single ReactElement@@ -46,7 +93,7 @@             return elements[0];         }         else {-            return React.createElement('div', null, elements);+            return hgr$React().createElement('div', null, elements);         }     }     return null;

@@ -11,7 +11,7 @@     const handlers = {};      // a copy of Lodash's omit, to copy dictionary except for one key-    function omit(obj, omitKey) {+    this['omit'] = function(obj, omitKey) {         return Object.keys(obj).reduce(function(result, key) {             if(key !== omitKey) {                 result[key] = obj[key];

@@ -0,0 +1,63 @@+-- | NB. Glazier.React.Event.* are not exported due to duplicate record fields+-- It is up to the user to import the Event modules as required.+module Glazier.React+    ( module Glazier.Command+    , module Glazier.Command.Exec+    , module Glazier.React.Component+    , module Glazier.React.Element+    , module Glazier.React.EventTarget+    , module Glazier.React.Gadget+    , module Glazier.React.Entity+    , module Glazier.React.ReadIORef+    , module Glazier.React.Markup+    , module Glazier.React.NativeEvent+    , module Glazier.React.Notice+    , module Glazier.React.ReactDOM+    , module Glazier.React.ReactId+    , module Glazier.React.Reactor+    , module Glazier.React.Reactor.Exec+    , module Glazier.React.Scene+    , module Glazier.React.Subject+    , module Glazier.React.Widget+    , module Glazier.React.Window+    , module Control.Also+    , module Control.Monad+    , module Control.Monad.Trans+    , module Control.Monad.Delegate+    , module Control.Monad.Reader+    , module Control.Monad.Except+    , module Control.Monad.RWS.Strict+    , module Control.Monad.State.Strict+    , module Control.Monad.Trans.Maybe+    , module Control.Monad.Trans.Maybe.Extras+    ) where++import Control.Also+import Control.Monad+import Control.Monad.Delegate+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.RWS.Strict+import Control.Monad.State.Strict+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Maybe.Extras+import Glazier.Command+import Glazier.Command.Exec+import Glazier.React.Component+import Glazier.React.Element+import Glazier.React.Entity+import Glazier.React.EventTarget+import Glazier.React.Gadget+import Glazier.React.Markup+import Glazier.React.NativeEvent+import Glazier.React.Notice+import Glazier.React.ReactDOM+import Glazier.React.ReactId+import Glazier.React.Reactor+import Glazier.React.Reactor.Exec+import Glazier.React.ReadIORef+import Glazier.React.Scene+import Glazier.React.Subject+import Glazier.React.Widget+import Glazier.React.Window

@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--module Glazier.React.Command-    ( basicRenderCmd-    ) where--import Control.Lens-import Control.Monad.State.Strict-import qualified GHCJS.Types as J-import qualified JavaScript.Extras as JE---- | Just change the state to something different so the React pureComponent will call render()--- renderCmd :: Monad m => (sm -> [JE.Property] -> J.JSVal -> cmd) -> G.GadgetT act sm m cmd--- The resulting command should be interpreted using 'componentSetState'-basicRenderCmd :: MonadState sm m =>-           Lens' sm Int-           -- -> Getter sm Int-           -> Getter sm J.JSVal-           -> (sm -> [JE.Property] -> J.JSVal -> cmd)-           -> m cmd-basicRenderCmd frameNum componentRef fcmd = do-    frameNum %= (\i -> (i `mod` JE.maxSafeInteger) + 1)-    i <- JE.toJS <$> use frameNum-    r <- use componentRef-    sm <- get-    pure $ fcmd sm [("frameNum", JE.JSVar i)] r

@@ -1,35 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}---- | Common functions used by command interpreters-module Glazier.React.Command.Run-    ( componentSetState-    ) where--import Control.Concurrent.MVar-import Control.Lens-import Control.Monad-import qualified GHCJS.Types as J-import qualified Glazier.React.Model as R-import qualified JavaScript.Extras as JE-import qualified JavaScript.Object as JO--componentSetState :: R.HasGizmo giz mdl pln => giz -> [JE.Property] -> J.JSVal -> IO ()-componentSetState giz props j = do-    let scn = giz ^. R.scene-        frm = giz ^. R.frame-    void $ swapMVar frm scn-    js_componentSetState (JE.fromProperties props) j--#ifdef __GHCJS__--foreign import javascript unsafe-  "if ($2 && $2['setState']) { $2['setState']($1); }"-  js_componentSetState :: JO.Object -> J.JSVal -> IO ()--#else--js_componentSetState :: JO.Object -> J.JSVal -> IO ()-js_componentSetState _ _ = pure ()--#endif

@@ -1,41 +1,8 @@-{-# LANGUAGE CPP #-}- module Glazier.React.Component-    ( ReactComponent-    , mkComponent+    ( ShimComponent -- constructor not exported+    , shimComponent+    , rerenderShim+    , ComponentRef -- constructor not exported     ) where -import qualified Control.Disposable as CD-import qualified GHCJS.Types as J-import qualified GHCJS.Marshal.Pure as J-import qualified JavaScript.Extras.Cast as JE---- | A newtype wrapper to give a noop disposable instance to React components--- This allows generic deriving of model Adaptors.-newtype ReactComponent = ReactComponent J.JSVal--instance CD.Disposing ReactComponent where-    disposing _ = CD.DisposeNone--instance J.IsJSVal ReactComponent-instance J.PToJSVal ReactComponent where-    pToJSVal = J.jsval-instance JE.ToJS ReactComponent--mkComponent :: IO ReactComponent-mkComponent = ReactComponent <$> js_mkComponent--#ifdef __GHCJS__--foreign import javascript unsafe-  "$r = hgr$mkClass();"-  js_mkComponent-      :: IO J.JSVal--#else--js_mkComponent :: IO J.JSVal-js_mkComponent = pure J.nullRef---#endif+import Glazier.React.Component.Internal

@@ -0,0 +1,69 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Glazier.React.Component.Internal+    ( ShimComponent(..) -- constructor exported+    , shimComponent+    , rerenderShim+    , ComponentRef(..) -- constructor exported+    ) where++import Control.DeepSeq+import Data.String+import qualified GHC.Generics as G+import qualified GHCJS.Marshal.Pure as J+import qualified GHCJS.Types as J+import qualified JavaScript.Extras as JE++-- | Returns a reference to the javascript *class* definition+-- of the shim wrapper around ReactPureComponent+newtype ShimComponent = ShimComponent JE.JSRep+    deriving (G.Generic, Show, J.IsJSVal, J.PToJSVal, JE.ToJS, IsString, NFData)++-- | This returns the javascript class definition of ShimComponent.+-- There is ever only one shim class, so it is purely available+shimComponent :: ShimComponent+shimComponent = ShimComponent js_shimComponent++-- | Rerenders an instance of a component created using ShimComponent.+rerenderShim :: ComponentRef -> IO ()+rerenderShim = js_rerenderShim++-- | This is used store the react "ref" to a javascript instance of a react Component.+newtype ComponentRef = ComponentRef JE.JSRep+    deriving (G.Generic, Show, J.IsJSVal, J.PToJSVal, JE.ToJS, IsString, NFData)++instance JE.FromJS ComponentRef where+    fromJS a | js_isReactComponent a = Just $ ComponentRef $ JE.JSRep a+    fromJS _ = Nothing++#ifdef __GHCJS__++foreign import javascript unsafe+  "$r = hgr$shimComponent();"+  js_shimComponent :: JE.JSRep++-- !!blah is javascript way of converting to bool+-- using undocumented api to check if something is react component+-- https://stackoverflow.com/questions/33199959/how-to-detect-a-react-component-vs-a-react-element+foreign import javascript unsafe+    "!(!($1 && !(!($1['isReactComponent']))))"+    js_isReactComponent :: J.JSVal -> Bool++foreign import javascript unsafe+  "if ($1 && $1['rerender']) { $1['rerender']() };"+  js_rerenderShim :: ComponentRef -> IO ()++#else++js_shimComponent :: JE.JSRep+js_shimComponent = JE.JSRep J.nullRef++js_isReactComponent :: J.JSVal -> Bool+js_isReactComponent _ = False++js_rerenderShim :: ComponentRef -> IO ()+js_rerenderShim _ = pure ()++#endif

@@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}  -- | 'Lucid.HtmlT' inspired monad for creating 'ReactElement's module Glazier.React.Element-    ( ReactElement+    ( ReactElement -- constructor is not exported     , unsafeCoerceElement     , mkBranchElement     , mkLeafElement@@ -11,18 +13,22 @@     , mkCombinedElements     ) where +import Control.DeepSeq+import Control.Newtype.Generics+import Data.String+import qualified GHC.Generics as G import qualified GHCJS.Marshal.Pure as J import qualified GHCJS.Types as J import qualified JavaScript.Array as JA-import qualified JavaScript.Object as JO import qualified JavaScript.Extras as JE+import qualified JavaScript.Object as JO -newtype ReactElement = ReactElement J.JSVal-instance J.IsJSVal ReactElement-instance J.PToJSVal ReactElement where-    pToJSVal = J.jsval-instance JE.ToJS ReactElement+-- | NB. No FromJS provided. See 'unsafeCoerceElement' below.+newtype ReactElement = ReactElement JE.JSRep+    deriving (G.Generic, Show, J.IsJSVal, J.PToJSVal, JE.ToJS, IsString, NFData) +instance Newtype ReactElement+ -- | Unfortunately, ReactJS did not export an easy way to check if something is a ReactElement, -- although they do so in the internal code with REACT_ELEMENT_TYPE. -- This function allow coercing a ReactElement from a JSVal@@ -30,15 +36,15 @@ -- This function is required when receiving ReactElement from javascript (eg in a callback) -- or to interface with foreign React Elements. unsafeCoerceElement :: J.JSVal -> ReactElement-unsafeCoerceElement = ReactElement+unsafeCoerceElement = ReactElement . JE.JSRep  -- | Create a react element (with children) from a HashMap of properties-mkBranchElement :: JE.JSVar -> [JE.Property] -> [ReactElement] -> IO ReactElement+mkBranchElement :: JE.JSRep -> [JE.Property] -> [ReactElement] -> IO ReactElement mkBranchElement n props xs =     js_mkBranchElement n (JE.fromProperties props) (JA.fromList $ JE.toJS <$> xs)  -- | Create a react element (with no children) from a HashMap of properties-mkLeafElement :: JE.JSVar -> [JE.Property] -> IO ReactElement+mkLeafElement :: JE.JSRep -> [JE.Property] -> IO ReactElement mkLeafElement n props =     js_mkLeafElement n (JE.fromProperties props) @@ -58,12 +64,12 @@ -- a different ReactElement may be created, because JSVal -- and JSArray are mutable. foreign import javascript unsafe-    "$r = React.createElement($1, $2, $3);"-    js_mkBranchElement :: JE.JSVar -> JO.Object -> JA.JSArray -> IO ReactElement+    "$r = hgr$React().createElement($1, $2, $3);"+    js_mkBranchElement :: JE.JSRep -> JO.Object -> JA.JSArray -> IO ReactElement  foreign import javascript unsafe-    "$r = React.createElement($1, $2);"-    js_mkLeafElement :: JE.JSVar -> JO.Object -> IO ReactElement+    "$r = hgr$React().createElement($1, $2);"+    js_mkLeafElement :: JE.JSRep -> JO.Object -> IO ReactElement  foreign import javascript unsafe     "$r = $1;"@@ -79,16 +85,16 @@ -- | This is an IO action because even if the same args was used -- a different ReactElement may be created, because JSVal -- and JSArray are mutable.-js_mkBranchElement :: JE.JSVar -> JO.Object -> JA.JSArray -> IO ReactElement-js_mkBranchElement _ _ _ = pure (ReactElement J.nullRef)+js_mkBranchElement :: JE.JSRep -> JO.Object -> JA.JSArray -> IO ReactElement+js_mkBranchElement _ _ _ = pure (ReactElement $ JE.JSRep J.nullRef) -js_mkLeafElement :: JE.JSVar -> JO.Object -> IO ReactElement-js_mkLeafElement _ _ =  pure (ReactElement J.nullRef)+js_mkLeafElement :: JE.JSRep -> JO.Object -> IO ReactElement+js_mkLeafElement _ _ =  pure (ReactElement $ JE.JSRep J.nullRef)  js_textElement :: J.JSString -> ReactElement-js_textElement _ = ReactElement J.nullRef+js_textElement _ = ReactElement $ JE.JSRep J.nullRef  js_mkCombinedElements :: JA.JSArray -> IO ReactElement-js_mkCombinedElements _ = pure (ReactElement J.nullRef)+js_mkCombinedElements _ = pure (ReactElement $ JE.JSRep J.nullRef)  #endif

@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Glazier.React.Entity where++import Control.Lens+import Glazier.React.Subject++----------------------------------------------------------------------------------++data Entity p s = Entity (Subject p) (Traversal' p s)++_subject :: Lens' (Entity p s) (Subject p)+_subject = lens (\(Entity p _) -> p) (\(Entity _ s) p -> Entity p s)++_self :: Lens (Entity p s) (Entity p s') (ReifiedTraversal' p s) (ReifiedTraversal' p s')+_self = lens (\(Entity _ s) -> Traversal s) (\(Entity p _) (Traversal t) -> Entity p t)++magnifiedEntity ::+    ( Magnify m n (Entity p a) (Entity p b)+    , Contravariant (Magnified m r)+    )+    => Traversal' b a -> m r -> n r+magnifiedEntity l = magnify (to go)+  where+    go (Entity sbj slf) = Entity sbj (slf.l)

@@ -1,334 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}---- | This module based on React/Flux/PropertiesAndEvents.hs.-module Glazier.React.Event-  ( DOMEventTarget-  , DOMEvent-  , SyntheticEvent-  , eventHandler-  , eventHandlerM-  , Event(..)-  , preventDefault-  , isDefaultPrevented-  , stopPropagation-  , isPropagationStopped-  , parseEvent-  , MouseEvent(..)-  , parseMouseEvent-  , KeyboardEvent(..)-  , parseKeyboardEvent-  )-where--import Control.DeepSeq-import qualified Data.JSString as J-import qualified GHCJS.Foreign as J-import qualified GHCJS.Marshal.Pure as J-import qualified GHCJS.Types as J-import qualified JavaScript.Extras.Cast as JE---- | The object that dispatched the event.--- https://developer.mozilla.org/en-US/docs/Web/API/Event/target-newtype DOMEventTarget = DOMEventTarget J.JSVal--instance J.IsJSVal DOMEventTarget-instance J.PToJSVal DOMEventTarget where-    pToJSVal = J.jsval-instance JE.ToJS DOMEventTarget-instance JE.FromJS DOMEventTarget where-    fromJS a | js_isDOMEventTarget a = Just $ DOMEventTarget a-    fromJS _ = Nothing---- | The native event--- https://developer.mozilla.org/en-US/docs/Web/API/Event-newtype DOMEvent = DOMEvent J.JSVal--instance J.IsJSVal DOMEvent-instance J.PToJSVal DOMEvent where-    pToJSVal = J.jsval-instance JE.ToJS DOMEvent-instance JE.FromJS DOMEvent where-    fromJS a | js_isDOMEvent a = Just $ DOMEvent a-    fromJS _ = Nothing---- | Every event in React is a synthetic event, a cross-browser wrapper around the native event.--- 'SyntheticEvent' must only be used in the first part of 'eventHandler'.-newtype SyntheticEvent = SyntheticEvent J.JSVal--instance J.IsJSVal SyntheticEvent-instance J.PToJSVal SyntheticEvent where-    pToJSVal = J.jsval-instance JE.ToJS SyntheticEvent-instance JE.FromJS SyntheticEvent where-    fromJS a | js_isSyntheticEvent a = Just $ SyntheticEvent a-    fromJS _ = Nothing---- | Using the NFData idea from React/Flux/PropertiesAndEvents.hs--- React re-uses SyntheticEvent from a pool, which means it may no longer be valid if we lazily--- parse it. However, we still want lazy parsing so we don't parse unnecessary fields.--- Additionally, we don't want to block during the event handling.The reason this is a problem is--- because Javascript is single threaded, but Haskell is lazy.--- Therefore GHCJS threads are a strange mixture of synchronous and asynchronous threads,--- where a synchronous thread might be converted to an asynchronous thread if a "black hole" is encountered.--- See https://github.com/ghcjs/ghcjs-base/blob/master/GHCJS/Concurrent.hs--- This safe interface requires two input functions:--- 1. a function to reduce SyntheticEvent to a NFData. The mkEventCallback will ensure that the--- NFData is forced which will ensure all the required fields from Synthetic event has been parsed.--- This function must not block.--- 2. a second function that uses the NFData. This function is allowed to block.--- mkEventHandler results in a function that you can safely pass into 'GHC.Foreign.Callback.syncCallback1'--- with 'GHCJS.Foreign.Callback.ContinueAsync'.-eventHandler :: NFData a => (evt -> a) -> (a -> b) -> (evt -> b)-eventHandler goStrict goLazy evt = goLazy $!! goStrict evt---- | a monadic version of eventHandler--- The monad's effects must not block!-eventHandlerM :: (Monad m, NFData a) => (evt -> m a) -> (a -> m b) -> (evt -> m b)-eventHandlerM goStrict goLazy evt = do-    r <- goStrict evt-    goLazy $!! r--preventDefault :: SyntheticEvent -> IO ()-preventDefault = js_preventDefault--isDefaultPrevented :: SyntheticEvent -> Bool-isDefaultPrevented = js_isDefaultPrevented--stopPropagation :: SyntheticEvent -> IO ()-stopPropagation = js_stopPropagation--isPropagationStopped :: SyntheticEvent -> Bool-isPropagationStopped = js_isPropagationStopped---- | Every `SyntheticEvent` can be parsed to an `Event`.--- 'Event' must only be used in the first part of 'eventHandler'.-data Event = Event-    { bubbles :: Bool-    , cancelable :: Bool-    , currentTarget :: DOMEventTarget-    , defaultPrevented :: Bool-    , eventPhase :: Int-    , isTrusted :: Bool-    , nativeEvent :: DOMEvent-    , target :: DOMEventTarget-    , timeStamp :: Int-    -- type is a reserved word, so prefix to eventType-    , eventType :: J.JSString-    }---- | We can lie about this not being in IO because--- within the strict part of 'eventHandlerM'--- the SyntheticEvent is effectively immutable.--- In reality SyntheticEvent is reused from a pool.--- We want to maintain this lie so that we can lazily parse only the--- properties the event handler is interested in.--- This will throw if J.JSVal is null, or not convertible to the desired type--- so we are assuming that SyntheticEvent will behave nicely.-unsafeProperty :: J.PFromJSVal a => J.JSVal -> J.JSString -> a-unsafeProperty v = J.pFromJSVal . js_unsafeProperty v---- | We can lie about this not being in IO because--- within the strict part of 'eventHandlerM'--- the SyntheticEvent is effectively immutable.-parseEvent :: SyntheticEvent -> Event-parseEvent (SyntheticEvent evt) =-    Event-    { bubbles = unsafeProperty evt "bubbles"-    , cancelable = unsafeProperty evt "cancelable"-    , currentTarget = DOMEventTarget $ js_unsafeProperty evt "currentTarget"-    , defaultPrevented = unsafeProperty evt "defaultPrevented"-    , eventPhase = unsafeProperty evt "eventPhase"-    , isTrusted = unsafeProperty evt "isTrusted"-    , nativeEvent = DOMEvent evt-    , target = DOMEventTarget $ js_unsafeProperty evt "target"-    , timeStamp = unsafeProperty evt "timeStamp"-    , eventType = unsafeProperty evt "type"-    }---- | Mouse and Drag/Drop events--- 'MouseEvent' must only be used in the first part of 'eventHandler'.--- https://facebook.github.io/react/docs/events.html#mouse-events--- https://developer.mozilla.org/en-US/docs/Web/Events--- Event names (eventType)--- onClick (click) onContextMenu (contextmenu) onDoubleClick (dblclick)--- onDrag (drag) onDragEnd (dragend) onDragEnter (dragenter) onDragExit (dragexit)--- onDragLeave (dragleave) onDragOver (dragover) onDragStart (dragstart)--- onDrop (drop) onMouseDown (mousedown) onMouseEnter (mouseenter) onMouseLeave (mouseleave)--- onMouseMove (mousemove) onMouseOut (mouseout) onMouseOver (mouseover) onMouseUp (mouseup)-data MouseEvent = MouseEvent-  { altKey :: Bool-  , button :: Int-  , buttons :: Int-  , clientX :: Int-  , clientY :: Int-  , ctrlKey :: Bool-  , getModifierState :: J.JSString -> Bool-  , metaKey :: Bool-  , pageX :: Int-  , pageY :: Int-  , relatedTarget :: DOMEventTarget-  , screenX :: Int-  , screenY :: Int-  , shiftKey :: Bool-  }---- | See https://www.w3.org/TR/DOM-Level-3-Events-key/#keys-modifier--- This will throw if J.JSVal is null, but shouldn't happen since we've--- already check for a valid SyntheticEvent-unsafeGetModifierState :: J.JSVal -> J.JSString -> Bool-unsafeGetModifierState obj k = J.fromJSBool $ js_unsafeGetModifierState obj k---- | We can lie about this not being in IO because--- within the strict part of 'eventHandlerM'--- the SyntheticEvent is effectively immutable.-parseMouseEvent :: SyntheticEvent -> Maybe MouseEvent-parseMouseEvent (SyntheticEvent evt) | js_isMouseEvent (js_unsafeProperty evt "nativeEvent") = Just $-    MouseEvent-    { altKey = unsafeProperty evt "altKey"-    , button = unsafeProperty evt "button"-    , buttons = unsafeProperty evt "buttons"-    , clientX = unsafeProperty evt "clientX"-    , clientY = unsafeProperty evt "clientY"-    , ctrlKey = unsafeProperty evt "ctrlKey"-    , getModifierState = unsafeGetModifierState evt-    , metaKey = unsafeProperty evt "metaKey"-    , pageX = unsafeProperty evt "pageX"-    , pageY = unsafeProperty evt "pageY"-    , relatedTarget = DOMEventTarget $ js_unsafeProperty evt "relatedTarget"-    , screenX = unsafeProperty evt "screenX"-    , screenY = unsafeProperty evt "xcreenY"-    , shiftKey = unsafeProperty evt "shiftKey"-    }-parseMouseEvent _ | otherwise = Nothing---- | Keyboard events--- 'KeyboardEvent' must only be used in the first part of 'eventHandler'.--- https://facebook.github.io/react/docs/events.html#keyboard-events--- Event names (eventType)--- onKeyDown (keydown) onKeyPress (keypress) onKeyUp (keyyp)-data KeyboardEvent = KeyboardEvent-  { altKey :: Bool-  , charCode ::Int-  , ctrlKey :: Bool-  , getModifierState :: J.JSString -> Bool-  , key :: J.JSString-  , keyCode :: Int-  , locale :: J.JSString-  , location ::Int-  , metaKey :: Bool-  , repeat :: Bool-  , shiftkey :: Bool-  , which :: Int-  }---- | We can lie about this not being in IO because--- within the strict part of 'eventHandlerM'--- the SyntheticEvent is effectively immutable.-parseKeyboardEvent :: SyntheticEvent -> Maybe KeyboardEvent-parseKeyboardEvent (SyntheticEvent evt) | js_isKeyboardEvent (js_unsafeProperty evt "nativeEvent") = Just $-    KeyboardEvent-    { altKey = unsafeProperty evt "altKey"-    , charCode = unsafeProperty evt "charCode"-    , ctrlKey = unsafeProperty evt "ctrlKey"-    , getModifierState = unsafeGetModifierState evt-    , key = unsafeProperty evt "key"-    , keyCode = unsafeProperty evt "keyCode"-    , locale = unsafeProperty evt "locale"-    , location = unsafeProperty evt "location"-    , metaKey = unsafeProperty evt "metaKey"-    , repeat = unsafeProperty evt "repeat"-    , shiftkey = unsafeProperty evt "shiftkey"-    , which = unsafeProperty evt "which"-    }-parseKeyboardEvent _ | otherwise = Nothing--#ifdef __GHCJS__--foreign import javascript unsafe-    "$1 instanceof EventTarget"-    js_isDOMEventTarget :: J.JSVal -> Bool--foreign import javascript unsafe-    "$1 instanceof Event"-    js_isDOMEvent :: J.JSVal -> Bool--foreign import javascript unsafe-    "($1 && $1['nativeEvent'] && $1['nativeEvent'] instanceof Event)"-    js_isSyntheticEvent :: J.JSVal -> Bool--foreign import javascript unsafe-    "$1['preventDefault']()"-    js_preventDefault :: SyntheticEvent -> IO ()--foreign import javascript unsafe-    "$1['isDefaultPrevented']()"-    js_isDefaultPrevented :: SyntheticEvent -> Bool--foreign import javascript unsafe-    "$1['stopPropagation']()"-    js_stopPropagation :: SyntheticEvent -> IO ()--foreign import javascript unsafe-    "$1['isPropagationStopped']()"-    js_isPropagationStopped :: SyntheticEvent -> Bool---- | unsafe and non-IO to enable lazy parsing. See mkEventHandler-foreign import javascript unsafe "$1[$2]"-  js_unsafeProperty :: J.JSVal -> J.JSString -> J.JSVal---- | unsafe to enable lazy parsing. See mkEventHandler-foreign import javascript unsafe-    "$1['getModifierState']($2)"-    js_unsafeGetModifierState :: J.JSVal -> J.JSString -> J.JSVal--foreign import javascript unsafe-    "($1 instanceof MouseEvent)"-    js_isMouseEvent :: J.JSVal -> Bool--foreign import javascript unsafe-    "($1 instanceof KeyboardEvent)"-    js_isKeyboardEvent :: J.JSVal -> Bool--#else--js_isDOMEventTarget :: J.JSVal -> Bool-js_isDOMEventTarget _ = False--js_isDOMEvent :: J.JSVal -> Bool-js_isDOMEvent _ = False--js_isSyntheticEvent :: J.JSVal -> Bool-js_isSyntheticEvent _ = False--js_preventDefault :: SyntheticEvent -> IO ()-js_preventDefault _ = pure ()--js_isDefaultPrevented :: SyntheticEvent -> Bool-js_isDefaultPrevented _ = False--js_stopPropagation :: SyntheticEvent -> IO ()-js_stopPropagation _ = pure ()--js_isPropagationStopped :: SyntheticEvent -> Bool-js_isPropagationStopped _ = False---- | unsafe and non-IO to enable lazy parsing. See mkEventHandler-js_unsafeProperty :: J.JSVal -> J.JSString -> J.JSVal-js_unsafeProperty _ _ = J.nullRef---- | unsafe to enable lazy parsing. See mkEventHandler-js_unsafeGetModifierState :: J.JSVal -> J.JSString -> J.JSVal-js_unsafeGetModifierState _ _ = J.nullRef--js_isMouseEvent :: J.JSVal -> Bool-js_isMouseEvent _ = False--js_isKeyboardEvent :: J.JSVal -> Bool-js_isKeyboardEvent _ = False--#endif

@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Glazier.React.Event.HashChange+  ( HashChangeEvent(..)+  , toHashChangeEvent+  )+where++import Control.DeepSeq+import qualified GHC.Generics as G+import qualified GHCJS.Types as J+import Glazier.React.EventTarget.Internal+import Glazier.React.NativeEvent.Internal+import Glazier.React.Notice.Internal+import qualified JavaScript.Extras as JE++-- https://developer.mozilla.org/en-US/docs/Web/API/HashChangeEvent+data HashChangeEvent = HashChangeEvent+  { target :: EventTarget+  -- type is a reserved word, so prefix to eventType+  , eventType :: J.JSString+  , bubbles :: Bool+  , cancelable :: Bool+  , oldURL ::J.JSString+  , newURL :: J.JSString+  }+    deriving (G.Generic)+instance NFData HashChangeEvent++-- | We can lie about this not being in IO because+-- within the strict part of 'handleEventM'+-- the Notice is effectively immutable.+toHashChangeEvent :: NativeEvent -> Maybe HashChangeEvent+toHashChangeEvent nevt | js_isHashChangeEvent evt = Just $+    HashChangeEvent+    { target = EventTarget $ JE.JSRep $ unsafeGetProperty evt "target"+    , eventType = unsafeGetProperty evt "type"+    , bubbles = unsafeGetProperty evt "bubbles"+    , cancelable = unsafeGetProperty evt "cancelable"+    , oldURL = unsafeGetProperty evt "oldURL"+    , newURL = unsafeGetProperty evt "newURL"+    }+  where evt = JE.toJS nevt+toHashChangeEvent _ | otherwise = Nothing++#ifdef __GHCJS__++foreign import javascript unsafe+    "($1 instanceof HashChangeEvent)"+    js_isHashChangeEvent :: J.JSVal -> Bool++#else++js_isHashChangeEvent :: J.JSVal -> Bool+js_isHashChangeEvent _ = False++#endif

@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Glazier.React.Event.Keyboard+  ( KeyboardEvent(..)+  , toKeyboardEvent+  )+where++import Control.DeepSeq+import qualified GHC.Generics as G+import qualified GHCJS.Types as J+import Glazier.React.Notice.Internal+import qualified JavaScript.Extras as JE+import Prelude hiding (repeat)++-- | Keyboard events+-- 'KeyboardEvent' must only be used in the first part of 'handleEvent'.+-- https://facebook.github.io/react/docs/events.html#keyboard-events+-- https://developer.mozilla.org/en-US/docs/Web/API/KeyboardEvent+-- Event names (eventType)+-- onKeyDown (keydown) onKeyPress (keypress) onKeyUp (keyyp)+data KeyboardEvent = KeyboardEvent+  { altKey :: Bool+  , charCode ::Int+  , ctrlKey :: Bool+  , getModifierState :: J.JSString -> Bool+  , key :: J.JSString+  , keyCode :: Int+  , locale :: J.JSString+  , location ::Int+  , metaKey :: Bool+  , repeat :: Bool+  , shiftkey :: Bool+  , which :: Int+  }+    deriving (G.Generic)+instance NFData KeyboardEvent++-- | We can lie about this not being in IO because+-- within the strict part of 'handleEventM'+-- the Notice is effectively immutable.+toKeyboardEvent :: Notice -> Maybe KeyboardEvent+toKeyboardEvent (Notice (JE.JSRep evt)) | js_isKeyboardEvent (unsafeGetProperty evt "nativeEvent") = Just $+    KeyboardEvent+    { altKey = unsafeGetProperty evt "altKey"+    , charCode = unsafeGetProperty evt "charCode"+    , ctrlKey = unsafeGetProperty evt "ctrlKey"+    , getModifierState = unsafeGetModifierState evt+    , key = unsafeGetProperty evt "key"+    , keyCode = unsafeGetProperty evt "keyCode"+    , locale = unsafeGetProperty evt "locale"+    , location = unsafeGetProperty evt "location"+    , metaKey = unsafeGetProperty evt "metaKey"+    , repeat = unsafeGetProperty evt "repeat"+    , shiftkey = unsafeGetProperty evt "shiftkey"+    , which = unsafeGetProperty evt "which"+    }+toKeyboardEvent _ | otherwise = Nothing++#ifdef __GHCJS__++foreign import javascript unsafe+    "($1 instanceof KeyboardEvent)"+    js_isKeyboardEvent :: J.JSVal -> Bool++#else++js_isKeyboardEvent :: J.JSVal -> Bool+js_isKeyboardEvent _ = False++#endif

@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Glazier.React.Event.Mouse+  ( MouseEvent(..)+  , toMouseEvent+  )+where++import Control.DeepSeq+import qualified GHC.Generics as G+import qualified GHCJS.Types as J+import Glazier.React.EventTarget.Internal+import Glazier.React.Notice.Internal+import qualified JavaScript.Extras as JE++-- | Mouse and Drag/Drop events+-- 'MouseEvent' must only be used in the first part of 'handleEvent'.+-- https://facebook.github.io/react/docs/events.html#mouse-events+-- https://developer.mozilla.org/en-US/docs/Web/Events+-- Event names (eventType)+-- onClick (click) onContextMenu (contextmenu) onDoubleClick (dblclick)+-- onDrag (drag) onDragEnd (dragend) onDragEnter (dragenter) onDragExit (dragexit)+-- onDragLeave (dragleave) onDragOver (dragover) onDragStart (dragstart)+-- onDrop (drop) onMouseDown (mousedown) onMouseEnter (mouseenter) onMouseLeave (mouseleave)+-- onMouseMove (mousemove) onMouseOut (mouseout) onMouseOver (mouseover) onMouseUp (mouseup)+data MouseEvent = MouseEvent+  { altKey :: Bool+  , button :: Int+  , buttons :: Int+  , clientX :: Int+  , clientY :: Int+  , ctrlKey :: Bool+  , getModifierState :: J.JSString -> Bool+  , metaKey :: Bool+  , pageX :: Int+  , pageY :: Int+  , relatedTarget :: EventTarget+  , screenX :: Int+  , screenY :: Int+  , shiftKey :: Bool+  }+    deriving (G.Generic)+instance NFData MouseEvent++-- | We can lie about this not being in IO because+-- within the strict part of 'handleEventM'+-- the Notice is effectively immutable.+toMouseEvent :: Notice -> Maybe MouseEvent+toMouseEvent (Notice (JE.JSRep evt)) | js_isMouseEvent (unsafeGetProperty evt "nativeEvent") = Just $+    MouseEvent+    { altKey = unsafeGetProperty evt "altKey"+    , button = unsafeGetProperty evt "button"+    , buttons = unsafeGetProperty evt "buttons"+    , clientX = unsafeGetProperty evt "clientX"+    , clientY = unsafeGetProperty evt "clientY"+    , ctrlKey = unsafeGetProperty evt "ctrlKey"+    , getModifierState = unsafeGetModifierState evt+    , metaKey = unsafeGetProperty evt "metaKey"+    , pageX = unsafeGetProperty evt "pageX"+    , pageY = unsafeGetProperty evt "pageY"+    , relatedTarget = EventTarget $ JE.JSRep $ unsafeGetProperty evt "relatedTarget"+    , screenX = unsafeGetProperty evt "screenX"+    , screenY = unsafeGetProperty evt "xcreenY"+    , shiftKey = unsafeGetProperty evt "shiftKey"+    }+toMouseEvent _ | otherwise = Nothing++#ifdef __GHCJS__++foreign import javascript unsafe+    "($1 instanceof MouseEvent)"+    js_isMouseEvent :: J.JSVal -> Bool++#else++js_isMouseEvent :: J.JSVal -> Bool+js_isMouseEvent _ = False++#endif

@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module based on React/Flux/PropertiesAndEvents.hs.+module Glazier.React.Event.Synthetic+  ( SyntheticEvent(..)+  , toSyntheticEvent+  )+where++import Control.DeepSeq+import qualified GHC.Generics as G+import qualified GHCJS.Types as J+import Glazier.React.EventTarget.Internal+import Glazier.React.NativeEvent.Internal+import Glazier.React.Notice.Internal+import qualified JavaScript.Extras as JE++-- | Every `Notice` can be parsed to an `SyntheticEvent`.+-- 'SyntheticEvent' must only be used in the first part of 'handleEvent'.+data SyntheticEvent = SyntheticEvent+    { bubbles :: Bool+    , cancelable :: Bool+    , currentTarget :: EventTarget+    , defaultPrevented :: Bool+    , eventPhase :: Int+    , isTrusted :: Bool+    , nativeEvent :: NativeEvent+    , target :: EventTarget+    , timeStamp :: Int+    -- type is a reserved word, so prefix to eventType+    , eventType :: J.JSString+    }+    deriving (G.Generic)+instance NFData SyntheticEvent++-- | We can lie about this not being in IO because+-- within the strict part of 'handleEventM'+-- the Notice is effectively immutable.+toSyntheticEvent :: Notice -> SyntheticEvent+toSyntheticEvent (Notice (JE.JSRep evt)) =+    SyntheticEvent+    { bubbles = unsafeGetProperty evt "bubbles"+    , cancelable = unsafeGetProperty evt "cancelable"+    , currentTarget = EventTarget $ JE.JSRep $ unsafeGetProperty evt "currentTarget"+    , defaultPrevented = unsafeGetProperty evt "defaultPrevented"+    , eventPhase = unsafeGetProperty evt "eventPhase"+    , isTrusted = unsafeGetProperty evt "isTrusted"+    , nativeEvent = NativeEvent $ JE.JSRep $ evt+    , target = EventTarget $ JE.JSRep $ unsafeGetProperty evt "target"+    , timeStamp = unsafeGetProperty evt "timeStamp"+    , eventType = unsafeGetProperty evt "type"+    }+

@@ -0,0 +1,8 @@+-- | This module based on React/Flux/PropertiesAndEvents.hs.+module Glazier.React.EventTarget+    ( EventTarget  -- constructor is not exported+    )+    where++import Glazier.React.EventTarget.Internal+

@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | This module based on React/Flux/PropertiesAndEvents.hs.+module Glazier.React.EventTarget.Internal+  ( EventTarget(..)+  )+where++import Control.DeepSeq+import Data.String+import qualified GHC.Generics as G+import qualified GHCJS.Marshal.Pure as J+import qualified GHCJS.Types as J+import qualified JavaScript.Extras as JE++-- | The object that dispatched the event.+-- https://developer.mozilla.org/en-US/docs/Web/API/Event/target+newtype EventTarget =+    EventTarget JE.JSRep -- not J.JSVal so the show instance is more useful+    deriving (G.Generic, Show, J.IsJSVal, J.PToJSVal, JE.ToJS, IsString, NFData)++instance JE.FromJS EventTarget where+    fromJS a | js_isEventTarget a = Just $ EventTarget $ JE.JSRep a+    fromJS _ = Nothing++#ifdef __GHCJS__++foreign import javascript unsafe+    "$1 instanceof EventTarget"+    js_isEventTarget :: J.JSVal -> Bool++#else++js_isEventTarget :: J.JSVal -> Bool+js_isEventTarget _ = False++#endif

@@ -0,0 +1,34 @@+-- {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module Glazier.React.Gadget where++import Control.Monad.Trans.Cont+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified Data.DList as DL+import Glazier.React.Entity+import Glazier.React.Subject++-- | The @s@ state can be magnified with 'magnifiedEntity'+type Gadget cmd p s = ReaderT (Entity p s) (ContT () (State (DL.DList cmd)))++toGadget ::+    (Entity p s+        -> (a -> State (DL.DList cmd) ())+        -> State (DL.DList cmd) ())+    -> Gadget cmd p s a+toGadget f = ReaderT (\r -> ContT (f r))++runGadget ::+    Gadget cmd p s a+    -> Entity p s+    -> (a -> State (DL.DList cmd) ())+    -> State (DL.DList cmd) ()+runGadget x l = runContT (runReaderT x l)++gadgetWith :: Subject s -> Gadget cmd s s a -> ContT () (State (DL.DList cmd)) a+gadgetWith sbj = (`runReaderT` (Entity sbj id))++evalGadget :: Gadget cmd p s () -> Entity p s -> State (DL.DList cmd) ()+evalGadget gad ent = evalContT . (`runReaderT` ent) $ gad

@@ -1,69 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}--module Glazier.React.Maker where--import Control.Monad.Free.Class-import Control.Monad.Free.Church-import Control.Monad.Free.TH-import Control.Monad.Trans.Maybe-import qualified GHCJS.Foreign.Callback as J-import qualified GHCJS.Types as J-import qualified Glazier as G-import qualified Glazier.React.Component as R-import qualified Glazier.React.Markup as R-import qualified Glazier.React.Model as R---- | DSL for IO effects required during making widget models and callbacks--- 'Maker' remembers the action type to allow 'mapAction' for changing the action type by parent widgets.--- The model type does not need to be changed, so it is hidden in the GADT existential.-data Maker act nxt where-    MkHandler-        :: (J.JSVal -> MaybeT IO [act])-        -> (J.Callback (J.JSVal -> IO ()) -> nxt)-        -> Maker act nxt-    MkEmptyFrame-        :: (R.Frame mdl pln -> nxt)-        -> Maker act nxt-    MkRenderer-        :: R.Frame mdl pln-        -> (J.JSVal -> G.WindowT (R.Scene mdl pln) R.ReactMl ())-        -> (J.Callback (J.JSVal -> IO J.JSVal) -> nxt)-        -> Maker act nxt-    PutFrame-        :: R.Frame mdl pln-        -> R.Scene mdl pln-        -> nxt-        -> Maker act nxt-    GetComponent-        :: (R.ReactComponent -> nxt)-        -> Maker act nxt-    MkKey-        :: (J.JSString -> nxt)-        -> Maker act nxt--instance Functor (Maker act) where-  fmap f (MkHandler handler g) = MkHandler handler (f . g)-  fmap f (MkEmptyFrame g) = MkEmptyFrame (f . g)-  fmap f (MkRenderer frm render g) = MkRenderer frm render (f . g)-  fmap f (PutFrame frm scn x) = PutFrame frm scn (f x)-  fmap f (GetComponent g) = GetComponent (f . g)-  fmap f (MkKey g) = MkKey (f . g)--makeFree ''Maker---- | Allows changing the action type of Maker-withAction :: (act -> act') -> Maker act a -> Maker act' a-withAction f (MkHandler handler g) = MkHandler (\v -> fmap f <$> handler v) g-withAction _ (MkEmptyFrame g) = MkEmptyFrame g-withAction _ (MkRenderer frm render g) = MkRenderer frm render g-withAction _ (PutFrame frm scn x) = PutFrame frm scn x-withAction _ (GetComponent g) = GetComponent g-withAction _ (MkKey g) = MkKey g--hoistWithAction :: (act -> act') -> F (Maker act) a -> F (Maker act') a-hoistWithAction f = hoistF (withAction f)

@@ -1,54 +0,0 @@-module Glazier.React.Maker.Run where--import Control.Concurrent.MVar-import Control.Concurrent.STM-import Control.Monad-import Control.Monad.Morph-import Control.Monad.Trans.Maybe-import Data.Foldable-import qualified Data.JSString as JS-import qualified GHCJS.Foreign.Callback as J-import qualified GHCJS.Types as J-import qualified Glazier as G-import qualified Glazier.React.Component as R-import Glazier.React.Maker as R-import qualified Glazier.React.Markup as R-import JavaScript.Extras as JE-import qualified Pipes.Concurrent as PC---- | This is called synchronously by React to render the DOM.--- This must not block!-onRender :: MVar s -> (J.JSVal -> G.WindowT s (R.ReactMlT IO) ()) -> J.JSVal -> IO J.JSVal-onRender mm wind v = do-    mdl <- readMVar mm-    JE.toJS <$> R.markedElement (wind v) mdl--mkActionCallback-    :: PC.Output act-    -> (J.JSVal -> MaybeT IO [act])-    -> IO (J.Callback (J.JSVal -> IO ()))-mkActionCallback output handler =-    J.syncCallback1 J.ContinueAsync $ \evt ->-        void $ runMaybeT $ do-            acts <- handler evt-            traverse_ (\act -> lift $ atomically $ PC.send output act >>= guard) acts--run :: MVar Int -> R.ReactComponent -> PC.Output act -> R.Maker act (IO a) -> IO a-run _ _ output (R.MkHandler handler g) = mkActionCallback output handler >>= g--run _ _ _ (R.MkEmptyFrame g) = newEmptyMVar >>= g--run _ _ _ (R.MkRenderer frm render g) = J.syncCallback1' (onRender frm render') >>= g-  where-    render' v = hoist (hoist generalize) (render v)--run _ _ _ (R.PutFrame frm scn g) = putMVar frm scn >> g--run _ component _ (R.GetComponent g) = g component--run muid _ _ (R.MkKey g) = do-    -- expects that muid is not empty!-    uid <- readMVar muid-    let uid' = (uid `mod` JE.maxSafeInteger) + 1-    void $ swapMVar muid uid'-    g (JS.pack . show $ uid')

@@ -1,9 +1,8 @@-{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}  -- | 'Lucid.HtmlT' inspired monad for creating 'ReactElement's@@ -12,122 +11,148 @@     , BranchParam(..)     , LeafParam(..)     , fromMarkup-    , ReactMlT(..)-    , ReactMl     , fromElement     , toElements-    , markedWindow-    , markedElements-    , markedElement+    , toElement     , txt     , lf     , bh+    , withMarkup+    , modifyMarkup+    , overSurfaceProperties+    , overAllProperties     ) where -import Control.Applicative-import Control.Lens-import qualified Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.Morph-import Control.Monad.Reader import Control.Monad.State.Strict-import qualified Data.DList as D-import Data.Semigroup+import qualified Data.DList as DL import qualified GHCJS.Types as J-import qualified Glazier as G-import qualified Glazier.React.Element as R+import qualified Glazier.React.Element as Z import qualified JavaScript.Extras as JE  -- | The parameters required to create a branch ReactElement with children data BranchParam = BranchParam-    JE.JSVar-    [JE.Property]-    (D.DList ReactMarkup)+    JE.JSRep+    (DL.DList JE.Property)+    (DL.DList ReactMarkup)  -- | The parameters required to create a leaf ReactElement (no children) data LeafParam = LeafParam-    JE.JSVar-    [JE.Property]+    JE.JSRep+    (DL.DList JE.Property)  data ReactMarkup-    = ElementMarkup R.ReactElement+    = ElementMarkup Z.ReactElement     | TextMarkup J.JSString     | BranchMarkup BranchParam     | LeafMarkup LeafParam --- | Create 'ReactElement's from a 'AtomMarkup'-fromMarkup :: ReactMarkup -> IO (R.ReactElement)-fromMarkup (BranchMarkup (BranchParam n p xs)) = do-    xs' <- sequenceA $ fromMarkup <$> (D.toList xs)-    R.mkBranchElement n p xs'+-- | Create 'ReactElement's from a 'ReactMarkup'+fromMarkup :: ReactMarkup -> IO Z.ReactElement+fromMarkup (BranchMarkup (BranchParam n props xs)) = do+    xs' <- sequenceA $ fromMarkup <$> (DL.toList xs)+    Z.mkBranchElement n (DL.toList props) xs' -fromMarkup (LeafMarkup (LeafParam n p)) = R.mkLeafElement n p+fromMarkup (LeafMarkup (LeafParam n props)) =+    Z.mkLeafElement n (DL.toList props) -fromMarkup (TextMarkup str) = pure $ R.textElement str+fromMarkup (TextMarkup str) = pure $ Z.textElement str  fromMarkup (ElementMarkup e) = pure e --- | Monadic generator of ReactActom.--- It is a CPS-style WriterT (ie a StateT) to build up a function--- build up a computations to generate a '[AtomMarkup]'.--- You can use 'runStateT' with an initial state of 'mempty'.-newtype ReactMlT m a = ReactMlT-    { runReactMlT :: StateT (D.DList ReactMarkup) m a-    } deriving ( MonadState (D.DList ReactMarkup)-               , Monad-               , Applicative-               , Functor-               , Fail.MonadFail-               , Alternative-               , MonadPlus-               , MonadFix-               , MonadIO-               , MFunctor-               )+------------------------------------------------- -type ReactMl = ReactMlT Identity+-- | To use an exisitng ReactElement+fromElement :: MonadState (DL.DList ReactMarkup) m => Z.ReactElement -> m ()+fromElement e = modify' (`DL.snoc` ElementMarkup e) --- makeWrapped ''ReactMlT+-- | Convert the ReactMlt to [Z.ReactElement]+toElements :: DL.DList ReactMarkup -> IO [Z.ReactElement]+toElements xs = sequenceA $ fromMarkup <$> DL.toList xs -instance (Semigroup a, Monad m) => Semigroup (ReactMlT m a) where-    (<>) = liftA2 (<>)+-- | Fully render the ReactMlt into a single Z.ReactElement+toElement :: DL.DList ReactMarkup -> IO Z.ReactElement+toElement xs = toElements xs >>= Z.mkCombinedElements -instance (Monoid a, Monad m) => Monoid (ReactMlT m a) where-    mempty = pure mempty-    mappend = liftA2 mappend+-- -- | toElements reading an s from the environment+-- toElements' :: MonadIO io => (s -> ReactMlT io ()) -> s -> io [Z.ReactElement]+-- toElements' f = (toElements . f) --- | To use an exisitng ReactElement-fromElement :: Applicative m => R.ReactElement -> ReactMlT m ()-fromElement e = ReactMlT . StateT $ \xs -> pure ((), xs `D.snoc` ElementMarkup e)+------------------------------------------------- --- | Convert the ReactMlt to [R.ReactElement]-toElements :: MonadIO io => ReactMlT io () -> io [R.ReactElement]-toElements m = do-    xs <- execStateT (runReactMlT m) mempty-    liftIO $ sequenceA $ fromMarkup <$> (D.toList xs)+-- | For text content+txt :: MonadState (DL.DList ReactMarkup) m => J.JSString -> m ()+txt n = modify' (`DL.snoc` TextMarkup n) --- | Render the ReactMlt under a Glazier window-markedWindow :: MonadIO io => G.WindowT s (ReactMlT io) () -> G.WindowT s io [R.ReactElement]-markedWindow = G.belowWindowT (toElements .)+-- | For the contentless elements: eg 'br_'.+-- Memonic: lf for leaf.+-- Duplicate listeners with the same key will be combined, but it is a silent error+-- if the same key is used across listeners and props.+-- "If an attribute/prop is duplicated the last one defined wins."+-- https://www.reactenlightenment.com/react-nodes/4.4.html+lf :: (MonadState (DL.DList ReactMarkup) m)+    => JE.JSRep+    -> (DL.DList JE.Property)+    -> m ()+lf n props = modify' (`DL.snoc` LeafMarkup (LeafParam n props)) --- | Fully render the ReactMlt into a [R.ReactElement]-markedElements :: MonadIO io => G.WindowT s (ReactMlT io) () -> s -> io [R.ReactElement]-markedElements w s = view G._WindowT' (markedWindow w) s+-- | Create a MonadState that run the given given a combining function+-- where the first arg is the state from running the markup producing MonadState with mempty,+-- and the 2nd arg the starting state of the resultant MonadState.+withMarkup :: MonadState (DL.DList ReactMarkup) m+    => (DL.DList ReactMarkup -> DL.DList ReactMarkup -> DL.DList ReactMarkup)+    -> m a+    -> m a+withMarkup f childs = do+    -- save state+    s <- get+    -- run children with mempty+    put mempty+    a <- childs+    childs' <- get+    -- restore state+    put s+    modify' (f childs')+    pure a --- | Fully render the ReactMlt into a R.ReactElement-markedElement :: MonadIO io => G.WindowT s (ReactMlT io) () -> s -> io R.ReactElement-markedElement w s = markedElements w s >>= liftIO . R.mkCombinedElements+-- | For the contentful elements: eg 'div_'.+-- Memonic: bh for branch.+-- Duplicate listeners with the same key will be combined, but it is a silent error+-- if the same key is used across listeners and props.+-- "If an attribute/prop is duplicated the last one defined wins."+-- https://www.reactenlightenment.com/react-nodes/4.4.html+bh :: (MonadState (DL.DList ReactMarkup) m)+    => JE.JSRep+    -> (DL.DList JE.Property)+    -> m a+    -> m a+bh n props = withMarkup (\childs' ms -> ms `DL.snoc` BranchMarkup (BranchParam n props childs')) --- | For text content-txt :: Applicative m => J.JSString -> ReactMlT m ()-txt n = ReactMlT . StateT $ \xs -> pure ((), xs `D.snoc` TextMarkup n)+-- Given a mapping function, apply it to children of the markup+modifyMarkup :: MonadState (DL.DList ReactMarkup) m+    => (DL.DList ReactMarkup -> DL.DList ReactMarkup)+    -> m a -> m a+modifyMarkup f = withMarkup (\childs' ms -> ms `DL.append` f childs') --- | For the contentless elements: eg 'br_'-lf :: Applicative m => JE.JSVar -> [JE.Property] -> ReactMlT m ()-lf n props = ReactMlT . StateT $ \xs -> pure ((), xs `D.snoc` LeafMarkup (LeafParam n props))+-- Given a mapping function, apply it to all child BranchMarkup or LeafMarkup (if possible)+-- Does not recurse into decendants.+overSurfaceProperties ::+    (DL.DList JE.Property -> DL.DList JE.Property)+    -> (DL.DList ReactMarkup -> DL.DList ReactMarkup)+overSurfaceProperties f childs = DL.fromList $ case DL.toList childs of+    LeafMarkup (LeafParam j ps) : bs ->+        LeafMarkup (LeafParam j (f ps)) : bs+    BranchMarkup (BranchParam j ps as) : bs ->+        BranchMarkup (BranchParam j (f ps) as) : bs+    bs -> bs --- | For the contentful elements: eg 'div_'-bh :: Functor m => JE.JSVar -> [JE.Property] -> ReactMlT m a -> ReactMlT m a-bh n props (ReactMlT (StateT childs)) = ReactMlT . StateT $ \xs -> do-    (a, childs') <- childs mempty-    pure (a, xs `D.snoc` BranchMarkup (BranchParam n props childs'))+-- Given a mapping function, apply it to all child BranchMarkup or LeafMarkup (if possible)+-- Recurse into decendants.+overAllProperties ::+    (DL.DList JE.Property -> DL.DList JE.Property)+    -> (DL.DList ReactMarkup -> DL.DList ReactMarkup)+overAllProperties f childs = DL.fromList $ case DL.toList childs of+    LeafMarkup (LeafParam j ps) : bs ->+        LeafMarkup (LeafParam j (f ps)) : bs+    BranchMarkup (BranchParam j ps as) : bs ->+        BranchMarkup (BranchParam j (f ps) (overAllProperties f as)) : bs+    bs -> bs

@@ -1,105 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Glazier.React.Model where--import Control.Concurrent.MVar-import qualified Control.Disposable as CD-import Control.Lens-import qualified GHC.Generics as G---- | Lens to the callbacks and interactions with React-class HasPlan c pln | c -> pln where-    plan :: Lens' c pln---- | Lens to the pure model for state and rendering.-class HasModel c mdl | c -> mdl where-    model :: Lens' c mdl---- | Convert to the pure serializable model for saving and restoring-class ToOutline c o | c -> o where-    outline :: c -> o---- | A record of Model and Plan-data Scene mdl pln = Scene-    { _model :: mdl-    , _plan :: pln-    } deriving (G.Generic)--class HasScene c mdl pln | c -> mdl pln where-    scene :: Lens' c (Scene mdl pln)--instance HasScene (Scene mdl pln) mdl pln where-    scene = id-    {-# INLINE scene #-}---- | All scenes should be disposable to make it easier for cleanup of callbacks.-instance (CD.Disposing pln, CD.Disposing mdl) => CD.Disposing (Scene mdl pln)--instance HasPlan (Scene mdl pln) pln where-    plan f (Scene mdl pln) = fmap (\pln' -> Scene mdl pln') (f pln)-    {-# INLINE plan #-}--instance HasModel (Scene mdl pln) mdl where-    model f (Scene mdl pln) = fmap (\mdl' -> Scene mdl' pln) (f mdl)-    {-# INLINE model #-}---- | A Scene can be converted to Outline by using the Model-instance ToOutline mdl ol => ToOutline (Scene mdl pln) ol where-    outline = view (model . to outline)-    {-# INLINE outline #-}---- | Frame is a Mvar of Scene. React rendering callback uses this MVar for rendering.-type Frame mdl pln = MVar (Scene mdl pln)--class HasFrame c mdl pln | c -> mdl pln where-    frame :: Lens' c (Frame mdl pln)--instance HasFrame (Frame mdl pln) mdl pln where-    frame = id-    {-# INLINE frame #-}---- | A record of Scene and Frame.-data Gizmo mdl pln = Gizmo-    { _scene :: Scene mdl pln-    , _frame :: Frame mdl pln-    } deriving (G.Generic)---- | Undecidableinstances!--- But this is safe because Scene is definitely smaller than Gizmo-instance CD.Disposing (Scene mdl pln) => CD.Disposing (Gizmo mdl pln) where-    disposing s = CD.disposing $ s ^. scene-    {-# INLINE disposing #-}--class (HasScene c mdl pln, HasFrame c mdl pln) => HasGizmo c mdl pln | c -> mdl pln where-    gizmo :: Lens' c (Gizmo mdl pln)--instance HasGizmo (Gizmo mdl pln) mdl pln where-    gizmo = id-    {-# INLINE gizmo #-}--instance HasFrame (Gizmo mdl pln) mdl pln where-    frame f (Gizmo scn frm) = fmap (\frm' -> Gizmo scn frm') (f frm)-    {-# INLINE frame #-}--instance HasScene (Gizmo mdl pln) mdl pln where-    scene f (Gizmo scn frm) = fmap (\scn' -> Gizmo scn' frm) (f scn)-    {-# INLINE scene #-}--instance HasPlan (Gizmo mdl pln) pln where-    plan = scene . plan-    {-# INLINE plan #-}--instance HasModel (Gizmo mdl pln) mdl where-    model = scene . model-    {-# INLINE model #-}---- | A Gizmo can be converted to Outline by using the Model-instance ToOutline mdl o => ToOutline (Gizmo mdl pln) o where-    outline = view (model . to outline)-    {-# INLINE outline #-}

@@ -0,0 +1,7 @@+-- | This module based on React/Flux/PropertiesAndEvents.hs.+module Glazier.React.NativeEvent+    ( NativeEvent  -- constructor is not exported+    )+    where++import Glazier.React.NativeEvent.Internal

@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | This module based on React/Flux/PropertiesAndEvents.hs.+module Glazier.React.NativeEvent.Internal+  ( NativeEvent(..)+  , )+where++import Control.DeepSeq+import Data.String+import qualified GHC.Generics as G+import qualified GHCJS.Marshal.Pure as J+import qualified GHCJS.Types as J+import qualified JavaScript.Extras as JE++-- | The native event+-- https://developer.mozilla.org/en-US/docs/Web/API/Event+newtype NativeEvent =+    NativeEvent JE.JSRep -- not J.JSVal so the show instance is more useful+    deriving (G.Generic, Show, J.IsJSVal, J.PToJSVal, JE.ToJS, IsString, NFData)++instance JE.FromJS NativeEvent where+    fromJS a | js_isNativeEvent a = Just $ NativeEvent $ JE.JSRep a+    fromJS _ = Nothing++#ifdef __GHCJS__++foreign import javascript unsafe+    "$1 instanceof Event"+    js_isNativeEvent :: J.JSVal -> Bool++#else++js_isNativeEvent :: J.JSVal -> Bool+js_isNativeEvent _ = False++#endif

@@ -0,0 +1,10 @@+module Glazier.React.Notice+    ( Notice  -- constructor is not exported+    , preventDefault+    , isDefaultPrevented+    , stopPropagation+    , isPropagationStopped+    )+    where++import Glazier.React.Notice.Internal

@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Glazier.React.Notice.Internal+  ( Notice(..)  -- constructor is exported+  , preventDefault+  , isDefaultPrevented+  , stopPropagation+  , isPropagationStopped+  , unsafeGetProperty+  , unsafeGetModifierState+  )+where++import qualified GHC.Generics as G+import qualified GHCJS.Foreign as J+import qualified GHCJS.Marshal.Pure as J+import qualified GHCJS.Types as J+import qualified JavaScript.Extras as JE++-- | Every event in React is a synthetic event, a cross-browser wrapper around the native event.+-- which reused from a pool.+-- So it is dangerous to keep a reference to a 'Notice' since it may expire and contain+-- other things without you knowing.+-- All relevant data from the 'Notice' must be consumed as soon you get one.+-- That is, 'Notice' must only be used in the first part of 'handleEvent'.+-- It is not an instance of NFData and so cannot be returned into the second lazy part of 'handleEvent'+newtype Notice = Notice JE.JSRep -- not J.JSVal so the show instance is more useful+    deriving (G.Generic, Show)++instance JE.FromJS Notice where+    fromJS a | js_isNotice a = Just $ Notice $ JE.JSRep a+    fromJS _ = Nothing++preventDefault :: Notice -> IO ()+preventDefault = js_preventDefault++isDefaultPrevented :: Notice -> Bool+isDefaultPrevented = js_isDefaultPrevented++stopPropagation :: Notice -> IO ()+stopPropagation = js_stopPropagation++isPropagationStopped :: Notice -> Bool+isPropagationStopped = js_isPropagationStopped++-- | Within the strict part of 'handleEventM'+-- the Notice is effectively immutable.+-- We want to maintain this lie so that we can lazily parse only the+-- properties the event handler is interested in.+-- This will throw if J.JSVal is null, or not convertible to the desired type+-- so we are assuming that Notice will behave nicely.+unsafeGetProperty :: J.PFromJSVal a => J.JSVal -> J.JSString -> a+unsafeGetProperty v = J.pFromJSVal . js_unsafeGetProperty v++-- | See https://www.w3.org/TR/DOM-Level-3-Events-key/#keys-modifier+-- This will throw if J.JSVal is null, but shouldn't happen since we've+-- already check for a valid Notice+unsafeGetModifierState :: J.JSVal -> J.JSString -> Bool+unsafeGetModifierState obj k = J.fromJSBool $ js_unsafeGetModifierState obj k++#ifdef __GHCJS__++foreign import javascript unsafe+    "$1 && $1['nativeEvent'] && $1['nativeEvent'] instanceof Event"+    js_isNotice :: J.JSVal -> Bool++foreign import javascript unsafe+    "$1['preventDefault']()"+    js_preventDefault :: Notice -> IO ()++foreign import javascript unsafe+    "$1['isDefaultPrevented']()"+    js_isDefaultPrevented :: Notice -> Bool++foreign import javascript unsafe+    "$1['stopPropagation']()"+    js_stopPropagation :: Notice -> IO ()++foreign import javascript unsafe+    "$1['isPropagationStopped']()"+    js_isPropagationStopped :: Notice -> Bool++-- | unsafe and non-IO to enable lazy parsing. See handleEvent+foreign import javascript unsafe "$1[$2]"+  js_unsafeGetProperty :: J.JSVal -> J.JSString -> J.JSVal++-- | unsafe to enable lazy parsing. See handleEvent+foreign import javascript unsafe+    "$1['getModifierState']($2)"+    js_unsafeGetModifierState :: J.JSVal -> J.JSString -> J.JSVal++#else++js_isNotice :: J.JSVal -> Bool+js_isNotice _ = False++js_preventDefault :: Notice -> IO ()+js_preventDefault _ = pure ()++js_isDefaultPrevented :: Notice -> Bool+js_isDefaultPrevented _ = False++js_stopPropagation :: Notice -> IO ()+js_stopPropagation _ = pure ()++js_isPropagationStopped :: Notice -> Bool+js_isPropagationStopped _ = False++-- | unsafe and non-IO to enable lazy parsing. See handleEvent+js_unsafeGetProperty :: J.JSVal -> J.JSString -> J.JSVal+js_unsafeGetProperty _ _ = J.nullRef++-- | unsafe to enable lazy parsing. See handleEvent+js_unsafeGetModifierState :: J.JSVal -> J.JSString -> J.JSVal+js_unsafeGetModifierState _ _ = J.nullRef++#endif

@@ -2,25 +2,26 @@  -- | Contains commons utilities when defining your own widget module Glazier.React.ReactDOM-  ( render+  ( renderDOM   ) where -import qualified GHCJS.Types as J+import qualified Glazier.React.Element as Z+import qualified JavaScript.Extras as JE  -- | Using a React Element (first arg) give React rendering control over a DOM element (second arg). -- This should only be called for the topmost component.-render :: J.JSVal -> J.JSVal -> IO ()-render = js_render+renderDOM :: Z.ReactElement -> JE.JSRep -> IO ()+renderDOM = js_render  #ifdef __GHCJS__  foreign import javascript unsafe-  "ReactDOM.render($1, $2);"-  js_render :: J.JSVal -> J.JSVal -> IO ()+  "hgr$ReactDOM().render($1, $2);"+  js_render :: Z.ReactElement-> JE.JSRep -> IO ()  #else -js_render :: J.JSVal -> J.JSVal -> IO ()+js_render :: Z.ReactElement -> JE.JSRep -> IO () js_render _ _ = pure ()  #endif

@@ -0,0 +1,6 @@+module Glazier.React.ReactId+    ( ReactId -- constructor not exported+    )+    where++import Glazier.React.ReactId.Internal

@@ -0,0 +1,28 @@+-- {-# LANGUAGE ConstraintKinds #-}+-- {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Glazier.React.ReactId.Internal where++import qualified Data.JSString as J+import qualified GHCJS.Marshal.Pure as J+import qualified GHCJS.Types as J+import qualified JavaScript.Extras as JE++import Data.String++-- type MkId m = MonadState Int m++-- mkId :: MonadState Int m => J.JSString -> m J.JSString+-- mkId n = do+--     i <- get+--     let i' = JE.safeIncrement i+--     put i'+--     pure . J.append n . J.cons ':' . J.pack $ show i'++-- This id can also be used as the react @key@+newtype ReactId = ReactId { unReactId :: J.JSString }+    deriving (Read, Show, Eq, Ord, JE.ToJS, IsString, J.IsJSVal, J.PToJSVal)++-- mkElementalId :: MonadState Int m => J.JSString -> m ElementalId+-- mkElementalId n = ElementalId <$> mkId n

@@ -0,0 +1,375 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Glazier.React.Reactor+    ( AsReactor+    , MonadReactor+    , ReactorCmd(..)+    , ModelState+    , mkReactId+    , setRender+    , mkSubject+    , mkSubject'+    , withMkSubject+    , bookSubjectCleanup+    , getModel+    , getElementalRef+    , rerender+    , tickModel+    , tickModelThen+    , domTrigger+    , domTrigger_+    , trigger+    , trigger_+    , onMounted+    , onRendered+    , onNextRendered+    , onTicked+    ) where++import Control.Also+import Control.DeepSeq+import Control.Lens+import Control.Monad.Delegate+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Trans.Maybe+import Data.Diverse.Lens+import qualified GHCJS.Types as J+import Glazier.Command+import Glazier.React.Entity+import Glazier.React.EventTarget+import Glazier.React.Notice+import Glazier.React.ReactId+import Glazier.React.ReadIORef+import Glazier.React.Subject+import Glazier.React.Widget+import Glazier.React.Window+import qualified JavaScript.Extras as JE+-----------------------------------------------------------------++type AsReactor cmd =+    ( AsFacet [cmd] cmd -- implicity required by 'MonadCodify'+    , AsFacet (ReactorCmd cmd) cmd+    )++type MonadReactor p s cmd m =+    ( AsReactor cmd+    , MonadReader (Entity p s) m+    , MonadCommand cmd m+    )++type ModelState s = StateT s ReadIORef++-- | NB. 'ReactorCmd' is not a functor because of the @Widget cmd@ in 'MkSubject'+data ReactorCmd cmd where+    -- | Make a unique named id+    MkReactId :: J.JSString -> (ReactId -> cmd) -> ReactorCmd cmd+    -- | the the rendering function in a Subject, replace any existing render callback+    SetRender :: Subject s -> Window s () -> ReactorCmd cmd+    -- | Make a fully initialized subject (with ShimCallbacks) from a widget spec and state+    MkSubject :: Widget cmd s s () -> s -> (Subject s -> cmd) -> ReactorCmd cmd+    -- | Keep subject alive until the next rerender+    BookSubjectCleanup :: Subject s -> ReactorCmd cmd+    -- | Generate a list of commands from reading the model.+    GetModel :: Subject s -> (s -> cmd) -> ReactorCmd cmd+    -- Get the event target+    -- If a "ref" callback to update 'elementalRef' has not been added;+    -- then add it, rerender, then return the EventTarget.+    GetElementalRef ::+        Subject s+        -> ReactId+        -> (EventTarget -> cmd)+        -> ReactorCmd cmd+    -- | Rerender a ShimComponent using the given state.+    Rerender :: Subject s -> ReactorCmd cmd+    -- | Update and rerender.+    TickModel :: Subject s -> ModelState s cmd -> ReactorCmd cmd+    -- | Create and register a dom callback+    RegisterDOMListener :: NFData a+        => Subject s+        -> JE.JSRep+        -> J.JSString+        -> (JE.JSRep -> MaybeT IO a)+        -> (a -> cmd)+        -> ReactorCmd cmd+    -- | Create and register a react callback+    -- If the callback is for "ref", then an listener to update 'elementalRef' for 'GetEventTarget'+    -- will automatically be added just before the listener in 'RegisterReactListener'.+    RegisterReactListener :: NFData a+        => Subject s+        -> ReactId+        -> J.JSString+        -> (JE.JSRep -> MaybeT IO a)+        -> (a -> cmd)+        -> ReactorCmd cmd+    -- | Create and register a callback for the mounted event+    RegisterMountedListener ::+        Subject s+        -> cmd+        -> ReactorCmd cmd+    -- | Create and register a callback for the rendered event+    RegisterRenderedListener ::+        Subject s+        -> cmd+        -> ReactorCmd cmd+    -- | Create and register a callback for the rendered event+    RegisterNextRenderedListener ::+        Subject s+        -> cmd+        -> ReactorCmd cmd+    -- | Create and register a callback for the state updated event+    RegisterTickedListener ::+        Subject s+        -> cmd+        -> ReactorCmd cmd++instance Show (ReactorCmd cmd) where+    showsPrec p (MkReactId s _) = showParen (p >= 11) $+        showString "MkReactId " . shows s+    showsPrec _ (SetRender _ _ ) = showString "SetRender"+    showsPrec _ (MkSubject _ _ _) = showString "MkSubject"+    showsPrec _ (BookSubjectCleanup _) = showString "BookSubjectCleanup"+    showsPrec _ (GetModel _ _) = showString "GetModel"+    showsPrec _ (GetElementalRef _ _ _) = showString "GetElementalRef"+    showsPrec _ (Rerender _) = showString "Rerender"+    showsPrec _ (TickModel _ _) = showString "TickModel"+    showsPrec _ (RegisterDOMListener _ _ _ _ _) = showString "RegisterDOMListener"+    showsPrec _ (RegisterReactListener _ _ _ _ _) = showString "RegisterReactListener"+    showsPrec _ (RegisterMountedListener _ _) = showString "RegisterMountedListener"+    showsPrec _ (RegisterRenderedListener _ _) = showString "RegisterRenderedListener"+    showsPrec _ (RegisterNextRenderedListener _ _) = showString "RegisterNextRenderedListener"+    showsPrec _ (RegisterTickedListener _ _) = showString "RegisterTickedListener"++------------------------------------------------------+-- | Make a unique named id+mkReactId :: (AsReactor cmd, MonadCommand cmd m)+    => J.JSString -> m ReactId+mkReactId n = delegate $ \fire -> do+    f <- codify fire+    exec' $ MkReactId n f++setRender :: (AsReactor cmd, MonadCommand cmd m)+    => Subject s -> Window s () -> m ()+setRender sbj win = exec' $ SetRender sbj win++-- | Make an initialized 'Subject' for a given model using the given 'Widget'.+mkSubject :: (AsReactor cmd, MonadCommand cmd m)+    => Widget cmd s s a -> s -> m (Either a (Subject s))+mkSubject wid s = delegate $ \fire -> do+    f <- codify fire+    let wid' = wid >>= (instruct . f . Left)+    exec' $ MkSubject wid' s (f . Right)++-- | Make an initialized 'Subject' for a given model using the given 'Widget'.+mkSubject' :: (AsReactor cmd, MonadCommand cmd m)+    => Widget cmd s s () -> s -> m (Subject s)+mkSubject' gad s = delegate $ \fire -> do+    f <- codify fire+    exec' $ MkSubject gad s f++-- | Make an initialized 'Subject' for a given model using the given 'Widget'.+withMkSubject :: (AsReactor cmd, MonadCommand cmd m)+    => Widget cmd s s a -> s -> (Subject s -> m ()) -> m a+withMkSubject wid s k = delegate $ \fire -> do+    f <- codify fire+    k' <- codify k+    let wid' = wid >>= (instruct . f)+    exec' $ MkSubject wid' s k'++-- -- | Add a constructed subject to a parent widget+-- addSubject :: (MonadReactor p ss cmd m)+--     => Widget cmd s s a+--     -> s+--     -> (Subject s -> StateT (Scene ss) ReadIORef ())+--     -> m a+-- addSubject wid s f = mkSubject wid s $ \sbj -> tickScene $ f sbj++-- | Schedule cleanup of the callbacks when the parent widget is rerendered.+bookSubjectCleanup ::+    (MonadReactor p allS cmd m)+    => Subject s -> m ()+bookSubjectCleanup sbj = exec' $ BookSubjectCleanup sbj++-- | Rerender the ShimComponent using the current @Entity@ context+rerender :: (MonadReactor p s cmd m) => m ()+rerender = do+    sbj <- view _subject+    exec' $ Rerender sbj++-- | Get the 'Model' and exec actions, using the current @Entity@ context+getModel :: (MonadReactor p s cmd m) => m s+getModel = delegate $ \k -> do+    Entity sbj slf <- ask+    let k' s = case preview slf s of+            Nothing -> pure ()+            Just s' -> k s'+    c <- codify k'+    exec' $ GetModel sbj c++-- | Get the event target+-- If a "ref" callback to update 'elementalRef' has not been added;+-- then add it, rerender, then return the EventTarget.+getElementalRef :: (MonadReactor p s cmd m) => ReactId -> m EventTarget+getElementalRef ri = delegate $ \k -> do+    sbj <- view _subject+    c <- codify k+    exec' $ GetElementalRef sbj ri c++-- | Update the 'Model' using the current @Entity@ context+tickModel :: (MonadReactor p s cmd m) => ModelState s () -> m ()+tickModel m = do+    Entity sbj slf <- ask+    let m' = zoom slf m+    exec' $ TickModel sbj (command_ <$> m')++-- | Update the 'Scene' using the current @Entity@ context,+-- and also return the next action to execute.+tickModelThen :: (Also m a, MonadReactor p s cmd m) => ModelState s (m a) -> m a+tickModelThen m = do+    Entity sbj slf <- ask+    delegate $ \fire -> do+        let m' = getAls <$> zoom slf (Als <$> m)+            f n = n >>= fire+        f' <- codify f+        exec' $ TickModel sbj (f' <$> m')++-- | Create a callback for a 'JE.JSRep' and add it to this elementals's dlist of listeners.+domTrigger ::+    ( NFData a+    , MonadReactor p s cmd m+    )+    => JE.JSRep+    -> J.JSString+    -> (JE.JSRep -> MaybeT IO a)+    -> m a+domTrigger j n goStrict = delegate $ \goLazy -> do+    Entity sbj _ <- ask+    goLazy' <- codify goLazy+    exec' $ RegisterDOMListener sbj j n goStrict goLazy'++-- | A variation of trigger which ignores the event but fires the given arg instead.+domTrigger_ ::+    ( MonadReactor p s cmd m+    )+    => JE.JSRep+    -> J.JSString+    -> a+    -> m a+domTrigger_ j n a = do+    domTrigger j n (const $ pure ())+    pure a++-- | Create a callback for a 'JE.JSRep' and add it to this elementals's dlist of listeners.+doTrigger ::+    ( NFData a+    , MonadReactor p s cmd m+    )+    => ReactId+    -> J.JSString+    -> (JE.JSRep -> MaybeT IO a)+    -> m a+doTrigger ri n goStrict = delegate $ \goLazy -> do+    Entity sbj _ <- ask+    goLazy' <- codify goLazy+    exec' $ RegisterReactListener sbj ri n goStrict goLazy'++-- | Create a callback for a 'Notice' and add it to this elementals's dlist of listeners.+trigger ::+    ( NFData a+    , MonadReactor p s cmd m+    )+    => ReactId+    -> J.JSString+    -> (Notice -> MaybeT IO a)+    -> m a+trigger ri n goStrict = doTrigger ri n $ handlesNotice goStrict+  where+    handlesNotice :: (Notice -> MaybeT IO a) -> (JE.JSRep -> MaybeT IO a)+    handlesNotice k j = MaybeT (pure $ JE.fromJSR j) >>= k++-- | A variation of trigger which ignores the event but fires the given arg instead.+trigger_ ::+    ( MonadReactor p s cmd m+    )+    => ReactId+    -> J.JSString+    -> a+    -> m a+trigger_ ri n a = do+    doTrigger ri n (const $ pure ())+    pure a++-- | Register actions to execute after a render.+-- It is safe to 'postCmd'' a 'TickScene' or 'Rerender'. These command will not+-- trigger another rendered event.+--+-- NB. This is trigged by react 'componentDidMount'+-- See jsbits/react.js hgr$shimComponent.+-- These callbacks are called after the ref callback by React+-- See https://reactjs.org/docs/refs-and-the-dom.html.+onMounted ::+    MonadReactor p s cmd m+    => m a+    -> m a+onMounted m = do+    sbj <- view _subject+    delegate $ \fire -> do+        c <- codify' (m >>= fire)+        exec' $ RegisterMountedListener sbj c++-- | Register actions to execute after a render.+-- It is safe to 'postCmd'' a 'TickScene' or 'Rerender'. These command will not+-- trigger another rendered event.+--+-- NB. This is trigged by react 'componentDidUpdate' and 'componentDidMount'+-- so it is also called for the initial render.+-- See jsbits/react.js hgr$shimComponent.+-- These callbacks are called after the ref callback by React+-- See https://reactjs.org/docs/refs-and-the-dom.html.+onRendered ::+    MonadReactor p s cmd m+    => m a+    -> m a+onRendered m = do+    sbj <- view _subject+    delegate $ \fire -> do+        c <- codify' (m >>= fire)+        exec' $ RegisterRenderedListener sbj c++onNextRendered ::+    MonadReactor p s cmd m+    => m a -> m a+onNextRendered m = do+    sbj <- view _subject+    delegate $ \fire -> do+        c <- codify' (m >>= fire)+        exec' $ RegisterNextRenderedListener sbj c++-- | Register actions to execute after the state has been updated with TickState.+-- It is safe to 'postCmd'' another 'TickScene', another onRendered event will+-- not be generated.+--+-- NB. This is trigged by react 'componentDidUpdate' and 'componentDidMount'+-- so it is also called for the initial render.+-- See jsbits/react.js hgr$shimComponent.+-- These callbacks are called after the ref callback by React+-- See https://reactjs.org/docs/refs-and-the-dom.html.+onTicked ::+    MonadReactor p s cmd m+    => m a+    -> m a+onTicked m = do+    sbj <- view _subject+    delegate $ \fire -> do+        c <- codify' (m >>= fire)+        exec' $ RegisterTickedListener sbj c

@@ -0,0 +1,746 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Glazier.React.Reactor.Exec+    ( ReactorEnv(..)+    , mkReactorEnvIO+    , startApp+    , reactorBackgroundWork+    , execReactorCmd+    , execMkReactId+    , execSetRender+    , execMkSubject+    , execBookSubjectCleanup+    , execGetModel+    , execGetElementalRef+    , execRerender+    , execTickModel+    , execRegisterDOMListener+    , execRegisterReactListener+    , execRegisterMountedListener+    , execRegisterRenderedListener+    , execRegisterNextRenderedListener+    , execRegisterTickedListener+    ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.DeepSeq+import Control.Lens+import Control.Lens.Misc+import Control.Monad.Delegate+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Maybe.Extras+import Control.Monad.Trans.RWS.Strict+import Control.Monad.Trans.State.Strict+import Data.Diverse.Lens+import qualified Data.DList as DL+import Data.Foldable+import Data.IORef+import qualified Data.JSString as J+import Data.Maybe+import Data.Typeable+import qualified GHCJS.Foreign.Callback as J+import qualified GHCJS.Foreign.Callback.Internal as J+import qualified GHCJS.Foreign.Export as J+import qualified GHCJS.Types as J+import Glazier.Command+import Glazier.React.Component+import Glazier.React.Entity+import Glazier.React.EventTarget+import Glazier.React.Gadget+import Glazier.React.Markup+import Glazier.React.ReactDOM+import Glazier.React.ReactId.Internal+import Glazier.React.Reactor+import Glazier.React.ReadIORef+import Glazier.React.Scene+import Glazier.React.Subject+import Glazier.React.Subject.Internal+import Glazier.React.Widget+import Glazier.React.Window+import qualified JavaScript.Extras as JE++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)+import Data.Semigroup+#endif++data ReactorEnv = ReactorEnv+    { reactIdEnv :: MVar Int+    , reactorBackgroundEnv :: TQueue (IO (IO ()))+    }++makeLenses_ ''ReactorEnv++mkReactorEnvIO :: IO (ReactorEnv)+mkReactorEnvIO = ReactorEnv <$> (newMVar (0 :: Int)) <*> newTQueueIO++-- | An example of starting an app using the glazier-react framework+startApp ::+    ( MonadIO m+    , MonadReader r m+    , Has ReactorEnv r+    , Typeable s -- for J.export+    , AsReactor cmd+    , AsFacet (IO cmd) cmd+    )+    => (cmd -> m ()) -> Widget cmd s s () -> s -> JE.JSRep -> m ()+startApp executor wid s root = do+    -- background worker thread+    q <- view ((hasLens @ReactorEnv)._reactorBackgroundEnv)+    liftIO $ void $ forkIO $ forever $ reactorBackgroundWork q++    -- create a mvar to store the app subject+    sbjVar <- liftIO $ newEmptyMVar+    let setup = do+            sbj <- mkSubject' wid s+            exec' (command_ <$> (putMVar sbjVar sbj))+        cs = (`execState` mempty) $ evalContT setup++    -- run the initial commands, this will store the app Subject into sbjVar+    traverse_ executor cs++    -- Start the App render+    liftIO $ do+        sbj <- takeMVar sbjVar+        markup <- unReadIORef $ (`execStateT` mempty) $ displaySubject sbj+        e <- toElement markup+        renderDOM e root++        -- Export sbj to prevent it from being garbage collected+        void $ J.export sbj++reactorBackgroundWork :: TQueue (IO (IO ())) -> IO ()+reactorBackgroundWork q = do+    -- wait until there is data+    x <- atomically $ readTQueue q+    -- run the action - this might add more data into the queue+    y <- x+    -- keep looping until there is no more data in the queue+    ys <- go (DL.singleton y)+    -- Run the secondary actions - which should rerender+    fold ys+  where+    go zs = do+        xs <- atomically $ flushTQueue q+        case xs of+            [] -> pure zs+            xs' -> do+                -- run the action - this might add more data into the queue+                ys <- sequence xs'+                go (zs <> DL.fromList ys)++execReactorCmd ::+    ( MonadUnliftIO m+    , MonadReader r m+    , AsReactor cmd+    , Has ReactorEnv r+    )+    => (cmd -> m ()) -> ReactorCmd cmd -> m ()+execReactorCmd executor c = case c of+    MkReactId n k -> execMkReactId n >>= (executor . k)+    SetRender sbj w -> execSetRender sbj w+    MkSubject wid s k -> execMkSubject executor wid s >>= (executor . k)+    -- GetScene sbj k -> execGetScene sbj >>= (executor . k)+    GetModel sbj k -> execGetModel sbj >>= (executor . k)+    GetElementalRef sbj ri k -> execGetElementalRef executor sbj ri k+    -- TickScene sbj tick -> execTickScene sbj tick >>= executor+    Rerender sbj -> execRerender sbj+    TickModel sbj tick -> execTickModel sbj tick >>= executor+    BookSubjectCleanup sbj -> execBookSubjectCleanup sbj+    RegisterDOMListener sbj j n goStrict goLazy -> execRegisterDOMListener executor sbj j n goStrict goLazy+    RegisterReactListener sbj ri n goStrict goLazy -> execRegisterReactListener executor sbj ri n goStrict goLazy+    RegisterMountedListener sbj k -> execRegisterMountedListener executor sbj k+    RegisterRenderedListener sbj k -> execRegisterRenderedListener executor sbj k+    RegisterNextRenderedListener sbj k -> execRegisterNextRenderedListener executor sbj k+    RegisterTickedListener sbj k -> execRegisterTickedListener executor sbj k++-----------------------------------------------------------------+execMkReactId ::+    ( MonadIO m+    , Has ReactorEnv r+    , MonadReader r m+    )+    => J.JSString+    -> m ReactId+execMkReactId n = do+    v <- view ((hasLens @ReactorEnv)._reactIdEnv)+    liftIO $ do+        i <- takeMVar v+        let i' = JE.safeIncrement i+        putMVar v i'+        pure . ReactId . J.append n . J.cons ':' . J.pack $ show i'+++doRender :: IORef (Scene s) -> Window s () -> IO J.JSVal+doRender scnRef win = do+    -- render using from scnRef (doesn't block)+    scn <- readIORef scnRef+    (mrkup, _) <- unReadIORef (execRWST win scn mempty) -- ignore unit writer output+    a <- JE.toJS <$> toElement mrkup+    pure a++doRef :: IORef (Scene s) -> MVar (Scene s) -> J.JSVal -> IO ()+doRef scnRef scnVar j = do+    -- update componentRef held in the Plan+    scn <- takeMVar scnVar+    let scn' = scn & _plan._componentRef .~ (JE.fromJS j)+    atomicWriteIORef scnRef scn'+    putMVar scnVar scn'++doRendered :: IORef (Scene s) -> MVar (Scene s) -> IO ()+doRendered scnRef scnVar = do+    -- update nextRenderedListener held in the Plan+    scn <- takeMVar scnVar+    let scn' = scn & _plan._nextRenderedListener .~ mempty+        nxt = scn ^. _plan._nextRenderedListener+        cb = scn ^. _plan._renderedListener++    atomicWriteIORef scnRef scn'+    putMVar scnVar scn'+    nxt+    cb++doMounted :: IORef (Scene s) -> IO ()+doMounted scnRef = do+    scn <- readIORef scnRef+    scn ^. _plan._mountedListener++execSetRender :: MonadIO m => Subject s -> Window s () -> m ()+execSetRender sbj win = liftIO $ do+    -- create the callbacks+    renderCb <- J.syncCallback' (doRender scnRef win)+    -- Create automatic garbage collection of the callbacks+    -- that will run when the Subject lease members are garbage collected.+    renderLease <- liftIO $ newEmptyMVar+    void $ mkWeakMVar renderLease $ J.releaseCallback renderCb+    -- Replace the existing ShimCallbacks (was fake version)+    scn <- takeMVar scnVar+    -- replace the rendering function+    atomicWriteIORef rndrLeaseRef renderLease+    let scn' = scn & _plan._shimCallbacks._shimRender .~ renderCb+    atomicWriteIORef scnRef scn'+    putMVar scnVar scn'+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj+    rndrLeaseRef = renderLeaseRef sbj++-- | Make an initialized 'Subject' for a given model using the given+-- 'Window' rendering function.+-- The original window should be dropped and the 'Widget' reduced to just a+-- 'Gadget' to emphasis the fact that the 'Window' was used up.+-- 'displaySubject' should be used to render the subject.+execMkSubject ::+    ( MonadIO m+    , AsReactor cmd+    , Has ReactorEnv r+    , MonadReader r m+    )+    => (cmd -> m ())+    -> Widget cmd s s ()+    -> s+    -> m (Subject s)+execMkSubject executor wid s = do+    ri <- execMkReactId (J.pack "plan")+    (sbj, cs) <- liftIO $ do+        -- create shim with fake callbacks for now+        let newPlan = Plan+                ri+                Nothing+                (ShimCallbacks (J.Callback J.nullRef) (J.Callback J.nullRef) (J.Callback J.nullRef) (J.Callback J.nullRef))+                mempty+                mempty+                mempty+                mempty+                mempty+                mempty+                mempty+                False+                False+            scn = Scene newPlan s++        scnRef <- newIORef scn+        scnVar <- newEmptyMVar+        -- Create a MVar just for auto cleanup of the callbacks+        -- This mvar must not be reachable from the callbacks,+        -- otherwise the callbacks will always be alive.+        otherCbLease <- newEmptyMVar+        renderLease <- newEmptyMVar+        rndrLeaseRef <- newIORef renderLease++        -- Create callbacks for now+        renderCb <- J.syncCallback' (pure J.nullRef) -- dummy render for now+        refCb <- J.syncCallback1 J.ContinueAsync (doRef scnRef scnVar)+        mountedCb <- J.syncCallback J.ContinueAsync (doMounted scnRef)+        renderedCb <- J.syncCallback J.ContinueAsync (doRendered scnRef scnVar)+        -- Create automatic garbage collection of the callbacks+        -- that will run when the Subject lease members are garbage collected.+        void $ mkWeakMVar otherCbLease $ do+            scn' <- readIORef scnRef+            -- scn' ^. _plan._nextRenderedListener+            scn' ^. _plan._finalCleanup+            -- cleanup callbacks+            traverse_ (traverse (J.releaseCallback . fst) . reactListeners) (scn' ^. _plan._elementals)+            traverse_ (J.releaseCallback . fst) (scn' ^. _plan._domlListeners)+            J.releaseCallback refCb+            J.releaseCallback renderedCb+        void $ mkWeakMVar renderLease $ J.releaseCallback renderCb++        -- Now we have enough to make a subject+        let sbj = Subject scnRef scnVar rndrLeaseRef otherCbLease+            -- initalize the subject using the Gadget+            gad = runExceptT wid+            gad' = gad `bindLeft` (exec' . SetRender sbj)+            gad'' = (either id id) <$> gad'+            tick = runGadget gad'' (Entity sbj id) pure+            cs = execState tick mempty+            -- update the scene to include the real shimcallbacks+            scn' = scn & _plan._shimCallbacks .~ ShimCallbacks renderCb mountedCb renderedCb refCb+        -- update the mutable variables with the initialzed scene+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+        pure (sbj, cs)+    -- execute additional commands+    -- one of these commands will be 'SetRender' which will+    -- update the dummy render with the real render function.+    executor (command' $ DL.toList cs)+    -- return the subject+    pure sbj++execBookSubjectCleanup ::+    ( MonadIO m+    , MonadReader r m+    , Has ReactorEnv r+    )+    => Subject s -> m ()+execBookSubjectCleanup sbj = do+    liftIO $ do+        scn <- takeMVar scnVar+        let cleanup = prolong sbj+            scn' = scn & _plan._nextRenderedListener %~ (*> cleanup)+        -- Update the back buffer+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+    -- Trigger a rerender+    execRerender sbj+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++execGetModel ::+    MonadIO m+    => Subject s+    -> m s+execGetModel sbj = liftIO . fmap model . readIORef $ sceneRef sbj++execRerender ::+    ( MonadIO m+    , MonadReader r m+    , Has ReactorEnv r+    )+    => Subject s -> m ()+execRerender sbj = do+    q <- view ((hasLens @ReactorEnv)._reactorBackgroundEnv)+    liftIO $ do+        scn <- takeMVar scnVar+        if not (scn ^. _plan._rerenderRequired)+            then do+                let scn' = scn & _plan._rerenderRequired .~ True+                -- Update the back buffer+                atomicWriteIORef scnRef scn'+                putMVar scnVar scn'+                atomically $ writeTQueue q (pure (scheduleRerender sbj))+            -- rerender has already been scheduled+            else putMVar scnVar scn+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++scheduleRerender :: Subject s -> IO ()+scheduleRerender sbj = do+    scn <- takeMVar scnVar+    if scn ^. _plan._rerenderRequired+        then do+            let scn' = scn & _plan._rerenderRequired .~ False+                        & _plan._tickedNotified .~ False+            -- Update the back buffer+            atomicWriteIORef scnRef scn'+            putMVar scnVar scn'+            case scn ^. _plan._componentRef of+                Nothing -> pure ()+                Just j -> rerenderShim j+        -- rerender not required (eg. already processed)+        else putMVar scnVar scn+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++-- | No need to run in a separate thread because it should never block for a significant amount of time.+-- Update the scene 'MVar' with the given action. Also triggers a rerender.+execTickModel ::+    ( MonadIO m+    , MonadReader r m+    , Has ReactorEnv r+    )+    => Subject s+    -> ModelState s cmd+    -> m cmd+execTickModel sbj tick = do+    q <- view ((hasLens @ReactorEnv)._reactorBackgroundEnv)+    liftIO $ do+        scn <- takeMVar scnVar+        let s = scn ^. _model+        (c, s') <- unReadIORef $ runStateT tick s+        let scn' = scn & _model .~ s'+        -- Update the back buffer+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+        atomically $ writeTQueue q notifyTicked+        pure c+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj+    notifyTicked = do+        scn <- takeMVar scnVar+        if not (scn ^. _plan._tickedNotified)+            then do+                let scn' = scn & _plan._tickedNotified .~ True+                        & _plan._rerenderRequired .~ True+                    cb = scn ^. _plan._tickedListener+                -- Update the back buffer+                atomicWriteIORef scnRef scn'+                putMVar scnVar scn'+                -- run tickedListeener+                cb+                pure (scheduleRerender sbj)+            -- notify not required (eg. already processed)+            else do+                putMVar scnVar scn+                pure (pure ())++mkEventCallback ::+    (MonadIO m)+    => IORef (J.JSVal -> IO (), IO ())+    -> m (J.Callback (J.JSVal -> IO ()))+mkEventCallback hdlRef = do+    liftIO $ J.syncCallback1 J.ContinueAsync $ \evt -> do+        (preprocessor, postprocessor) <- readIORef hdlRef+        -- first run all the non-blocking preprocessors+        preprocessor evt+        -- then run all the possibly blocking postprocessors+        postprocessor++-- | Using the NFData idea from React/Flux/PropertiesAndEvents.hs+-- React re-uses Notice from a pool, which means it may no longer be valid if we lazily+-- parse it. However, we still want lazy parsing so we don't parse unnecessary fields.+-- Additionally, we don't want to block during the event handling.The reason this is a problem is+-- because Javascript is single threaded, but Haskell is lazy.+-- Therefore GHCJS threads are a strange mixture of synchronous and asynchronous threads,+-- where a synchronous thread might be converted to an asynchronous thread if a "black hole" is encountered.+-- See https://github.com/ghcjs/ghcjs-base/blob/master/GHCJS/Concurrent.hs+-- This safe interface requires two input functions:+-- 1. a function to reduce Notice to a NFData. The handleEvent will ensure that the+-- NFData is forced which will ensure all the required fields from Synthetic event has been parsed.+-- This function must not block.+-- 2. a second function that uses the NFData. This function is allowed to block.+-- handleEvent results in a function that you can safely pass into 'GHC.Foreign.Callback.syncCallback1'+-- with 'GHCJS.Foreign.Callback.ContinueAsync'.+-- I have innovated further with the NFData idea to return two functions:+-- 1. (evt -> IO ()) function to preprocess the event, which is guaranteed to be non blocking.+-- 2. An IO () postprocessor function which may block.+-- This allows for multiple handlers for the same event to be processed safely,+-- by allowing a way for all the preprocessor handlers are all run first before+-- running all of the postprocessor handlers.+mkEventHandler :: (NFData a) => (evt -> MaybeT IO a) -> IO (evt -> IO (), MaybeT IO a)+mkEventHandler goStrict = do+    -- create a channel to write preprocessed data for the postprocessor+    -- 'Chan' guarantees that the writer is never blocked by the reader.+    -- There is only one reader/writer per channel.+    c <- newTQueueIO+    let preprocess evt = (`evalMaybeT` ()) $ do+            r <- goStrict evt+            -- This is guaranteed never to block+            lift $ atomically $ writeTQueue c $!! r+        -- there might not be a value in the chan+        -- because the preprocessor might not have produced any values+        postprocess = MaybeT $ atomically $ tryReadTQueue c+    pure (preprocess, postprocess)++addEventHandler :: (NFData a)+    => (JE.JSRep -> MaybeT IO a)+    -> (a -> IO ())+    -> IORef (J.JSVal -> IO (), IO ())+    -> IO ()+addEventHandler goStrict goLazy listenerRef = do+    -- update the ioref with the new handler+    (preprocessor, postprocessor) <- mkEventHandler (goStrict . JE.toJSR)+    let postprocessor' = (`evalMaybeT` ()) (postprocessor >>= (lift . goLazy))+    atomicModifyIORef' listenerRef $ \hdl -> (hdl `mappendListener` (preprocessor, postprocessor'), ())++-- | Create ref handler to assign 'elementalRef'+data Freshness = Existing | Fresh++execGetElementalRef ::+    ( MonadUnliftIO m+    , MonadReader r m+    , Has ReactorEnv r+    )+    => (cmd -> m ())+    -> Subject s+    -> ReactId+    -> (EventTarget -> cmd)+    -> m ()+execGetElementalRef executor sbj ri k = do+    UnliftIO u <- askUnliftIO+    scn <- liftIO $ takeMVar scnVar+    (refFreshness, pln) <- registerRefCoreListener sbj ri (plan scn)+    let tryAgain = u $ execGetElementalRef executor sbj ri k+        pln' = pln & _nextRenderedListener %~ (*> tryAgain)+        scn' = scn & _plan .~ pln'+        ret = pln ^? (_elementals.ix ri._elementalRef._Just)+        doTryAgain = do+            liftIO $ do+                atomicWriteIORef scnRef scn'+                putMVar scnVar scn'+            -- trigger a rerender+            execRerender sbj+    case refFreshness of+        Fresh -> doTryAgain+        Existing -> case ret of+            Nothing -> doTryAgain+            Just ret' -> do+                liftIO $ putMVar scnVar scn+                executor . k $ ret'+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++-- | This one doesn't take the sceneVar+registerRefCoreListener :: (MonadIO m)+    => Subject s+    -> ReactId+    -> Plan+    -> m (Freshness, Plan)+registerRefCoreListener sbj ri pln = do+    liftIO $ do+        -- first get or make the target+        (freshness, eventHdl) <-+            case pln ^. _elementals.at ri.to (fromMaybe (Elemental Nothing mempty))._reactListeners.at n of+                Nothing -> do+                    listenerRef <- newIORef mempty+                    cb <- mkEventCallback listenerRef+                    -- update listenerRef with new event listener+                    -- only do this once (when for first ref listener)+                    addEventHandler (pure . JE.fromJSR) hdlRef listenerRef+                    pure (Fresh, (cb, listenerRef))+                Just eventHdl -> pure (Existing, eventHdl)+        -- prepare the updated state+        let pln' = pln & _elementals.at ri %~ (Just . addElem . initElem)+            initElem = fromMaybe (Elemental Nothing mempty)+            addElem = _reactListeners.at n %~ addListener+            addListener = Just . maybe eventHdl (const eventHdl)+        case freshness of+            Fresh -> pure (Fresh, pln')+            Existing -> pure (Existing, pln)+  where+    n = J.pack "ref"+    -- hdlRef x = command' $ TickScene sbj (command_ <$> (_plan._elementals.ix ri._elementalRef .= x))+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj+    hdlRef x = do+        scn <- takeMVar scnVar+        let scn' = scn & _plan._elementals.ix ri._elementalRef .~ x+        -- Update the back buffer+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'++execRegisterReactListener :: (NFData a, MonadUnliftIO m)+    => (cmd -> m ())+    -> Subject s+    -> ReactId+    -> J.JSString+    -> (JE.JSRep -> MaybeT IO a)+    -> (a -> cmd)+    -> m ()+execRegisterReactListener executor sbj ri n goStrict goLazy = do+    UnliftIO u <- askUnliftIO+    scn_ <- liftIO $ takeMVar scnVar+    -- special logic for ref, where the first ref handler must be 'registerRefCoreListener'+    scn <- if (n == (J.pack "ref"))+        then do+            (refFreshness, pln) <- registerRefCoreListener sbj ri (plan scn_)+            case refFreshness of+                Existing -> pure scn_+                Fresh -> pure (scn_ & _plan .~ pln)+        else pure scn_+    liftIO $ do+        -- get or make the target+        (freshness, eventHdl@(_, listenerRef)) <-+            case scn ^. _plan._elementals.at ri.to (fromMaybe (Elemental Nothing mempty))._reactListeners.at n of+                Nothing -> do+                    listenerRef <- newIORef mempty+                    cb <- mkEventCallback listenerRef+                    pure (Fresh, (cb, listenerRef))+                Just eventHdl -> pure (Existing, eventHdl)+        let scn' = case freshness of+                Fresh -> scn & _plan._elementals.at ri %~ (Just . addElem . initElem)+                Existing -> scn+            initElem = fromMaybe (Elemental Nothing mempty)+            addElem = _reactListeners.at n %~ addListener+            addListener = Just . maybe eventHdl (const eventHdl)+        -- update listenerRef with new event listener+        addEventHandler goStrict (u . executor . goLazy) listenerRef+        -- Update the subject+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++mappendListener :: (J.JSVal -> IO (), IO ()) -> (J.JSVal -> IO (), IO ()) -> (J.JSVal -> IO (), IO ())+mappendListener (f1, g1) (f2, g2) = (\x -> f1 x *> f2 x, g1 *> g2)++execRegisterTickedListener :: (MonadUnliftIO m)+    => (cmd -> m ())+    -> Subject s+    -> cmd+    -> m ()+execRegisterTickedListener executor sbj c = do+    UnliftIO u <- askUnliftIO+    let hdl = u $ executor c+    liftIO $ do+        scn <- takeMVar scnVar+        let scn' = scn & _plan._tickedListener %~ (*> hdl)+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++execRegisterMountedListener :: (MonadUnliftIO m)+    => (cmd -> m ())+    -> Subject s+    -> cmd+    -> m ()+execRegisterMountedListener executor sbj c = do+    UnliftIO u <- askUnliftIO+    let hdl = u $ executor c+    liftIO $ do+        scn <- takeMVar scnVar+        let scn' = scn & _plan._mountedListener %~ (*> hdl)+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++execRegisterRenderedListener :: (MonadUnliftIO m)+    => (cmd -> m ())+    -> Subject s+    -> cmd+    -> m ()+execRegisterRenderedListener executor sbj c = do+    UnliftIO u <- askUnliftIO+    let hdl = u $ executor c+    liftIO $ do+        scn <- takeMVar scnVar+        let scn' = scn & _plan._renderedListener %~ (*> hdl)+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++execRegisterNextRenderedListener :: (MonadUnliftIO m)+    => (cmd -> m ())+    -> Subject s+    -> cmd+    -> m ()+execRegisterNextRenderedListener executor sbj c = do+    UnliftIO u <- askUnliftIO+    let hdl = u $ executor c+    liftIO $ do+        scn <- takeMVar scnVar+        let scn' = scn & _plan._nextRenderedListener %~ (*> hdl)+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++execRegisterDOMListener ::+    ( NFData a+    , MonadUnliftIO m+    , Has ReactorEnv r+    , MonadReader r m+    )+    => (cmd -> m ())+    -> Subject s+    -> JE.JSRep+    -> J.JSString+    -> (JE.JSRep -> MaybeT IO a)+    -> (a -> cmd)+    -> m ()+execRegisterDOMListener executor sbj j n goStrict goLazy = do+    -- Add the handler to the state+    UnliftIO u <- askUnliftIO+    -- generate a unique id+    ri <- execMkReactId n+    liftIO $ do+        scn <- takeMVar scnVar+        -- since ri is unique, it'll always be a new map item+        -- update the ioref with the new handler+        listenerRef <- newIORef mempty+        cb <- mkEventCallback listenerRef+        addEventHandler goStrict (u . executor . goLazy) listenerRef+        -- prepare the updated state,+        let scn' = scn & _plan._domlListeners.at ri .~ (Just (cb, listenerRef))+                & _plan._finalCleanup %~ (*> removeDomListener j n cb)+        -- Update the subject+        atomicWriteIORef scnRef scn'+        putMVar scnVar scn'+        -- now add the domListener to the javascript target+        addDomListener j n cb+  where+    scnRef = sceneRef sbj+    scnVar = sceneVar sbj++addDomListener :: JE.JSRep -> J.JSString -> J.Callback (J.JSVal -> IO ()) -> IO ()+addDomListener j n cb = js_addDomListener (JE.toJS j) n (JE.toJS cb)++removeDomListener :: JE.JSRep -> J.JSString -> J.Callback (J.JSVal -> IO ()) -> IO ()+removeDomListener j n cb = js_removeDomListener (JE.toJS j) n (JE.toJS cb)++#ifdef __GHCJS__++foreign import javascript unsafe+    "if ($1 && $1['addEventListener']) { $1['addEventListener']($2, $3); }"+    js_addDomListener :: J.JSVal -> J.JSString -> J.JSVal -> IO ()++foreign import javascript unsafe+    "if ($1 && $1['removeEventListener']) { $1['removeEventListener']($2, $3); }"+    js_removeDomListener :: J.JSVal -> J.JSString -> J.JSVal -> IO ()++#else++js_addDomListener :: J.JSVal -> J.JSString -> J.JSVal -> IO ()+js_addDomListener _ _ _ = pure mempty++js_removeDomListener :: J.JSVal -> J.JSString -> J.JSVal -> IO ()+js_removeDomListener _ _ _ = pure mempty++#endif

@@ -0,0 +1,7 @@+module Glazier.React.ReadIORef+    ( ReadIORef -- constructor not exported+    , unReadIORef+    , doReadIORef+    ) where++import Glazier.React.ReadIORef.Internal

@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Glazier.React.ReadIORef.Internal where++import Control.Applicative+import Data.IORef++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)+import Data.Semigroup+#endif++-- | NB. Don't export ReadSubject constructor to guarantee+-- that that it only contains non-blocking 'readIORef' IO.+newtype ReadIORef a = ReadIORef (IO a)+    deriving (Functor, Applicative, Monad)++instance Show (ReadIORef a) where+    showsPrec _ (ReadIORef _) = showString "ReadIORef"++instance Semigroup a => Semigroup (ReadIORef a) where+    ReadIORef f <> ReadIORef g = ReadIORef $ liftA2 (<>) f g++instance Monoid a => Monoid (ReadIORef a) where+    mempty = ReadIORef $ pure mempty+#if !MIN_VERSION_base(4,11,0)+    (ReadIORef f) `mappend` (ReadIORef g) = ReadIORef (liftA2 mappend f g)+#endif++unReadIORef :: ReadIORef a -> IO a+unReadIORef (ReadIORef m) = m++doReadIORef :: IORef a -> ReadIORef a+doReadIORef ref = ReadIORef $ readIORef $ ref

@@ -0,0 +1,143 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}++module Glazier.React.Scene where++import Control.Lens+import Control.Lens.Misc+import Data.IORef+import qualified Data.Map.Strict as M+import Data.Maybe+import qualified GHC.Generics as G+import qualified GHCJS.Foreign.Callback as J+import qualified GHCJS.Types as J+import Glazier.React.Component+import Glazier.React.EventTarget+import Glazier.React.ReactId++----------------------------------------------------------------------------------++-- | Interactivity for a particular DOM element.+data Elemental = Elemental+    { elementalRef :: Maybe EventTarget+    -- (name of event, context of event)+    , reactListeners :: M.Map J.JSString+        ( J.Callback (J.JSVal -> IO ())+        , IORef (J.JSVal -> IO (), IO ())+        )+    } deriving (G.Generic)++makeLenses_ ''Elemental++----------------------------------------------------------------------------------++data ShimCallbacks = ShimCallbacks+    -- render function of the ReactComponent+    { shimRender :: J.Callback (IO J.JSVal)+    -- Run the mountedListener in the plan+    , shimMounted :: J.Callback (IO ())+    -- Run the renderedListener in the plan+    , shimRendered :: J.Callback (IO ())+    -- updates the componenRef+    , shimRef :: J.Callback (J.JSVal -> IO ())+    } deriving (G.Generic)++makeLenses_ ''ShimCallbacks++----------------------------------------------------------------------------------++-- | Interactivity data for a react component+data Plan = Plan+    -- a react "ref" to the javascript instance of ReactComponent+    -- so that react "componentRef.setState()" can be called.+    { planId :: ReactId+    , componentRef :: Maybe ComponentRef+    , shimCallbacks :: ShimCallbacks+    -- called after state was just updated+    , tickedListener :: IO ()+    -- called after every rendering+    , renderedListener :: IO ()+    -- called after first rendering only+    , mountedListener :: IO ()+    -- do on next rerender. This gets reset after every rerender.+    , nextRenderedListener :: IO ()+    -- interactivity data for child DOM elements+    , elementals :: M.Map ReactId Elemental+    -- interactivity for explicit eventTarget.addEventListener() callbacks+    , domlListeners :: M.Map ReactId+        ( J.Callback (J.JSVal -> IO ())+        , IORef (J.JSVal -> IO (), IO ())+        )+    -- cleanup to call eventTarget.removeEventListener()+    , finalCleanup :: IO ()++    -- set to True if tickedListener has been processed+    , tickedNotified :: Bool+    -- set to True is rerender is required+    , rerenderRequired :: Bool+    } deriving (G.Generic)++makeLenses_ ''Plan++instance Show Plan where+    showsPrec d pln = showParen+        (d >= 11)+        ( showString "Plan {" . showString "componentRef ? " . shows (isJust $ componentRef pln)+        . showString ", " . showString "elementalIds = " . showList (M.keys $ elementals pln)+        . showString ", " . showString "planIds = " . showList (M.keys $ elementals pln)+        . showString "}"+        )++----------------------------------------------------------------------------------++-- | A 'Scene' contains interactivity data for all widgets as well as the model data.+data Scene s = Scene+    -- commands could be in a writer monad, but then you can't get+    -- a MonadWriter with ContT, but you can have a MonadState with ContT.+    { plan :: Plan+    , model :: s+    } deriving (G.Generic, Show, Functor)++_model :: Lens (Scene s) (Scene s') s s'+_model = lens model (\s a -> s { model = a})++_plan :: Lens' (Scene s) Plan+_plan = lens plan (\s a -> s { plan = a})++editSceneModel :: (Functor f) => LensLike' f s a -> LensLike' f (Scene s) (Scene a)+editSceneModel l safa s = (\s' -> s & _model .~ s' ) <$> l afa' (s ^. _model)+  where+    afa' a = (view _model) <$> safa (s & _model .~ a)++magnifiedScene ::+    ( Magnify m n (Scene a) (Scene b)+    , Functor (Magnified m r)+    )+    => LensLike' (Magnified m r) b a -> m r -> n r+magnifiedScene l = magnify (editSceneModel l)++zoomedScene ::+    ( Zoom m n (Scene a) (Scene b)+    , Functor (Zoomed m r)+    )+    => LensLike' (Zoomed m r) b a -> m r -> n r+zoomedScene l = zoom (editSceneModel l)++----------------------------------------------------------------------------------++elementTarget :: ReactId -> Traversal' (Scene s) EventTarget+elementTarget ri = _plan._elementals.ix ri._elementalRef._Just

@@ -0,0 +1,8 @@+module Glazier.React.Subject+    ( Subject -- constructor not exported+    , sceneRef+    , sceneVar+    , prolong -- read only accessor+    ) where++import Glazier.React.Subject.Internal

@@ -0,0 +1,43 @@+module Glazier.React.Subject.Internal where++import Control.Concurrent+import Control.Monad+import Data.IORef+import Glazier.React.Scene+----------------------------------------------------------------------------------++-- | Using MVar for synchronizing because it guarantees FIFO wakeup+-- which will help prevent old updates overriding new updates.+-- The constructor is hidden to maintain the expectation that+-- the last two member will keep the 'ShimCallbacks' inside the 'Scene' alive.+-- Before removing Subject from a container, use 'prolong' to store+-- the prolonging IO action "nextRenderedListener" action handler,+-- so that the 'ShimCallbacks' is garbage collected+-- only after the child widget is no longer rendered.+data Subject p = Subject+    (IORef (Scene p))+    (MVar (Scene p))+    (IORef (MVar ())) -- garbage collection for rendering callback+    (MVar ()) -- garbage collection for other callbacks++    deriving Eq++sceneRef :: Subject p -> IORef (Scene p)+sceneRef (Subject x _ _ _) = x++sceneVar :: Subject p -> MVar (Scene p)+sceneVar (Subject _ x _ _) = x++renderLeaseRef :: Subject p -> IORef (MVar ())+renderLeaseRef (Subject _ _ x _) = x++otherLeaseVar :: Subject p -> MVar ()+otherLeaseVar (Subject _ _ _ x) = x++-- | Creates an IO action whose existence will keep the lease alive.+-- Running it has no side effects.+prolong :: Subject s -> IO ()+prolong (Subject _ _ rndrLeaseRef otherCbLease) = do+    rndrLease <- readIORef rndrLeaseRef+    (void $ isEmptyMVar rndrLease)+    (void $ isEmptyMVar otherCbLease)

@@ -1,104 +1,216 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}  module Glazier.React.Widget where -import qualified Control.Disposable as CD import Control.Lens-import Control.Monad.Free.Church-import qualified Data.DList as D-import qualified Glazier as G-import qualified Glazier.React.Maker as R-import qualified Glazier.React.Markup as R-import qualified Glazier.React.Model as R+import Control.Monad.Except+import Data.Bifunctor+import Data.Diverse.Lens+import Data.Diverse.Profunctor+import Glazier.Command.Exec+import Glazier.React.Entity+import Glazier.React.Gadget+import Glazier.React.Scene+import Glazier.React.Window -type family CommandOf w where-    CommandOf (Widget c a o m p) = c+-- | A 'Widget' is a 'Gadget' that fires 'Either' a 'Window' or a value.+type Widget cmd p s a = ExceptT (Window s ()) (Gadget cmd p s) a -type family ActionOf w where-    ActionOf (Widget c a o m p) = a+-- | Use this function to verify at compile time that the first widget doesn't+-- require any @AsFacet (IO cmd) cmd@.+noIOWidget :: Widget (NoIOCmd cmd) s s a -> Widget cmd s s a -> Widget cmd s s a+noIOWidget _ = id -type family OutlineOf w where-    OutlineOf (Widget c a o m p) = o+magnifyWidget :: Traversal' t s -> ExceptT (Window s ()) (Gadget cmd p s) a -> ExceptT (Window t ()) (Gadget cmd p t) a+magnifyWidget l wid = ExceptT $ (first (magnifiedScene l)) <$> (magnifiedEntity l (runExceptT wid)) -type family ModelOf w where-    ModelOf (Widget c a o m p) = m+-- | Convert a 'Gadget' into a 'Widget'+widget :: Gadget cmd p s (Either (Window s ()) a) -> Widget cmd p s a+widget = ExceptT -type family PlanOf w where-    PlanOf (Widget c a o m p) = p+runWidget :: Widget cmd p s a -> Gadget cmd p s (Either (Window s ()) a)+runWidget = runExceptT -type SceneOf w = R.Scene (ModelOf w) (PlanOf w)+mapWidget ::+    (Gadget cmd p s (Either (Window s ()) a) -> Gadget cmd p' s' (Either (Window s' ()) b))+    -> Widget cmd p s a -> Widget cmd p' s' b+mapWidget = mapExceptT -type FrameOf w = R.Frame (ModelOf w) (PlanOf w)+display :: Window s () -> Widget cmd p s a+display = throwError -type GizmoOf w = R.Gizmo (ModelOf w) (PlanOf w)+overWindow :: (Window s () -> Window s ()) -> Widget cmd p s a -> Widget cmd p s a+overWindow = withExceptT -type WindowOf w = G.WindowT (SceneOf w) (R.ReactMlT Identity) ()+overWindow2 :: (Window s () -> Window s () -> Window s ())+    -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a+overWindow2 f x y = withWindow x $ \x' -> withWindow y $ \y' -> display $ f x' y' -type GadgetOf w = G.GadgetT (ActionOf w) (GizmoOf w) Identity (D.DList (CommandOf w))+overWindow3 :: (Window s () -> Window s () -> Window s () -> Window s ())+    -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a+overWindow3 f x y z = withWindow x $+    \x' -> withWindow y $+    \y' -> withWindow z $+    \z' -> display $ f x' y' z' --- | tag used to choose Schema that contains Gizmos-data WithGizmo--- | tag used to choose Schema that contains Outlines-data WithOutline+-- overWindow4 :: (Window s () -> Window s () -> Window s () -> Window s () -> Window s ())+--     -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a+-- overWindow4 f x y z a = withWindow x $+--     \x' -> withWindow y $+--     \y' -> withWindow z $+--     \z' -> withWindow a $+--     \a' -> display $ f x' y' z' a' --- | You can't use type family as a type variable for a data type. The workaround is to use--- a tag to choose between different type family functions.--- ModelType takes a tag to choose between Gizmo or Outline.--- This enables creating a @data@ type that can specialize to--- using the tag.-type family SchemaType tag w where-    SchemaType WithGizmo w = GizmoOf w-    SchemaType WithOutline w = OutlineOf w+-- overWindow5 :: (Window s () -> Window s () -> Window s () -> Window s () -> Window s () -> Window s ())+--     -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a+-- overWindow5 f x y z a b = withWindow x $+--     \x' -> withWindow y $+--     \y' -> withWindow z $+--     \z' -> withWindow a $+--     \a' -> withWindow b $+--     \b' -> display $ f x' y' z' a' b' --- | Record of functions for a widget. Contains everything you need to make the model,--- render, and run the event processing.--- This is a GADT to enforce the Disposing and ToOutline constraints at the time--- of creating the Widget record.-data Widget c a o m p where-    Widget-         :: (CD.Disposing m, CD.Disposing p, R.ToOutline m o)-         => (o -> F (R.Maker a) m)-         -> (R.Frame m p -> F (R.Maker a) p)-         -> G.WindowT (R.Scene m p) (R.ReactMlT Identity) ()-         -> G.GadgetT a (R.Gizmo m p) Identity (D.DList c)-         -> Widget c a o m p+overWindow2' ::+    ( ChooseBoth x1 x2 ys)+    => (Window s () -> Window s () -> Window s ())+    -> Widget cmd p s (Which x1) -> Widget cmd p s (Which x2) -> Widget cmd p s (Which ys)+overWindow2' f x1 x2 = overWindow2 f (diversify <$> x1) (diversify <$> x2) --- | This typeclass is convenient as it carries the 'Disposing Model' and 'Disposing Plan' constraints--- and allows treating 'Widget c a m p' as a type 'w'-class (CD.Disposing (ModelOf w)-      , CD.Disposing (PlanOf w)-      , R.ToOutline (ModelOf w) (OutlineOf w)) => IsWidget w where-    -- | Make a Model from an Outline-    mkModel :: w -> OutlineOf w -> F (R.Maker (ActionOf w)) (ModelOf w)-    -- | Given an empty frame, make the Plan that uses the frame for rendering-    mkPlan :: w -> R.Frame (ModelOf w) (PlanOf w) -> F (R.Maker (ActionOf w)) (PlanOf w)-    -- | Rendering function that uses the Scene of Model and Plan-    window :: w -> G.WindowT (R.Scene (ModelOf w) (PlanOf w)) (R.ReactMlT Identity) ()-    -- | Update function that processes Action to update the Frame and Scene-    gadget :: w -> G.GadgetT (ActionOf w) (R.Gizmo (ModelOf w) (PlanOf w)) Identity (D.DList (CommandOf w))+overWindow3' ::+    ( Diversify x1 ys+    , Diversify x2 ys+    , Diversify x3 ys+    , ys ~ AppendUnique x1 (AppendUnique x2 x3))+    => (Window s () -> Window s () -> Window s () -> Window s ())+    -> Widget cmd p s (Which x1) -> Widget cmd p s (Which x2) -> Widget cmd p s (Which x3) -> Widget cmd p s (Which ys)+overWindow3' f x1 x2 x3 = overWindow3 f+    (diversify <$> x1)+    (diversify <$> x2)+    (diversify <$> x3) -instance (CD.Disposing m, CD.Disposing p, R.ToOutline m o) => IsWidget (Widget c a o m p) where-    mkModel (Widget f _ _ _) = f-    mkPlan (Widget _ f _ _) = f-    window (Widget _ _ f _) = f-    gadget (Widget _ _ _ f) = f+-- overWindow4' ::+--     ( Diversify x1 ys+--     , Diversify x2 ys+--     , Diversify x3 ys+--     , Diversify x4 ys+--     , ys ~ AppendUnique x1 (AppendUnique x2 (AppendUnique x3 x4)))+--     => (Window s () -> Window s () -> Window s () -> Window s () -> Window s ())+--     -> Widget cmd p s (Which x1) -> Widget cmd p s (Which x2) -> Widget cmd p s (Which x3) -> Widget cmd p s (Which x4)+--     -> Widget cmd p s (Which ys)+-- overWindow4' f x1 x2 x3 x4 = overWindow4 f+--     (diversify <$> x1)+--     (diversify <$> x2)+--     (diversify <$> x3)+--     (diversify <$> x4) --- | Make the required Frame and Plan for a Model-mkGizmo :: IsWidget w => w -> ModelOf w -> F (R.Maker (ActionOf w)) (R.Gizmo (ModelOf w) (PlanOf w))-mkGizmo w mdl = do-    frm <- R.mkEmptyFrame-    scn <- R.Scene mdl <$> mkPlan w frm-    R.putFrame frm scn-    pure (R.Gizmo scn frm)+-- overWindow5' ::+--     ( Diversify x1 ys+--     , Diversify x2 ys+--     , Diversify x3 ys+--     , Diversify x4 ys+--     , Diversify x5 ys+--     , ys ~ AppendUnique x1 (AppendUnique x2 (AppendUnique x3 (AppendUnique x4 x5))))+--     => (Window s () -> Window s () -> Window s () -> Window s () -> Window s () -> Window s ())+--     -> Widget cmd p s (Which x1) -> Widget cmd p s (Which x2) -> Widget cmd p s (Which x3)+--     -> Widget cmd p s (Which x4) -> Widget cmd p s (Which x5) -> Widget cmd p s (Which ys)+-- overWindow5' f x1 x2 x3 x4 x5 = overWindow5 f+--     (diversify <$> x1)+--     (diversify <$> x2)+--     (diversify <$> x3)+--     (diversify <$> x4)+--     (diversify <$> x5) --- | Make the required Frame and Plan from an Outline-mkGizmo' ::-  IsWidget w =>-  w-  -> OutlineOf w-  -> F (R.Maker (ActionOf w)) (R.Gizmo (ModelOf w) (PlanOf w))-mkGizmo' w i = mkModel w i >>= mkGizmo w+withWindow :: Widget cmd p s a -> (Window s () -> Widget cmd p s a) -> Widget cmd p s a+withWindow = catchError++withWindow' :: (ChooseBoth xs ys zs)+    => Widget cmd p s (Which xs)+    -> (Window s () -> Widget cmd p s (Which ys))+    -> Widget cmd p s (Which zs)+withWindow' m f = withWindow (diversify <$> m) (fmap diversify . f)++-- withWindow2 :: Widget cmd p s a -> Widget cmd p s a+--     -> (Window s () -> Window s () -> Widget cmd p s a)+--     -> Widget cmd p s a+-- withWindow2 x y f = withWindow x $ \x' -> withWindow y $ \y' -> f x' y'++-- withWindow3 :: Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a+--     -> (Window s () -> Window s () -> Window s () -> Widget cmd p s a)+--     -> Widget cmd p s a+-- withWindow3 x y z f = withWindow x $ \x' -> withWindow y $ \y' -> withWindow z $ \z' -> f x' y' z'++-- windowWith :: (Window s () -> Widget cmd p s a) -> Widget cmd p s a -> Widget cmd p s a+-- windowWith = flip withWindow++-- windowWith2 :: (Window s () -> Window s () -> Widget cmd p s a)+--     -> Widget cmd p s a -> Widget cmd p s a+--     -> Widget cmd p s a+-- windowWith2 f x y = withWindow2 x y f++-- windowWith3 :: (Window s () -> Window s () -> Window s () -> Widget cmd p s a)+--     -> Widget cmd p s a -> Widget cmd p s a -> Widget cmd p s a+--     -> Widget cmd p s a+-- windowWith3 f x y z = withWindow3 x y z f++-- withWindow2' ::+--     ( Diversify x1 zs+--     , Diversify x2 zs+--     , Diversify ys zs+--     , zs ~ AppendUnique x1 (AppendUnique x2 ys)) -- not redunant contraint+--     => Widget cmd p s (Which x1)+--     -> Widget cmd p s (Which x2)+--     -> (Window s () -> Window s () -> Widget cmd p s (Which ys))+--     -> Widget cmd p s (Which zs)+-- withWindow2' x y f = withWindow2 (diversify <$> x) (diversify <$> y) (\x' y' -> fmap diversify $ f x' y')++-- withWindow3' ::+--     ( Diversify x1 zs+--     , Diversify x2 zs+--     , Diversify x3 zs+--     , Diversify ys zs+--     , zs ~ AppendUnique x1 (AppendUnique x2 (AppendUnique x3 ys))) -- not redunant contraint+--     => Widget cmd p s (Which x1)+--     -> Widget cmd p s (Which x2)+--     -> Widget cmd p s (Which x3)+--     -> (Window s () -> Window s () -> Window s () -> Widget cmd p s (Which ys))+--     -> Widget cmd p s (Which zs)+-- withWindow3' x y z f = withWindow3 (diversify <$> x) (diversify <$> y) (diversify <$> z)+--     (\x' y' z' -> fmap diversify $ f x' y' z')++-- windowWith' :: (ChooseBoth xs ys zs)+--     => (Window s () -> Widget cmd p s (Which ys))+--     -> Widget cmd p s (Which xs)+--     -> Widget cmd p s (Which zs)+-- windowWith' f m = withWindow' m f++-- windowWith2' ::+--     ( Diversify x1 zs+--     , Diversify x2 zs+--     , Diversify ys zs+--     , zs ~ AppendUnique x1 (AppendUnique x2 ys)) -- not redunant contraint+--     => (Window s () -> Window s () -> Widget cmd p s (Which ys))+--     -> Widget cmd p s (Which x1)+--     -> Widget cmd p s (Which x2)+--     -> Widget cmd p s (Which zs)+-- windowWith2' f x y = withWindow2' x y f++-- windowWith3' ::+--     ( Diversify x1 zs+--     , Diversify x2 zs+--     , Diversify x3 zs+--     , Diversify ys zs+--     , zs ~ AppendUnique x1 (AppendUnique x2 (AppendUnique x3 ys))) -- not redunant contraint+--     => (Window s () -> Window s () -> Window s () -> Widget cmd p s (Which ys))+--     -> Widget cmd p s (Which x1)+--     -> Widget cmd p s (Which x2)+--     -> Widget cmd p s (Which x3)+--     -> Widget cmd p s (Which zs)+-- windowWith3' f x y z = withWindow3' x y z f

@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++module Glazier.React.Window where++import Control.Lens+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Trans.RWS.Strict+import qualified Data.DList as DL+import qualified Data.Map.Strict as M+import qualified GHCJS.Foreign.Callback as J+import qualified GHCJS.Types as J+import Glazier.React.Component+import Glazier.React.Markup+import Glazier.React.ReactId+import Glazier.React.ReadIORef+import Glazier.React.Scene+import Glazier.React.Subject+import qualified JavaScript.Extras as JE++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)+import Data.Semigroup+#endif++-- The @s@ can be magnified with 'magnifiedScene'+type Window s = RWST (Scene s) () (DL.DList ReactMarkup) ReadIORef++-- type SceneDisplay x s r = Display (Scene x s) r+----------------------------------------------------------------------------------++getListeners :: MonadReader (Scene s) m => ReactId -> m [JE.Property]+getListeners ri = do+    ls <- view (_plan._elementals.ix ri._reactListeners.to M.toList)+    pure $ (\(n, (cb, _)) -> (n, JE.toJSR cb)) <$> ls++-- | Interactive version of 'lf' using listeners obtained from the 'Plan' for a 'ElementalId'.+lf' :: (MonadReader (Scene s) m, MonadState (DL.DList ReactMarkup) m)+    => ReactId+    -> JE.JSRep -- ^ eg "div" or "input"+    -> DL.DList JE.Property+    -> m ()+lf' ri n props = do+    ls <- getListeners ri+    lf n (props <> DL.fromList ls)++-- | Interactive version of 'bh'+bh' :: (MonadReader (Scene s) m, MonadState (DL.DList ReactMarkup) m)+    => ReactId+    -> JE.JSRep+    -> DL.DList JE.Property+    -> m r+    -> m r+bh' ri n props childs = do+    ls <- getListeners ri+    bh n (props <> DL.fromList ls) childs++bindListenerContext :: JE.JSRep -> J.Callback (J.JSVal -> J.JSVal -> IO ()) -> JE.JSRep+bindListenerContext = js_bindListenerContext++displaySubject :: (MonadTrans t, MonadState (DL.DList ReactMarkup) (t ReadIORef)) => Subject s -> t ReadIORef ()+displaySubject sbj = do+    scn <- lift (doReadIORef (sceneRef sbj))+    let scb = scn ^. _plan._shimCallbacks+        renderCb = shimRender scb+        mountedCb = shimMounted scb+        renderedCb = shimRendered scb+        refCb = shimRef scb+        ri = scn ^. _plan._planId+    -- These are the callbacks on the 'ShimComponent'+    -- See jsbits/react.js++    lf (JE.toJSR shimComponent)+        [ ("render", JE.toJSR renderCb)+        , ("mounted", JE.toJSR mountedCb)+        , ("rendered", JE.toJSR renderedCb)+        , ("ref", JE.toJSR refCb)+        , ("key", JE.toJSR ri)+        ]++#ifdef __GHCJS__++foreign import javascript unsafe+    "$r = function(j) { $2($1, j) };"+    js_bindListenerContext :: JE.JSRep -> J.Callback (J.JSVal -> J.JSVal -> IO ()) -> JE.JSRep++#else++js_bindListenerContext :: JE.JSRep -> J.Callback (J.JSVal -> J.JSVal -> IO ()) -> JE.JSRep+js_bindListenerContext _ _ = JE.JSRep J.nullRef+++#endif