packages feed

glazier-react (empty) → 0.1.0.0

raw patch · 16 files changed

+1102/−0 lines, 16 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, disposable, dlist, free, ghcjs-base, ghcjs-base-stub, glazier, javascript-extras, lens, mmorph, mtl, pipes-concurrency, profunctors, semigroupoids, stm, text, transformers, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Louis Pan (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Louis Pan nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+[![Hackage](https://img.shields.io/hackage/v/glazier-react.svg)](https://hackage.haskell.org/package/glazier-react)++See https://github.com/louispan/glazier-react-examples for a example apps, include a fully-featured TodoMVC.++See https://github.com/louispan/glazier-react-widget for reusable widget library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ glazier-react.cabal view
@@ -0,0 +1,59 @@+name:                glazier-react+version:             0.1.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.+homepage:            https://github.com/louispan/glazier-react#readme+license:             BSD3+license-file:        LICENSE+author:              Louis Pan+maintainer:          louis@pan.me+copyright:           2017 Louis Pan+category:            Web, FRP+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  js-sources:          jsbits/react.js+                       jsbits/registry.js+  exposed-modules:     Glazier.React.Command+                       Glazier.React.Command.Run+                       Glazier.React.Component+                       Glazier.React.Element+                       Glazier.React.Event+                       Glazier.React.Maker+                       Glazier.React.Maker.Run+                       Glazier.React.Markup+                       Glazier.React.ReactDOM+                       Glazier.React.Widget+  build-depends:       base >= 4.7 && < 5+                     , containers >= 0.5 && < 0.6+                     , deepseq >= 1.4 && < 1.5+                     , disposable >= 0.2 && < 1+                     , dlist >= 0.8 && < 0.9+                     , free >= 4.12 && < 5+                     , glazier >= 0.10 && < 1+                     , javascript-extras >= 0.2 && < 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+  default-language:    Haskell2010+  default-extensions:  ApplicativeDo+  ghc-options:         -Wall+  if impl(ghcjs)+    build-depends: ghcjs-base+  if !impl(ghcjs)+    build-depends: ghcjs-base-stub >= 0.1.0.1 && < 1++source-repository head+  type:     git+  location: https://github.com/louispan/glazier-react
+ jsbits/react.js view
@@ -0,0 +1,53 @@+// 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';++// // 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 {++//     componentDidUpdate() {+//         if (this.props['componentDidUpdate'])+//             this.props['componentDidUpdate'](this.state);+//     }++//     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;++    return cl;+}++// Convert a list of ReactElements into a single ReactElement+function hgr$mkCombinedElements(elements) {+    if (elements && elements.constructor === Array) {+        if (elements.length === 0) {+            return null;+        }+        else if (elements.length === 1) {+            return elements[0];+        }+        else {+            return React.createElement('div', null, elements);+        }+    }+    return null;+}
+ jsbits/registry.js view
@@ -0,0 +1,61 @@+// The registry is like a simplified NodeJS EventEmitter.+// This is used so that the props can be assigned from Haskell+// and retrieved via Javascript.+// It is required to interoperate with foreign React components which+// contains haskell components.+// A Haskell-only React app will not need this.+function hgr$registry() {+    // private++    // Using closures to hide data: http://www.crockford.com/javascript/private.html+    const handlers = {};++    // a copy of Lodash's omit, to copy dictionary except for one key+    function omit(obj, omitKey) {+        return Object.keys(obj).reduce(function(result, key) {+            if(key !== omitKey) {+                result[key] = obj[key];+            }+            return result;+        }, {});+    }++    // privileged public++    // This is used from javascript to be called back for named triggers.+    // returns a unregister function.+    // NB. this['method'] (instead of this.listen) protects against minification.+    this['listen'] = function(name, listener) {+        if (!handlers[name])+            handlers[name] = { nextIndex: 0, listeners: {} };++        var i = handlers[name].nextIndex;+        handlers[name].nextIndex += 1;+        handlers[name].listeners[i] = listener;+        var unregister = function() {+            handlers[name] = omit(handlers[name], i);+        };+        return unregister;+    };++    // This is used from haskell to notify all javascript listeners.+    // returns a list in an arbitrary order of the results from each listener.+    this['shout'] = function(name, data) {+        const ret = []+        if (handlers[name]) {+            // iterate using copy of keys to safeguard against listeners added/removed+            // during callbacks.+            for (const key of Object.keys(handlers[name].listeners)) {+                const listener = handlers[name].listeners[key];+                if (listener) {+                    ret.push(listener(data));+                }+            }+        }+        return ret;+    }++    this['makeName'] = function(names) {+        return arr.join('#');+    }+}
+ src/Glazier/React/Command.hs view
@@ -0,0 +1,27 @@+{-# 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` maxBound) + 1)+    i <- JE.toJS <$> use frameNum+    r <- use componentRef+    sm <- get+    pure $ fcmd sm [("frameNum", i)] r
+ src/Glazier/React/Command/Run.hs view
@@ -0,0 +1,35 @@+{-# 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.Widget as R+import qualified JavaScript.Extras as JE+import qualified JavaScript.Object as JO++componentSetState :: R.HasSuperModel sm g m => sm -> [JE.Property] -> J.JSVal -> IO ()+componentSetState sm props j = do+    let gm = sm ^. R.gModel+        mm = sm ^. R.mModel+    void $ swapMVar mm gm+    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
+ src/Glazier/React/Component.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}++module Glazier.React.Component+    ( ReactComponent+    , mkComponent+    ) where++import qualified Control.Disposable as CD+import qualified GHCJS.Types as J+import qualified GHCJS.Marshal.Pure as J+import qualified JavaScript.Extras.Recast 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
+ src/Glazier/React/Element.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | 'Lucid.HtmlT' inspired monad for creating 'ReactElement's+module Glazier.React.Element+    ( ReactElement+    , unsafeCoerceElement+    , mkBranchElement+    , mkLeafElement+    , textElement+    , mkCombinedElements+    ) where++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++newtype ReactElement = ReactElement J.JSVal+instance J.IsJSVal ReactElement+instance J.PToJSVal ReactElement where+    pToJSVal = J.jsval+instance JE.ToJS 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+-- and is marked unsafe as a reminder that the coersion is unchecked.+-- 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++-- | Create a react element (with children) from a HashMap of properties+mkBranchElement :: J.JSVal -> [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 :: J.JSVal -> [JE.Property] -> IO ReactElement+mkLeafElement n props =+    js_mkLeafElement n (JE.fromProperties props)++-- | Not an IO action because JSString is immutable+textElement :: J.JSString -> ReactElement+textElement = js_textElement++-- | React only allows a single top most element.+-- Provide a handly function to wrap a list of ReactElements inside a 'div' if required.+-- If there is only one element in the list, then nothing is changed.+mkCombinedElements :: [ReactElement] -> IO ReactElement+mkCombinedElements xs = js_mkCombinedElements (JA.fromList $ JE.toJS <$> xs)++#ifdef __GHCJS__++-- | 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.+foreign import javascript unsafe+    "$r = React.createElement($1, $2, $3);"+    js_mkBranchElement :: J.JSVal -> JO.Object -> JA.JSArray -> IO ReactElement++foreign import javascript unsafe+    "$r = React.createElement($1, $2);"+    js_mkLeafElement :: J.JSVal -> JO.Object -> IO ReactElement++foreign import javascript unsafe+    "$r = $1;"+    js_textElement :: J.JSString -> ReactElement++-- | Wrap a list of ReactElements inside a 'div'+foreign import javascript unsafe+    "$r = hgr$mkCombinedElements($1);"+    js_mkCombinedElements :: JA.JSArray -> IO ReactElement++#else++-- | 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 :: J.JSVal -> JO.Object -> JA.JSArray -> IO ReactElement+js_mkBranchElement _ _ _ = pure (ReactElement J.nullRef)++js_mkLeafElement :: J.JSVal -> JO.Object -> IO ReactElement+js_mkLeafElement _ _ =  pure (ReactElement J.nullRef)++js_textElement :: J.JSString -> ReactElement+js_textElement _ = ReactElement J.nullRef++js_mkCombinedElements :: JA.JSArray -> IO ReactElement+js_mkCombinedElements _ = pure (ReactElement J.nullRef)++#endif
+ src/Glazier/React/Event.hs view
@@ -0,0 +1,330 @@+{-# 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.Recast 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 = pure . Just $ DOMEventTarget a+    fromJS _ = pure 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 = pure . Just $ DOMEvent a+    fromJS _ = pure 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 = pure . Just $ SyntheticEvent a+    fromJS _ = pure 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.+-- 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'.+-- The reason of this 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+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++parseEvent :: SyntheticEvent -> IO Event+parseEvent (SyntheticEvent evt) =+    pure $ 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 -> IO (Maybe MouseEvent)+parseMouseEvent (SyntheticEvent evt) | js_isMouseEvent (js_unsafeProperty evt "nativeEvent") = pure $ 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 = pure 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 -> IO (Maybe KeyboardEvent)+parseKeyboardEvent (SyntheticEvent evt) | js_isKeyboardEvent (js_unsafeProperty evt "nativeEvent") = pure $ 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 = pure 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
+ src/Glazier/React/Maker.hs view
@@ -0,0 +1,72 @@+{-# 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.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.Widget 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+    MkEmptyMModel+        :: (R.MModel gsk mdl -> nxt)+        -> Maker act nxt+    MkRenderer+        :: R.MModel gsk mdl+        -> (J.JSVal -> G.WindowT (R.GModel gsk mdl) (R.ReactMl) ())+        -> (J.Callback (J.JSVal -> IO J.JSVal) -> nxt)+        -> Maker act nxt+    PutMModel+        :: R.MModel gsk mdl+        -> R.GModel gsk mdl+        -> nxt+        -> Maker act nxt+    GetComponent+        :: (R.ReactComponent -> nxt)+        -> Maker act nxt++instance Functor (Maker act) where+  fmap f (MkHandler handler g) = MkHandler handler (f . g)+  fmap f (MkEmptyMModel g) = MkEmptyMModel (f . g)+  fmap f (MkRenderer ms render g) = MkRenderer ms render (f . g)+  fmap f (PutMModel ms s x) = PutMModel ms s (f x)+  fmap f (GetComponent g) = GetComponent (f . g)++makeFree ''Maker++-- | Allows changing the action type of Maker+mapAction :: (act -> act') -> Maker act a -> Maker act' a+mapAction f (MkHandler handler g) = MkHandler (\v -> fmap f <$> handler v) g+mapAction _ (MkEmptyMModel g) = MkEmptyMModel g+mapAction _ (MkRenderer ms render g) = MkRenderer ms render g+mapAction _ (PutMModel ms s x) = PutMModel ms s x+mapAction _ (GetComponent g) = GetComponent g++mkSuperModel+    :: MonadFree (Maker act) m+    => (R.MModel gsk mdl -> m gsk)+    -> (gsk -> R.GModel gsk mdl)+    -> m (R.SuperModel gsk mdl)+mkSuperModel makeGasket createGModel = do+    mm <- mkEmptyMModel+    g <- makeGasket mm+    let gm = createGModel g+    putMModel mm gm+    pure (R.SuperModel mm gm)
+ src/Glazier/React/Maker/Run.hs view
@@ -0,0 +1,46 @@+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 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 :: R.ReactComponent -> PC.Output act -> R.Maker act (IO a) -> IO a+run _ output (R.MkHandler handler g) = mkActionCallback output handler >>= g++run _ _ (R.MkEmptyMModel g) = newEmptyMVar >>= g++run _ _ (R.MkRenderer ms render g) = J.syncCallback1' (onRender ms render') >>= g+  where+    render' v = hoist (hoist generalize) (render v)++run _ _ (R.PutMModel ms s g) = putMVar ms s >> g++run component _ (R.GetComponent g) = g component
+ src/Glazier/React/Markup.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | 'Lucid.HtmlT' inspired monad for creating 'ReactElement's+module Glazier.React.Markup+    ( ReactMarkup(..)+    , BranchParam(..)+    , LeafParam(..)+    , fromMarkup+    , ReactMlT(..)+    , ReactMl+    , fromElement+    , toElements+    , markedWindow+    , markedElements+    , markedElement+    , txt+    , lf+    , bh+    ) 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 GHCJS.Types as J+import qualified Glazier as G+import qualified Glazier.React.Element as R+import qualified JavaScript.Extras as JE++-- | The parameters required to create a branch ReactElement with children+data BranchParam = BranchParam+    J.JSVal -- ^ Can be a react component type as well as html name+    [JE.Property]+    (D.DList ReactMarkup) -- ^ children++-- | The parameters required to create a leaf ReactElement (no children)+data LeafParam = LeafParam+    J.JSVal -- ^ Can be a react component type as well as html name+    [JE.Property]++data ReactMarkup+    = ElementMarkup R.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'++fromMarkup (LeafMarkup (LeafParam n p)) = R.mkLeafElement n p++fromMarkup (TextMarkup str) = pure $ R.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++makeWrapped ''ReactMlT++instance (Semigroup a, Monad m) => Semigroup (ReactMlT m a) where+    (<>) = liftA2 (<>)++instance (Monoid a, Monad m) => Monoid (ReactMlT m a) where+    mempty = pure mempty+    mappend = liftA2 mappend++-- | 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)++-- | 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 .)++-- | 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++-- | 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 text content+txt :: Applicative m => J.JSString -> ReactMlT m ()+txt n = ReactMlT . StateT $ \xs -> pure ((), xs `D.snoc` TextMarkup n)++-- | For the contentless elements: eg 'br_'+lf :: Applicative m => J.JSVal -> [JE.Property] -> ReactMlT m ()+lf n props = ReactMlT . StateT $ \xs -> pure ((), xs `D.snoc` LeafMarkup (LeafParam n props))++-- | For the contentful elements: eg 'div_'+bh :: Functor m => J.JSVal -> [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'))
+ src/Glazier/React/ReactDOM.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}++-- | Contains commons utilities when defining your own widget+module Glazier.React.ReactDOM+  ( render+  ) where++import qualified GHCJS.Types as J++-- | 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++#ifdef __GHCJS__++foreign import javascript unsafe+  "ReactDOM.render($1, $2);"+  js_render :: J.JSVal -> J.JSVal -> IO ()++#else++js_render :: J.JSVal -> J.JSVal -> IO ()+js_render _ _ = pure ()++#endif
+ src/Glazier/React/Widget.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Glazier.React.Widget where++import Control.Concurrent.MVar+import qualified Control.Disposable as CD+import Control.Lens+import qualified GHC.Generics as G++class HasWidgetGasket c gsk | c -> gsk where+    widgetGasket :: Lens' c gsk++class HasWidgetModel c mdl | c -> mdl where+    widgetModel :: Lens' c mdl++data GModel gsk mdl = GModel+    { _widgetGasket :: gsk+    , _widgetModel :: mdl+    } deriving (G.Generic)++instance (CD.Disposing gsk, CD.Disposing mdl) => CD.Disposing (GModel gsk mdl)++instance HasWidgetGasket (GModel gsk mdl) gsk where+    widgetGasket f (GModel gsk mdl) = fmap (\gsk' -> GModel gsk' mdl) (f gsk)+    {-# INLINE widgetGasket #-}++instance HasWidgetModel (GModel gsk mdl) mdl where+    widgetModel f (GModel gsk mdl) = fmap (\mdl' -> GModel gsk mdl') (f mdl)+    {-# INLINE widgetModel #-}++class HasGModel c gsk mdl | c -> gsk mdl where+    gModel :: Lens' c (GModel gsk mdl)++instance HasGModel (GModel gsk mdl) gsk mdl where+    gModel = id++type MModel gsk mdl = MVar (GModel gsk mdl)++class HasMModel c gsk mdl | c -> gsk mdl where+    mModel :: Lens' c (MModel gsk mdl)++instance HasMModel (MModel gsk mdl) gsk mdl where+    mModel = id++data SuperModel gsk mdl = SuperModel+    { _mModel :: MModel gsk mdl+    , _gModel :: GModel gsk mdl+    } deriving (G.Generic)++instance CD.Disposing (GModel gsk mdl) => CD.Disposing (SuperModel gsk mdl) where+    disposing s = CD.disposing $ s ^. gModel++class (HasMModel c gsk mdl, HasGModel c gsk mdl) => HasSuperModel c gsk mdl | c -> gsk mdl where+    superModel :: Lens' c (SuperModel gsk mdl)++instance HasSuperModel (SuperModel gsk mdl) gsk mdl where+    superModel = id++instance HasMModel (SuperModel gsk mdl) gsk mdl where+    mModel f (SuperModel mm gm) = fmap (\mm' -> SuperModel mm' gm) (f mm)+    {-# INLINE mModel #-}++instance HasGModel (SuperModel gsk mdl) gsk mdl where+    gModel f (SuperModel mm gm) = fmap (\gm' -> SuperModel mm gm') (f gm)+    {-# INLINE gModel #-}++class IsWidget w where+    -- The input to Gadget+    type WidgetAction w :: *++    -- The output of Gadget+    type WidgetCommand w :: *++    -- The pure model for state and rendering+    type WidgetModel w :: *++    -- Callbacks and data required for interfacing with react.+    type WidgetGasket w :: *++type WidgetGModel w = GModel (WidgetGasket w) (WidgetModel w)+type WidgetMModel w = MModel (WidgetGasket w) (WidgetModel w)+type WidgetSuperModel w = SuperModel (WidgetGasket w) (WidgetModel w)