packages feed

react-haskell 1.2.0.0 → 1.3.0.0

raw patch · 14 files changed

+1520/−522 lines, 14 filesdep +deepseqdep +lens-familydep +voiddep ~basedep ~haste-lib

Dependencies added: deepseq, lens-family, void

Dependency ranges changed: base, haste-lib

Files

+ lib/bezier.js view
@@ -0,0 +1,156 @@+/**+ * BezierEasing - use bezier curve for transition easing function+ * by Gaëtan Renaudeau 2014 – MIT License+ *+ * Credits: is based on Firefox's nsSMILKeySpline.cpp+ * Usage:+ * var spline = BezierEasing(0.25, 0.1, 0.25, 1.0)+ * spline(x) => returns the easing value | x must be in [0, 1] range+ *+ */+(function (definition) {+  if (typeof exports === "object") {+    module.exports = definition();+  } else if (typeof define === 'function' && define.amd) {+    define([], definition);+  } else {+    window.BezierEasing = definition();+  }+}(function () {+  var global = this;++  // These values are established by empiricism with tests (tradeoff: performance VS precision)+  var NEWTON_ITERATIONS = 4;+  var NEWTON_MIN_SLOPE = 0.001;+  var SUBDIVISION_PRECISION = 0.0000001;+  var SUBDIVISION_MAX_ITERATIONS = 10;++  var kSplineTableSize = 11;+  var kSampleStepSize = 1.0 / (kSplineTableSize - 1.0);++  var float32ArraySupported = 'Float32Array' in global;++  function BezierEasing (mX1, mY1, mX2, mY2) {+    // Validate arguments+    if (arguments.length !== 4) {+      throw new Error("BezierEasing requires 4 arguments.");+    }+    for (var i=0; i<4; ++i) {+      if (typeof arguments[i] !== "number" || isNaN(arguments[i]) || !isFinite(arguments[i])) {+        throw new Error("BezierEasing arguments should be integers.");+      } +    }+    if (mX1 < 0 || mX1 > 1 || mX2 < 0 || mX2 > 1) {+      throw new Error("BezierEasing x values must be in [0, 1] range.");+    }++    var mSampleValues = float32ArraySupported ? new Float32Array(kSplineTableSize) : new Array(kSplineTableSize);+   +    function A (aA1, aA2) { return 1.0 - 3.0 * aA2 + 3.0 * aA1; }+    function B (aA1, aA2) { return 3.0 * aA2 - 6.0 * aA1; }+    function C (aA1)      { return 3.0 * aA1; }+   +    // Returns x(t) given t, x1, and x2, or y(t) given t, y1, and y2.+    function calcBezier (aT, aA1, aA2) {+      return ((A(aA1, aA2)*aT + B(aA1, aA2))*aT + C(aA1))*aT;+    }+   +    // Returns dx/dt given t, x1, and x2, or dy/dt given t, y1, and y2.+    function getSlope (aT, aA1, aA2) {+      return 3.0 * A(aA1, aA2)*aT*aT + 2.0 * B(aA1, aA2) * aT + C(aA1);+    }++    function newtonRaphsonIterate (aX, aGuessT) {+      for (var i = 0; i < NEWTON_ITERATIONS; ++i) {+        var currentSlope = getSlope(aGuessT, mX1, mX2);+        if (currentSlope === 0.0) return aGuessT;+        var currentX = calcBezier(aGuessT, mX1, mX2) - aX;+        aGuessT -= currentX / currentSlope;+      }+      return aGuessT;+    }++    function calcSampleValues () {+      for (var i = 0; i < kSplineTableSize; ++i) {+        mSampleValues[i] = calcBezier(i * kSampleStepSize, mX1, mX2);+      }+    }++    function binarySubdivide (aX, aA, aB) {+      var currentX, currentT, i = 0;+      do {+        currentT = aA + (aB - aA) / 2.0;+        currentX = calcBezier(currentT, mX1, mX2) - aX;+        if (currentX > 0.0) {+          aB = currentT;+        } else {+          aA = currentT;+        }+      } while (Math.abs(currentX) > SUBDIVISION_PRECISION && ++i < SUBDIVISION_MAX_ITERATIONS);+      return currentT;+    }++    function getTForX (aX) {+      var intervalStart = 0.0;+      var currentSample = 1;+      var lastSample = kSplineTableSize - 1;++      for (; currentSample != lastSample && mSampleValues[currentSample] <= aX; ++currentSample) {+        intervalStart += kSampleStepSize;+      }+      --currentSample;++      // Interpolate to provide an initial guess for t+      var dist = (aX - mSampleValues[currentSample]) / (mSampleValues[currentSample+1] - mSampleValues[currentSample]);+      var guessForT = intervalStart + dist * kSampleStepSize;++      var initialSlope = getSlope(guessForT, mX1, mX2);+      if (initialSlope >= NEWTON_MIN_SLOPE) {+        return newtonRaphsonIterate(aX, guessForT);+      } else if (initialSlope === 0.0) {+        return guessForT;+      } else {+        return binarySubdivide(aX, intervalStart, intervalStart + kSampleStepSize);+      }+    }++    var _precomputed = false;+    function precompute() {+      _precomputed = true;+      if (mX1 != mY1 || mX2 != mY2)+        calcSampleValues();+    }++    var f = function (aX) {+      if (!_precomputed) precompute();+      if (mX1 === mY1 && mX2 === mY2) return aX; // linear+      // Because JavaScript number are imprecise, we should guarantee the extremes are right.+      if (aX === 0) return 0;+      if (aX === 1) return 1;+      return calcBezier(getTForX(aX), mY1, mY2);+    };++    f.getControlPoints = function() { return [{ x: mX1, y: mY1 }, { x: mX2, y: mY2 }]; };++    var args = [mX1, mY1, mX2, mY2];+    var str = "BezierEasing("+args+")";+    f.toString = function () { return str; };++    var css = "cubic-bezier("+args+")";+    f.toCSS = function () { return css; };++    return f;+  }++  // CSS mapping+  BezierEasing.css = {+    "ease":        BezierEasing(0.25, 0.1, 0.25, 1.0),+    "linear":      BezierEasing(0.00, 0.0, 1.00, 1.0),+    "ease-in":     BezierEasing(0.42, 0.0, 1.00, 1.0),+    "ease-out":    BezierEasing(0.00, 0.0, 0.58, 1.0),+    "ease-in-out": BezierEasing(0.42, 0.0, 0.58, 1.0)+  };++  return BezierEasing;++}));
lib/stubs.js view
@@ -51,15 +51,60 @@ function js_set_field_True(obj, field, value) {obj[field] = true;} function js_set_field_False(obj, field, value) {obj[field] = false;} -function js_set_onClick(cb, attrs) {attrs.onClick = function(e) {B(A(cb,[[0,e],0]));};}-function js_set_onDoubleClick(cb, attrs) {attrs.onDoubleClick = function(e) {B(A(cb,[[0,e],0]));};}-function js_set_onChange(cb, attrs) {attrs.onChange = function(e) {B(A(cb,[[0,e],0]));};}-function js_set_onKeyUp(cb, attrs) {attrs.onKeyUp = function(e) {B(A(cb,[[0,e],0]));};}-function js_set_onKeyPress(cb, attrs) {attrs.onKeyPress = function(e) {B(A(cb,[[0,e],0]));};}-function js_set_onKeyDown(cb, attrs) {attrs.onKeyDown = function(e) { B(A(cb,[[0,e],0]));};}-function js_set_onBlur(cb, attrs) {attrs.onBlur = function(e) {B(A(cb,[[0,e],0]));};}-function js_set_onMouseEnter(cb, attrs) {attrs.onMouseEnter = function(e) {B(A(cb,[[0,e],0]));};}-function js_set_onMouseLeave(cb, attrs) {attrs.onMouseLeave = function(e) {B(A(cb,[[0,e],0]));};}+function js_set_onClick(cb, attrs) {+    attrs.onClick = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}+function js_set_onDoubleClick(cb, attrs) {+    attrs.onDoubleClick = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}+function js_set_onChange(cb, attrs) {+    attrs.onChange = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}+function js_set_onKeyUp(cb, attrs) {+    attrs.onKeyUp = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}+function js_set_onKeyPress(cb, attrs) {+    attrs.onKeyPress = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}+function js_set_onKeyDown(cb, attrs) {+    attrs.onKeyDown = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}+function js_set_onBlur(cb, attrs) {+    attrs.onBlur = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}+function js_set_onMouseEnter(cb, attrs) {+    attrs.onMouseEnter = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}+function js_set_onMouseLeave(cb, attrs) {+    attrs.onMouseLeave = function(e) {+        e.persist();+        B(A(cb,[[0,e],0]));+    };+}  function js_React_DOM(tagName, attrs) {return React.DOM[tagName](attrs);} @@ -240,4 +285,54 @@         raw.screenX,         raw.screenY,     ];+}++// polyfill from http://www.paulirish.com/2011/requestanimationframe-for-smart-animating/+(function() {+    var lastTime = 0;+    var vendors = ['webkit', 'moz'];+    for(var x = 0; x < vendors.length && !window.requestAnimationFrame; ++x) {+        window.requestAnimationFrame = window[vendors[x]+'RequestAnimationFrame'];+        window.cancelAnimationFrame =+          window[vendors[x]+'CancelAnimationFrame'] || window[vendors[x]+'CancelRequestAnimationFrame'];+    }++    if (!window.requestAnimationFrame)+        window.requestAnimationFrame = function(callback, element) {+            var currTime = new Date().getTime();+            var timeToCall = Math.max(0, 16 - (currTime - lastTime));+            var id = window.setTimeout(function() { callback(currTime + timeToCall); },+              timeToCall);+            lastTime = currTime + timeToCall;+            return id;+        };++    if (!window.cancelAnimationFrame)+        window.cancelAnimationFrame = function(id) {+            clearTimeout(id);+        };+}());++function js_raf(cb) {+    return window.requestAnimationFrame(function(time) {+        B(A(cb,[[0,time],0]));+    });+}++function js_createClass(render, setState) {+    return React.createClass({+        render: render,+    });+}++function js_bezier(x0, y0, x1, y1, x) {+    return BezierEasing(x0, y0, x1, y1)(x);+}++function js_render(e, r){+    React.render(e, r);+}++function js_cancelRaf(id) {+    window.cancelAnimationFrame(id); }
react-haskell.cabal view
@@ -1,8 +1,8 @@ name:                react-haskell-version:             1.2.0.0+version:             1.3.0.0 synopsis:            Haskell React bindings description:-  This package provides high level bindings to Facebook's <facebook.github.io/react/ React> library, meant for use with <haste-lang.org Haste>.+  This package provides high level bindings to Facebook's <http://facebook.github.io/react/ React> library, meant for use with <http://haste-lang.org Haste>.   .   React is a JavaScript library for building user interfaces. React (and React-Haskell) is focused on just UI - it's not a framework.   .@@ -10,11 +10,24 @@   .   Here's a simple example which demonstrates basic elements, attributes, state, and handling events.   .-  > statefulView :: StatefulReact JSString ()-  > statefulView = div_ <! class_ "container" $ do-  >     str <- getState-  >     input_ <! value_ str-  >            <! onChange (\_ evt -> toJSStr $ map toUpper $ fromJSStr $ targetValue evt)+  > -- We're creating a class with JSString state+  > data Example+  > instance ReactKey Example where+  >     type ClassState Example = JSString+  >     type AnimationState Example = ()+  >     type Signal Example = JSString+  >+  > -- updating to the new state without animation+  > transition :: JSString -> JSString -> (JSString, [AnimConfig Example])+  > transition oldState signal = (signal, [])+  >+  > view :: JSString -> React Example ()+  > view str = div_ [ class_ "container" ] $ do+  >     input_ [ value_ str, onChange (Just . targetValue) ]+  >+  > main :: IO ()+  > main = withElem "id" $ \elem ->+  >     render elem =<< createClass view transition "" () [] license:             MIT license-file:        LICENSE author:              Joel Burget@@ -27,7 +40,7 @@ bug-reports: https://github.com/joelburget/react-haskell/issues  data-dir: lib-data-files: stubs.js+data-files: stubs.js, bezier.js  flag haste-inst   description: Built with haste-inst/hastec@@ -40,25 +53,37 @@ library   exposed-modules: React   other-modules:+    React.Anim,     React.Attrs,+    React.Class,     React.Elements,     React.Events,     React.Imports,+    React.Interpret,+    React.Local,+    React.Render,     React.Types   other-extensions:+    CPP,     FlexibleInstances,     FlexibleContexts,     ForeignFunctionInterface,+    GADTs,     GeneralizedNewtypeDeriving,+    LambdaCase,     MultiParamTypeClasses,+    NamedFieldPuns,     OverloadedStrings   build-depends:-    base >= 4.5 && < 4.7,+    base >= 4.5 && < 5,     transformers,-    monads-tf+    monads-tf,+    deepseq,+    lens-family,+    void == 0.7   if flag(haste-inst)     build-depends:-      haste-lib >= 0.4 && <0.5+      haste-lib >= 0.4 && <0.6   else     build-depends:       haste-compiler
src/React.hs view
@@ -1,136 +1,58 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, LambdaCase,-  MultiParamTypeClasses, FlexibleContexts, Rank2Types #-}-+-- |+-- Module      :  React+-- Copyright   :  (C) 2014-15 Joel Burget+-- License     :  MIT+-- Maintainer  :  Joel Burget <joelburget@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable module React     ( module X-    , getDomNode-    , render-    , nest-    , pureNest-    ) where -import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class-import Data.Functor.Identity-import Data.Monoid-import Data.String--import Haste hiding (fromString)-import Haste.Foreign-import Haste.JSON-import Haste.Prim--import Prelude hiding (div)--import React.Attrs as X-import React.Elements as X-import React.Events as X-import React.Imports-import React.Types as X---- TODO--- * restricted monads--- * store elem in monad--- * escaping / dangerouslySetInnerHTML--element :: (JSString -> RawAttrs -> ReactArray -> IO ForeignNode)-        -> JSString-        -> Attrs-        -> [(RawEvent -> IO (), EvtType)]-        -> [ForeignNode]-        -> IO ForeignNode-element constructor name attrs handlers content = do-    attr <- js_empty_object-    mapM_ (setField attr) attrs-    mapM_ (makeHandler attr) handlers--    children <- js_ReactArray_empty-    mapM_ (js_ReactArray_push children) content-    constructor name attr children--makeHandler :: RawAttrs -> (RawEvent -> IO (), EvtType) -> IO ()-makeHandler obj (handle, ChangeEvt) = js_set_onChange (toPtr handle) obj-makeHandler obj (handle, KeyDownEvt) = js_set_onKeyDown (toPtr handle) obj-makeHandler obj (handle, KeyPressEvt) = js_set_onKeyPress (toPtr handle) obj-makeHandler obj (handle, KeyUpEvt) = js_set_onKeyUp (toPtr handle) obj-makeHandler obj (handle, ClickEvt) = js_set_onClick (toPtr handle) obj-makeHandler obj (handle, DoubleClickEvt) = js_set_onDoubleClick (toPtr handle) obj-makeHandler obj (handle, MouseEnterEvt) = js_set_onMouseEnter (toPtr handle) obj-makeHandler obj (handle, MouseLeaveEvt) = js_set_onMouseLeave (toPtr handle) obj--voidElement :: (JSString -> RawAttrs -> IO ForeignNode)-            -> JSString-            -> Attrs-            -> [(RawEvent -> IO (), EvtType)]-            -> IO ForeignNode-voidElement constructor name attrs handlers =-    element (\n a c -> constructor n a) name attrs handlers []--setField :: RawAttrs -> (JSString, JSON) -> IO ()-setField attr (fld, Str v) = js_set_field_String attr fld v-setField attr (fld, Dict vs) = do-    subObj <- js_empty_object-    mapM_ (setField subObj) vs-    js_set_field_Obj attr fld subObj-setField attr (fld, Num v) = js_set_field_Double attr fld v-setField attr (fld, Bool True) = js_set_field_True attr fld-setField attr (fld, Bool False) = js_set_field_False attr fld---- TODO this seems wrong-setField attr (fld, Null) = return ()---- TODO figure out what to do with this-getDomNode :: ForeignNode -> IO (Maybe Elem)-getDomNode r = fmap fromPtr (js_React_getDomNode r)--unStateful :: s-           -> (s -> IO ())-           -> StatefulEventHandler s-           -> (RawEvent -> IO (), EvtType)-unStateful s act (StatefulEventHandler handle ty) = (act . handle s, ty)+    -- React.Anim+    , Color(..)+    , getAnimationState+    , Animatable(..) -- XXX -interpret :: Monad m-          => StatefulReactT s m ()-          -> s-          -> (s -> IO ())-          -> m (IO ForeignNode)-interpret react s cb = do-    ~(child:_, s', ()) <- runStatefulReactT react s-    return $ interpret' s' cb child+    -- React.Class+    , ReactClass()+    , createClass -interpret' :: s-           -> (s -> IO ())-           -> ReactNode s-           -> IO ForeignNode-interpret' s cb = \case-    Parent name as hs children -> do-        children' <- forM children (interpret' s cb)-        let hs' = map (unStateful s cb) hs-        element js_React_DOM_parent name as hs' children'-    Leaf name as hs -> do-        let hs' = map (unStateful s cb) hs-        voidElement js_React_DOM_leaf name as hs'-    Text str -> js_React_DOM_text (toJSStr str)+    -- React.Local+    , locally+    , Narrowing(..) -nest :: Monad m => MockLens a b -> StatefulReactT b m x -> StatefulReactT a m x-nest lens nested = StatefulReactT $ \a -> do-    (nodes, b, x) <- runStatefulReactT nested (mockGet lens a)-    return (map (nodeConvert lens) nodes, mockSet lens b a, x)+    -- React.Render+    , cancelRender+    , render -pureNest :: Monad m => StatefulReactT () m x -> StatefulReactT a m x-pureNest = nest pureLens where-    pureLens :: MockLens a ()-    pureLens f a = const a <$> f ()+    -- React.Types+    , ReactT(..)+    , React+    , ReactKey(AnimationState, ClassState, Signal)+    , RenderHandle(..)+    , AnimConfig(..)+    , Easing(..)+    , EventProperties(..)+    , ModifierKeys(..)+    , MouseEvent(..)+    , KeyboardEvent(..)+    , ChangeEvent(..)+    , FocusEvent(..)+    ) where -render' :: Elem -> ForeignNode -> IO ()-render' = ffi "(function(e,r){React.render(r,e);})"+-- TODO+-- restricted monads+-- store elem in monad+-- escaping / dangerouslySetInnerHTML -render :: s -> Elem -> StatefulReact s () -> IO ()-render s elem r = do-    let cb s' = render s' elem r-    foreignNode <- runIdentity $ interpret r s cb-    render' elem foreignNode+import React.Anim+import React.Class+-- import React.Imports+-- import React.Interpret+import React.Local+import React.Render+import React.Types -renderPureReact :: Elem -> PureReact -> IO ()-renderPureReact = render ()+import React.Attrs as X+import React.Elements as X+import React.Events as X
+ src/React/Anim.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiWayIf,+  FlexibleContexts #-}+module React.Anim where++import Control.Applicative+import Data.IORef+import Data.Monoid++import Haste+import Lens.Family2++import React.Imports+import React.Types+++-- TODO support delays++-- TODO look at velocity++-- TODO also `Floating (Scalar v)` ?+--      Double ~ Scalar v?+-- TODO common pattern:+--      from .+^ (?? *^ (to .-. from))+{-+easingFunc :: (AffineSpace p, v ~ Diff p, VectorSpace v)+           => Easing -> a -> a -> Double -> a+easingFunc Linear from to t = from .+^ (t *^ (to .-. from))+-- easingFunc Linear from to t = alerp from to t+easingFunc EaseInQuad from to t = from .+^ ((t*t) *^ (to .-. from))+easingFunc _ _ _ _ = error "that easing function has not been defined yet"+-}++instance Animatable Double where+    interpolate ease from to t =+        if | t <= 0 -> from+           | t >= 1 -> to+           | otherwise -> from + easeDouble ease t * (to - from)+    animAdd = (+)+    animSub = (-)+    animZero = 0++-- I think this could become Functor if we limit `to` to `animZero`+-- instance (Applicative f, Animatable a) => Animatable (f a) where+--     interpolate ease from to t = interpolate ease <$> from <*> to <*> pure t+--     animAdd = liftA2 animAdd+--     animZero = pure animZero++-- TODO use generics for all tuple instances+instance Animatable () where+    interpolate _ _ _ _ = ()+    animAdd _ _ = ()+    animSub _ _ = ()+    animZero = ()++instance (Animatable a, Animatable b) => Animatable (a, b) where+    interpolate ease (x0, y0) (x1, y1) t =+        (interpolate ease x0 x1 t, interpolate ease y0 y1 t)+    animAdd (x0, y0) (x1, y1) = (x0 `animAdd` x1, y0 `animAdd` y1)+    animSub (x0, y0) (x1, y1) = (x0 `animSub` x1, y0 `animSub` y1)+    animZero = (animZero, animZero)++instance (Animatable a, Animatable b, Animatable c) => Animatable (a, b, c) where+    interpolate ease (x0, y0, z0) (x1, y1, z1) t =+        (interpolate ease x0 x1 t,+         interpolate ease y0 y1 t,+         interpolate ease z0 z1 t)+    animAdd (x0, y0, z0) (x1, y1, z1) =+        (x0 `animAdd` x1,+         y0 `animAdd` y1,+         z0 `animAdd` z1)+    animSub (x0, y0, z0) (x1, y1, z1) =+        (x0 `animSub` x1,+         y0 `animSub` y1,+         z0 `animSub` z1)+    animZero = (animZero, animZero, animZero)++-- TODO use color package+-- | 24-bit colors which can be interpolated.+data Color = Color Int Int Int++instance Animatable Color where+    interpolate ease c1@(Color r0 g0 b0) c2@(Color r1 g1 b1) t =+        let t' = interpolate ease 0 1 t+        in Color (intLerp r0 r1 t') (intLerp g0 g1 t') (intLerp b0 b1 t')+    animAdd (Color r0 g0 b0) (Color r1 g1 b1) =+        Color (r0 + r1) (g0 + g1) (b0 + b1)+    animSub (Color r0 g0 b0) (Color r1 g1 b1) =+        Color (r0 - r1) (g0 - g1) (b0 - b1)+    animZero = (Color 0 0 0)++instance Show Color where+    show (Color r g b) = "rgb" ++ show (r, g, b)++easeInPow :: Int -> Double -> Double+easeInPow pow t = t ^^ pow++easeOutPow :: Int -> Double -> Double+easeOutPow pow t = 1 - easeInPow pow (1 - t)++easeInOutPow :: Int -> Double -> Double+easeInOutPow pow t = if t < 0.5+   then easeInPow pow (t * 2) / 2+   else 1 - easeInPow pow ((1 - t) * 2) / 2++elastic :: Double -> Double+elastic t =+    let p = 0.3+        powFactor = 2 ** (-10 * t)+        sinFactor = sin $ (t - p / 4) * (2 * pi / p)+    in powFactor * sinFactor + 1++easeDouble :: Easing -> Double -> Double+easeDouble Linear t = t++easeDouble EaseInQuad t    = easeInPow 2 t+easeDouble EaseOutQuad t   = easeOutPow 2 t+easeDouble EaseInOutQuad t = easeInOutPow 2 t++easeDouble EaseInCubic t    = easeInPow 3 t+easeDouble EaseOutCubic t   = easeOutPow 3 t+easeDouble EaseInOutCubic t = easeInOutPow 3 t++easeDouble EaseInQuart t    = easeInPow 4 t+easeDouble EaseOutQuart t   = easeOutPow 4 t+easeDouble EaseInOutQuart t = easeInOutPow 4 t++easeDouble EaseInQuint t    = easeInPow 5 t+easeDouble EaseOutQuint t   = easeOutPow 5 t+easeDouble EaseInOutQuint t = easeInOutPow 5 t++easeDouble EaseInBounce t = easeDouble EaseOutBounce (1 - t)+easeDouble EaseOutBounce t = let c = 7.5625 in+    if | t < (1 / 2.75) -> c * t * t+       | t < (2 / 2.75) -> let t' = t - (1.5 / 2.75) in c * t' * t' + 0.75+       | t < (2.5 / 2.75) -> let t' = t - (2.25 / 2.75) in c * t' * t' + 0.9375+       | otherwise -> let t' = t - (2.625 / 2.75) in c * t' * t' + 0.984375++-- TODO fix+easeDouble EaseInOutBounce t =+    if t < 0.5+        then easeDouble EaseInBounce (t * 2) / 2+        else 1 - easeDouble EaseOutBounce ((1 - t) * 2) / 2++easeDouble EaseInElastic t = 1 - elastic (1 - t)+easeDouble EaseOutElastic t = elastic t++-- TODO fix+easeDouble EaseInOutElastic t =+    if t < 0.5+       then elastic (t * 2) / 2+       else 1 - elastic ((1 - t) * 2) / 2++easeDouble (EaseBezier x0 y0 x1 y1) t = js_bezier x0 y0 x1 y1 t++-- some magic numbers i found on the internet+easeDouble EaseInSine t = js_bezier 0.47 0 0.745 0.715 t+easeDouble EaseOutSine t = js_bezier 0.39 0.575 0.565 1 t++getAnimationState :: Monad m => ReactT ty m (AnimationState ty)+getAnimationState = ReactT $ \anim -> return ([], anim)++stepRunningAnims :: AnimationState ty -> [(RunningAnim ty, Double)] -> AnimationState ty+stepRunningAnims anim running =+    let start = foldr+            ( \(RunningAnim AnimConfig{lens=lens} _, _) anim' ->+                anim' & lens .~ animZero+            )+            anim running+    in foldr+        ( \(RunningAnim (AnimConfig _ (from, to) lens easing _) _, progress)+           anim' ->+            anim' & lens %~ (`animAdd` interpolate easing from to progress)+        ) start running++lerp :: Double -> RunningAnim ty -> Double+lerp time (RunningAnim (AnimConfig duration _ _ _ _) begin) =+    (time - begin) / duration++intLerp :: Int -> Int -> Double -> Int+intLerp a b t = floor $ (fromIntegral a) + (fromIntegral $ b - a) * t
src/React/Attrs.hs view
@@ -1,50 +1,90 @@ {-# LANGUAGE OverloadedStrings #-} module React.Attrs where +import React.Types+ import Haste.JSON import Haste.Prim --- class ReactAttr a where+class_ :: JSString -> AttrOrHandler signal+class_ = mkStaticAttr "className" Str -type Attr = (JSString, JSON)+href_ :: JSString -> AttrOrHandler signal+href_ = mkStaticAttr "href" Str -mkAttr :: JSString -> (a -> JSON) -> a -> Attr-mkAttr name f a = (name, f a)+id_ :: JSString -> AttrOrHandler signal+id_ = mkStaticAttr "id" Str --- exception-className :: JSString -> Attr-className = mkAttr "className" Str+src_ :: JSString -> AttrOrHandler signal+src_ = mkStaticAttr "src" Str -class_ :: JSString -> Attr-class_ = mkAttr "className" Str+style_ :: JSON -> AttrOrHandler signal+style_ = mkStaticAttr "style" id -href_ :: JSString -> Attr-href_ = mkAttr "href" Str+value_ :: JSString -> AttrOrHandler signal+value_ = mkStaticAttr "value" Str -id_ :: JSString -> Attr-id_ = mkAttr "id" Str+placeholder_ :: JSString -> AttrOrHandler signal+placeholder_ = mkStaticAttr "placeholder" Str -src_ :: JSString -> Attr-src_ = mkAttr "src" Str+for_ :: JSString -> AttrOrHandler signal+for_ = mkStaticAttr "htmlFor" Str -style_ :: JSON -> Attr-style_ = mkAttr "style" id+type_ :: JSString -> AttrOrHandler signal+type_ = mkStaticAttr "type" Str -value_ :: JSString -> Attr-value_ = mkAttr "value" Str+checked_ :: Bool -> AttrOrHandler signal+checked_ = mkStaticAttr "checked" Bool -placeholder_ :: JSString -> Attr-placeholder_ = mkAttr "placeholder" Str+autofocus_ :: Bool -> AttrOrHandler signal+autofocus_ = mkStaticAttr "autoFocus" Bool -for_ :: JSString -> Attr-for_ = mkAttr "htmlFor" Str+width_ :: Double -> AttrOrHandler signal+width_ = mkStaticAttr "width" Num -type_ :: JSString -> Attr-type_ = mkAttr "type" Str+height_ :: Double -> AttrOrHandler signal+height_ = mkStaticAttr "height" Num -checked_ :: Bool -> Attr-checked_ = mkAttr "checked" Bool+-- svg! --- TODO think about supporting autoFocus / other camel-cased react names-autofocus_ :: Bool -> Attr-autofocus_ = mkAttr "autoFocus" Bool+cx_ :: Double -> AttrOrHandler signal+cx_ = mkStaticAttr "cx" Num++cy_ :: Double -> AttrOrHandler signal+cy_ = mkStaticAttr "cy" Num++d_ :: Double -> AttrOrHandler signal+d_ = mkStaticAttr "d" Num++dx_ :: Double -> AttrOrHandler signal+dx_ = mkStaticAttr "dx" Num++dy_ :: Double -> AttrOrHandler signal+dy_ = mkStaticAttr "dy" Num++x_ :: Double -> AttrOrHandler signal+x_ = mkStaticAttr "x" Num++y_ :: Double -> AttrOrHandler signal+y_ = mkStaticAttr "y" Num++r_ :: Double -> AttrOrHandler signal+r_ = mkStaticAttr "r" Num++fill_ :: JSString -> AttrOrHandler signal+fill_ = mkStaticAttr "fill" Str++viewBox_ :: JSString -> AttrOrHandler signal+viewBox_ = mkStaticAttr "viewBox" Str++points_ :: JSString -> AttrOrHandler signal+points_ = mkStaticAttr "points" Str++transform_ :: JSString -> AttrOrHandler signal+transform_ = mkStaticAttr "transform" Str++-- fillOpacity fontFamily fontSize fx fy gradientTransform+-- gradientUnits markerEnd markerMid markerStart offset opacity+-- patternContentUnits patternUnits preserveAspectRatio r rx ry+-- spreadMethod stopColor stopOpacity stroke strokeDasharray strokeLinecap+-- strokeOpacity strokeWidth textAnchor version x1 x2 x y1 y2 y
+ src/React/Class.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-}+module React.Class+    ( ReactClass(..)+    , createClass+    ) where++import Data.IORef++import React.Anim+import React.Imports+import React.Types++import Haste+import Haste.JSON+import Haste.Prim+++-- | A 'ReactClass' is a standalone component of a user interface which+-- contains the state necessary to render and animate itself. Classes are+-- a tool for scoping.+--+-- Use 'createClass' to construct.+data ReactClass ty = ReactClass+    { classRender :: ClassState ty -> React ty ()+    , classTransition :: ClassState ty+                      -> Signal ty+                      -> (ClassState ty, [AnimConfig ty])++    , foreignClass :: ForeignClass++    , stateRef :: IORef (ClassState ty)+    , animRef :: IORef (AnimationState ty)+    , runningAnimRef :: IORef [RunningAnim ty]+    , transitionRef :: IORef [Signal ty]+    }+++-- | 'ReactClass' smart contstructor.+createClass :: (ClassState ty -> React ty ()) -- ^ render function+            -> (ClassState ty -> Signal ty -> (ClassState ty, [AnimConfig ty]))+            -- ^ transition function+            -> ClassState ty -- ^ initial state+            -> AnimationState ty -- ^ initial animation state+            -> [Signal ty] -- signals to send on startup+            -> IO (ReactClass ty)+createClass render transition initialState initialAnim initialTrans = do+    foreignClass <- js_createClass $ toPtr render++    stateRef <- newIORef initialState+    animRef <- newIORef initialAnim+    runningAnimRef <- newIORef []+    transitionRef <- newIORef initialTrans++    return $ ReactClass+        render+        transition+        foreignClass+        stateRef+        animRef+        runningAnimRef+        transitionRef
src/React/Elements.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies #-} module React.Elements where  import Haste.Prim@@ -7,237 +7,277 @@  import Prelude hiding (div, span) -makeParent :: Monad m-           => JSString-           -> StatefulReactT s m a-           -> StatefulReactT s m ()-makeParent name children = StatefulReactT $ \s -> do-    ~(childNodes, s', _) <- runStatefulReactT children s-    return ([Parent name [] [] childNodes], s', ())--makeLeaf :: Monad m-         => JSString-         -> StatefulReactT s m ()-makeLeaf name = StatefulReactT $ \s -> return ([Leaf name [] []], s, ())--text_ :: JSString -> StatefulReact s ()-text_ str = StatefulReactT $ \s -> return ([Text (fromJSStr str)], s, ())+text_ :: JSString -> React ty ()+text_ str = ReactT $ \_ -> return ([Text (fromJSStr str)], ()) -a_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-a_ = makeParent "a"-abbr_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-abbr_ = makeParent "abbr"-address_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-address_ = makeParent "address"-article_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-article_ = makeParent "article"-aside_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-aside_ = makeParent "aside"-audio_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-audio_ = makeParent "audio"-b_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-b_ = makeParent "b"-bdi_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-bdi_ = makeParent "bdi"-bdo_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-bdo_ = makeParent "bdo"-big_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-big_ = makeParent "big"-blockquote_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-blockquote_ = makeParent "blockquote"-body_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-body_ = makeParent "body"-button_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-button_ = makeParent "button"-canvas_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-canvas_ = makeParent "canvas"-caption_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-caption_ = makeParent "caption"-cite_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-cite_ = makeParent "cite"-code_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-code_ = makeParent "code"-colgroup_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-colgroup_ = makeParent "colgroup"-data_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-data_ = makeParent "data"-datalist_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-datalist_ = makeParent "datalist"-dd_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-dd_ = makeParent "dd"-del_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-del_ = makeParent "del"-details_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-details_ = makeParent "details"-dfn_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-dfn_ = makeParent "dfn"-div_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-div_ = makeParent "div"-dl_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-dl_ = makeParent "dl"-dt_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-dt_ = makeParent "dt"-em_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-em_ = makeParent "em"-fieldset_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-fieldset_ = makeParent "fieldset"-figcaption_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-figcaption_ = makeParent "figcaption"-figure_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-figure_ = makeParent "figure"-footer_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-footer_ = makeParent "footer"-form_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-form_ = makeParent "form"-h1_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-h1_ = makeParent "h1"-h2_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-h2_ = makeParent "h2"-h3_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-h3_ = makeParent "h3"-h4_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-h4_ = makeParent "h4"-h5_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-h5_ = makeParent "h5"-h6_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-h6_ = makeParent "h6"-head_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-head_ = makeParent "head"-header_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-header_ = makeParent "header"-html_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-html_ = makeParent "html"-i_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-i_ = makeParent "i"-iframe_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-iframe_ = makeParent "iframe"-ins_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-ins_ = makeParent "ins"-kbd_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-kbd_ = makeParent "kbd"-label_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-label_ = makeParent "label"-legend_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-legend_ = makeParent "legend"-li_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-li_ = makeParent "li"-main_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-main_ = makeParent "main"-map_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-map_ = makeParent "map"-mark_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-mark_ = makeParent "mark"-menu_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-menu_ = makeParent "menu"-menuitem_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-menuitem_ = makeParent "menuitem"-meter_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-meter_ = makeParent "meter"-nav_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-nav_ = makeParent "nav"-noscript_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-noscript_ = makeParent "noscript"-object_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-object_ = makeParent "object"-ol_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-ol_ = makeParent "ol"-optgroup_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-optgroup_ = makeParent "optgroup"-option_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-option_ = makeParent "option"-output_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-output_ = makeParent "output"-p_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-p_ = makeParent "p"-pre_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-pre_ = makeParent "pre"-progress_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-progress_ = makeParent "progress"-q_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-q_ = makeParent "q"-rp_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-rp_ = makeParent "rp"-rt_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-rt_ = makeParent "rt"-ruby_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-ruby_ = makeParent "ruby"-s_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-s_ = makeParent "s"-samp_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-samp_ = makeParent "samp"-section_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-section_ = makeParent "section"-select_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-select_ = makeParent "select"-small_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-small_ = makeParent "small"-span_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-span_ = makeParent "span"-strong_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-strong_ = makeParent "strong"-sub_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-sub_ = makeParent "sub"-summary_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-summary_ = makeParent "summary"-sup_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-sup_ = makeParent "sup"-table_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-table_ = makeParent "table"-tbody_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-tbody_ = makeParent "tbody"-td_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-td_ = makeParent "td"-tfoot_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-tfoot_ = makeParent "tfoot"-th_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-th_ = makeParent "th"-thead_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-thead_ = makeParent "thead"-time_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-time_ = makeParent "time"-tr_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-tr_ = makeParent "tr"-u_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-u_ = makeParent "u"-ul_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-ul_ = makeParent "ul"-var_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-var_ = makeParent "var"-video_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m ()-video_ = makeParent "video"+a_ :: TermParent t => TermParentArg t -> t+a_ = termParent "a"+abbr_ :: TermParent t => TermParentArg t -> t+abbr_ = termParent "abbr"+address_ :: TermParent t => TermParentArg t -> t+address_ = termParent "address"+article_ :: TermParent t => TermParentArg t -> t+article_ = termParent "article"+aside_ :: TermParent t => TermParentArg t -> t+aside_ = termParent "aside"+audio_ :: TermParent t => TermParentArg t -> t+audio_ = termParent "audio"+b_ :: TermParent t => TermParentArg t -> t+b_ = termParent "b"+bdi_ :: TermParent t => TermParentArg t -> t+bdi_ = termParent "bdi"+bdo_ :: TermParent t => TermParentArg t -> t+bdo_ = termParent "bdo"+big_ :: TermParent t => TermParentArg t -> t+big_ = termParent "big"+blockquote_ :: TermParent t => TermParentArg t -> t+blockquote_ = termParent "blockquote"+body_ :: TermParent t => TermParentArg t -> t+body_ = termParent "body"+button_ :: TermParent t => TermParentArg t -> t+button_ = termParent "button"+canvas_ :: TermParent t => TermParentArg t -> t+canvas_ = termParent "canvas"+caption_ :: TermParent t => TermParentArg t -> t+caption_ = termParent "caption"+cite_ :: TermParent t => TermParentArg t -> t+cite_ = termParent "cite"+code_ :: TermParent t => TermParentArg t -> t+code_ = termParent "code"+colgroup_ :: TermParent t => TermParentArg t -> t+colgroup_ = termParent "colgroup"+data_ :: TermParent t => TermParentArg t -> t+data_ = termParent "data"+datalist_ :: TermParent t => TermParentArg t -> t+datalist_ = termParent "datalist"+dd_ :: TermParent t => TermParentArg t -> t+dd_ = termParent "dd"+del_ :: TermParent t => TermParentArg t -> t+del_ = termParent "del"+details_ :: TermParent t => TermParentArg t -> t+details_ = termParent "details"+dfn_ :: TermParent t => TermParentArg t -> t+dfn_ = termParent "dfn"+div_ :: TermParent t => TermParentArg t -> t+div_ = termParent "div"+dl_ :: TermParent t => TermParentArg t -> t+dl_ = termParent "dl"+dt_ :: TermParent t => TermParentArg t -> t+dt_ = termParent "dt"+em_ :: TermParent t => TermParentArg t -> t+em_ = termParent "em"+fieldset_ :: TermParent t => TermParentArg t -> t+fieldset_ = termParent "fieldset"+figcaption_ :: TermParent t => TermParentArg t -> t+figcaption_ = termParent "figcaption"+figure_ :: TermParent t => TermParentArg t -> t+figure_ = termParent "figure"+footer_ :: TermParent t => TermParentArg t -> t+footer_ = termParent "footer"+form_ :: TermParent t => TermParentArg t -> t+form_ = termParent "form"+h1_ :: TermParent t => TermParentArg t -> t+h1_ = termParent "h1"+h2_ :: TermParent t => TermParentArg t -> t+h2_ = termParent "h2"+h3_ :: TermParent t => TermParentArg t -> t+h3_ = termParent "h3"+h4_ :: TermParent t => TermParentArg t -> t+h4_ = termParent "h4"+h5_ :: TermParent t => TermParentArg t -> t+h5_ = termParent "h5"+h6_ :: TermParent t => TermParentArg t -> t+h6_ = termParent "h6"+head_ :: TermParent t => TermParentArg t -> t+head_ = termParent "head"+header_ :: TermParent t => TermParentArg t -> t+header_ = termParent "header"+html_ :: TermParent t => TermParentArg t -> t+html_ = termParent "html"+i_ :: TermParent t => TermParentArg t -> t+i_ = termParent "i"+iframe_ :: TermParent t => TermParentArg t -> t+iframe_ = termParent "iframe"+ins_ :: TermParent t => TermParentArg t -> t+ins_ = termParent "ins"+kbd_ :: TermParent t => TermParentArg t -> t+kbd_ = termParent "kbd"+label_ :: TermParent t => TermParentArg t -> t+label_ = termParent "label"+legend_ :: TermParent t => TermParentArg t -> t+legend_ = termParent "legend"+li_ :: TermParent t => TermParentArg t -> t+li_ = termParent "li"+main_ :: TermParent t => TermParentArg t -> t+main_ = termParent "main"+map_ :: TermParent t => TermParentArg t -> t+map_ = termParent "map"+mark_ :: TermParent t => TermParentArg t -> t+mark_ = termParent "mark"+menu_ :: TermParent t => TermParentArg t -> t+menu_ = termParent "menu"+menuitem_ :: TermParent t => TermParentArg t -> t+menuitem_ = termParent "menuitem"+meter_ :: TermParent t => TermParentArg t -> t+meter_ = termParent "meter"+nav_ :: TermParent t => TermParentArg t -> t+nav_ = termParent "nav"+noscript_ :: TermParent t => TermParentArg t -> t+noscript_ = termParent "noscript"+object_ :: TermParent t => TermParentArg t -> t+object_ = termParent "object"+ol_ :: TermParent t => TermParentArg t -> t+ol_ = termParent "ol"+optgroup_ :: TermParent t => TermParentArg t -> t+optgroup_ = termParent "optgroup"+option_ :: TermParent t => TermParentArg t -> t+option_ = termParent "option"+output_ :: TermParent t => TermParentArg t -> t+output_ = termParent "output"+p_ :: TermParent t => TermParentArg t -> t+p_ = termParent "p"+pre_ :: TermParent t => TermParentArg t -> t+pre_ = termParent "pre"+progress_ :: TermParent t => TermParentArg t -> t+progress_ = termParent "progress"+q_ :: TermParent t => TermParentArg t -> t+q_ = termParent "q"+rp_ :: TermParent t => TermParentArg t -> t+rp_ = termParent "rp"+rt_ :: TermParent t => TermParentArg t -> t+rt_ = termParent "rt"+ruby_ :: TermParent t => TermParentArg t -> t+ruby_ = termParent "ruby"+s_ :: TermParent t => TermParentArg t -> t+s_ = termParent "signal"+samp_ :: TermParent t => TermParentArg t -> t+samp_ = termParent "samp"+section_ :: TermParent t => TermParentArg t -> t+section_ = termParent "section"+select_ :: TermParent t => TermParentArg t -> t+select_ = termParent "select"+small_ :: TermParent t => TermParentArg t -> t+small_ = termParent "small"+span_ :: TermParent t => TermParentArg t -> t+span_ = termParent "span"+strong_ :: TermParent t => TermParentArg t -> t+strong_ = termParent "strong"+sub_ :: TermParent t => TermParentArg t -> t+sub_ = termParent "sub"+summary_ :: TermParent t => TermParentArg t -> t+summary_ = termParent "summary"+sup_ :: TermParent t => TermParentArg t -> t+sup_ = termParent "sup"+table_ :: TermParent t => TermParentArg t -> t+table_ = termParent "table"+tbody_ :: TermParent t => TermParentArg t -> t+tbody_ = termParent "tbody"+td_ :: TermParent t => TermParentArg t -> t+td_ = termParent "td"+tfoot_ :: TermParent t => TermParentArg t -> t+tfoot_ = termParent "tfoot"+th_ :: TermParent t => TermParentArg t -> t+th_ = termParent "th"+thead_ :: TermParent t => TermParentArg t -> t+thead_ = termParent "thead"+time_ :: TermParent t => TermParentArg t -> t+time_ = termParent "time"+tr_ :: TermParent t => TermParentArg t -> t+tr_ = termParent "tr"+u_ :: TermParent t => TermParentArg t -> t+u_ = termParent "u"+ul_ :: TermParent t => TermParentArg t -> t+ul_ = termParent "ul"+var_ :: TermParent t => TermParentArg t -> t+var_ = termParent "var"+video_ :: TermParent t => TermParentArg t -> t+video_ = termParent "video" -area_ :: Monad m => StatefulReactT s m ()-area_ = makeLeaf "area"-base_ :: Monad m => StatefulReactT s m ()-base_ = makeLeaf "base"-br_ :: Monad m => StatefulReactT s m ()-br_ = makeLeaf "br"-col_ :: Monad m => StatefulReactT s m ()-col_ = makeLeaf "col"-embed_ :: Monad m => StatefulReactT s m ()-embed_ = makeLeaf "embed"-hr_ :: Monad m => StatefulReactT s m ()-hr_ = makeLeaf "hr"-img_ :: Monad m => StatefulReactT s m ()-img_ = makeLeaf "img"-input_ :: Monad m => StatefulReactT s m ()-input_ = makeLeaf "input"-keygen_ :: Monad m => StatefulReactT s m ()-keygen_ = makeLeaf "keygen"-link_ :: Monad m => StatefulReactT s m ()-link_ = makeLeaf "link"-meta_ :: Monad m => StatefulReactT s m ()-meta_ = makeLeaf "meta"-param_ :: Monad m => StatefulReactT s m ()-param_ = makeLeaf "param"-source_ :: Monad m => StatefulReactT s m ()-source_ = makeLeaf "source"-track_ :: Monad m => StatefulReactT s m ()-track_ = makeLeaf "track"-wbr_ :: Monad m => StatefulReactT s m ()-wbr_ = makeLeaf "wbr"+area_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+area_ = termLeaf "area"+base_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+base_ = termLeaf "base"+br_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+br_ = termLeaf "br"+col_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+col_ = termLeaf "col"+embed_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+embed_ = termLeaf "embed"+hr_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+hr_ = termLeaf "hr"+img_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+img_ = termLeaf "img"+input_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+input_ = termLeaf "input"+keygen_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+keygen_ = termLeaf "keygen"+link_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+link_ = termLeaf "link"+meta_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+meta_ = termLeaf "meta"+param_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+param_ = termLeaf "param"+source_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+source_ = termLeaf "source"+track_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+track_ = termLeaf "track"+wbr_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+wbr_ = termLeaf "wbr"  -- script :: RawAttrs -> JSString -> IO ForeignNode -- style :: RawAttrs -> JSString -> IO ForeignNode -- textarea :: RawAttrs -> JSString -> IO ForeignNode -- title :: RawAttrs -> JSString -> IO ForeignNode++-- svg!++svg_ :: TermParent t => TermParentArg t -> t+svg_ = termParent "svg"++defs_ :: TermParent t => TermParentArg t -> t+defs_ = termParent "defs"++g_ :: TermParent t => TermParentArg t -> t+g_ = termParent "g"++linearGradient_ :: TermParent t => TermParentArg t -> t+linearGradient_ = termParent "linearGradient"++mask_ :: TermParent t => TermParentArg t -> t+mask_ = termParent "mask"++pattern_ :: TermParent t => TermParentArg t -> t+pattern_ = termParent "pattern"++radialGradient_ :: TermParent t => TermParentArg t -> t+radialGradient_ = termParent "radialGradient"++stop_ :: TermParent t => TermParentArg t -> t+stop_ = termParent "stop"++-- text_ :: TermParent t => TermParentArg t -> t+-- text_ = termParent "text"++tspan_ :: TermParent t => TermParentArg t -> t+tspan_ = termParent "tspan"++circle_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+circle_ = termLeaf "circle"++ellipse_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+ellipse_ = termLeaf "ellipse"++line_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+line_ = termLeaf "line"++path_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+path_ = termLeaf "path"++polygon_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+polygon_ = termLeaf "polygon"++polyline_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+polyline_ = termLeaf "polyline"++rect_ :: (Monad m, sig ~ Signal ty) => [AttrOrHandler sig] -> ReactT ty m ()+rect_ = termLeaf "rect"
src/React/Events.hs view
@@ -1,53 +1,87 @@ {-# LANGUAGE OverloadedStrings #-} module React.Events where +import Control.Applicative+import Control.DeepSeq+ import Haste import Haste.Prim  import React.Imports import React.Types -onChange :: (s -> ChangeEvent -> s) -> StatefulEventHandler s-onChange handler = StatefulEventHandler-    (\s evt -> handler s (fromPtr (js_parseChangeEvent evt)))+-- TODO: handle (a -> Maybe b) or (a -> b)++handlerToJs :: (RawEvent -> Maybe (IO ())) -> Ptr (RawEvent -> IO ())+handlerToJs handle =+    let go :: Maybe (IO ()) -> IO ()+        go = maybe (return ()) id+    in toPtr (go . handle)++makeHandler :: RawAttrs -> (RawEvent -> Maybe (IO ()), EvtType) -> IO ()+makeHandler obj (handle, ChangeEvt) =+    js_set_onChange (handlerToJs handle) obj+makeHandler obj (handle, KeyDownEvt) =+    js_set_onKeyDown (handlerToJs handle) obj+makeHandler obj (handle, KeyPressEvt) =+    js_set_onKeyPress (handlerToJs handle) obj+makeHandler obj (handle, KeyUpEvt) =+    js_set_onKeyUp (handlerToJs handle) obj+makeHandler obj (handle, ClickEvt) =+    js_set_onClick (handlerToJs handle) obj+makeHandler obj (handle, DoubleClickEvt) =+    js_set_onDoubleClick (handlerToJs handle) obj+makeHandler obj (handle, MouseEnterEvt) =+    js_set_onMouseEnter (handlerToJs handle) obj+makeHandler obj (handle, MouseLeaveEvt) = return ()+    -- js_set_onMouseLeave (handlerToJs handle) obj++unHandler :: (s -> IO ())+          -> EventHandler s+          -> (RawEvent -> Maybe (IO ()), EvtType)+unHandler act (EventHandler handle ty) = (\e -> act <$> handle e, ty)++onChange :: (ChangeEvent -> Maybe s) -> AttrOrHandler s+onChange = mkEventHandler+    (fromPtr . js_parseChangeEvent)     ChangeEvt -onKeyDown :: (s -> KeyboardEvent -> s) -> StatefulEventHandler s-onKeyDown handler = StatefulEventHandler-    (\s evt -> handler s (fromPtr (js_parseKeyboardEvent evt)))+onKeyDown :: (KeyboardEvent -> Maybe s) -> AttrOrHandler s+onKeyDown = mkEventHandler+    (fromPtr . js_parseKeyboardEvent)     KeyDownEvt -onKeyPress :: (s -> KeyboardEvent -> s) -> StatefulEventHandler s-onKeyPress handler = StatefulEventHandler-    (\s evt -> handler s (fromPtr (js_parseKeyboardEvent evt)))+onKeyPress :: (KeyboardEvent -> Maybe s) -> AttrOrHandler s+onKeyPress = mkEventHandler+    (fromPtr . js_parseKeyboardEvent)     KeyPressEvt -onKeyUp :: (s -> KeyboardEvent -> s) -> StatefulEventHandler s-onKeyUp handler = StatefulEventHandler-    (\s evt -> handler s (fromPtr (js_parseKeyboardEvent evt)))+onKeyUp :: (KeyboardEvent -> Maybe s) -> AttrOrHandler s+onKeyUp = mkEventHandler+    (fromPtr . js_parseKeyboardEvent)     KeyUpEvt -onMouseEnter :: (s -> MouseEvent -> s) -> StatefulEventHandler s-onMouseEnter handler = StatefulEventHandler-    (\s evt -> handler s (fromPtr (js_parseMouseEvent evt)))+onMouseEnter :: (MouseEvent -> Maybe s) -> AttrOrHandler s+onMouseEnter = mkEventHandler+    (fromPtr . js_parseMouseEvent)     MouseEnterEvt -onMouseLeave :: (s -> MouseEvent -> s) -> StatefulEventHandler s-onMouseLeave handler = StatefulEventHandler-    (\s evt -> handler s (fromPtr (js_parseMouseEvent evt)))+onMouseLeave :: (MouseEvent -> Maybe s) -> AttrOrHandler s+onMouseLeave = mkEventHandler+    (fromPtr . js_parseMouseEvent)     MouseLeaveEvt -onDoubleClick :: (s -> MouseEvent -> s) -> StatefulEventHandler s-onDoubleClick handler = StatefulEventHandler-    (\s evt -> handler s (fromPtr (js_parseMouseEvent evt)))+onDoubleClick :: (MouseEvent -> Maybe s) -> AttrOrHandler s+onDoubleClick = mkEventHandler+    (fromPtr . js_parseMouseEvent)     DoubleClickEvt -onClick :: (s -> MouseEvent -> s) -> StatefulEventHandler s-onClick handler = StatefulEventHandler-    (\s evt -> handler s (fromPtr (js_parseMouseEvent evt)))+onClick :: (MouseEvent -> Maybe s) -> AttrOrHandler s+onClick = mkEventHandler+    (fromPtr . js_parseMouseEvent)     ClickEvt -onEnter :: (s -> s) -> StatefulEventHandler s-onEnter f = onKeyPress handler where-    handler s KeyboardEvent{key="Enter"} = f s-    handler s _ = s+onEnter :: s -> AttrOrHandler s+onEnter s = onKeyPress handler where+    handler KeyboardEvent{key="Enter"} = Just s+    handler _ = Nothing
src/React/Imports.hs view
@@ -1,4 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface, CPP #-}++-- TODO send GHC bug report+{- ANN module "HLint: ignore Use camelCase" -}+ module React.Imports where  import React.Types@@ -7,6 +11,43 @@ import Haste.Foreign import Haste.JSON import Haste.Prim++#ifdef __HASTE__+foreign import ccall js_render :: ForeignNode -> Elem -> IO ()+#else+js_render :: ForeignNode -> Elem -> IO ()+js_render = error "cannot evaluate js_render in ghc"+#endif++#ifdef __HASTE__+foreign import ccall js_bezier :: Double -> Double -> Double -> Double -> Double -> Double+#else+js_bezier :: Double -> Double -> Double -> Double -> Double -> Double+js_bezier = error "cannot evaluate js_bezier in ghc"+#endif++#ifdef __HASTE__+foreign import ccall js_createClass :: Ptr (state -> React ty ())+                                    -> IO ForeignClass+#else+js_createClass :: Ptr (state -> React ty ())+               -> IO ForeignClass+js_createClass = error "cannot evaluate js_createClass in ghc"+#endif++#ifdef __HASTE__+foreign import ccall js_raf :: Ptr (Double -> IO ()) -> IO RenderHandle+#else+js_raf :: Ptr (Double -> IO ()) -> IO RenderHandle+js_raf = error "cannot evaluate js_raf in ghc"+#endif++#ifdef __HASTE__+foreign import ccall js_cancelRaf :: RenderHandle -> IO ()+#else+js_cancelRaf :: RenderHandle -> IO ()+js_cancelRaf = error "cannot evaluate js_cancelRaf in ghc"+#endif  #ifdef __HASTE__ foreign import ccall js_React_DOM_leaf :: JSString -> RawAttrs -> IO ForeignNode
+ src/React/Interpret.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings, LambdaCase #-}+module React.Interpret where++import Control.Monad++import Haste.DOM+import Haste.Foreign+import Haste.JSON+import Haste.Prim++import React.Events+import React.Imports+import React.Types+++element :: (JSString -> RawAttrs -> ReactArray -> IO ForeignNode)+        -> JSString+        -> Attrs+        -> [(RawEvent -> Maybe (IO ()), EvtType)]+        -> [ForeignNode]+        -> IO ForeignNode+element constructor name attrs handlers content = do+    attr <- js_empty_object+    mapM_ (setField attr) attrs+    mapM_ (makeHandler attr) handlers++    children <- js_ReactArray_empty+    mapM_ (js_ReactArray_push children) content+    constructor name attr children+++voidElement :: (JSString -> RawAttrs -> IO ForeignNode)+            -> JSString+            -> Attrs+            -> [(RawEvent -> Maybe (IO ()), EvtType)]+            -> IO ForeignNode+voidElement constructor name attrs handlers =+    element (\n a c -> constructor n a) name attrs handlers []+++setField :: RawAttrs -> (JSString, JSON) -> IO ()+setField attr (fld, Str v) = js_set_field_String attr fld v+setField attr (fld, Dict vs) = do+    subObj <- js_empty_object+    mapM_ (setField subObj) vs+    js_set_field_Obj attr fld subObj+setField attr (fld, Num v) = js_set_field_Double attr fld v+setField attr (fld, Bool True) = js_set_field_True attr fld+setField attr (fld, Bool False) = js_set_field_False attr fld++-- TODO this seems wrong+setField attr (fld, Null) = return ()+++-- TODO figure out what to do with this+-- getDomNode :: ForeignNode -> IO (Maybe Elem)+-- getDomNode r = fmap fromPtr (js_React_getDomNode r)++interpret :: Monad m+          => ReactT ty m ()+          -> AnimationState ty+          -> (Signal ty -> IO ())+          -> m (IO ForeignNode)+interpret react anim cb = do+    ~(child:_, ()) <- runReactT react anim+    return $ interpret' cb child+++interpret' :: (signal -> IO ())+           -> ReactNode signal+           -> IO ForeignNode+interpret' cb = \case+    Parent name as hs children -> do+        children' <- forM children (interpret' cb)+        let hs' = map (unHandler cb) hs+        element js_React_DOM_parent name as hs' children'+    Leaf name as hs -> do+        let hs' = map (unHandler cb) hs+        voidElement js_React_DOM_leaf name as hs'+    Text str -> js_React_DOM_text (toJSStr str)
+ src/React/Local.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances, GADTs, MultiParamTypeClasses #-}+module React.Local (locally, Narrowing(..)) where++import Control.Applicative+import Data.Void++import React.Types++-- TODO+-- * make work with react classes++data Narrowing general local = Narrowing+    { localizeAnimationState :: AnimationState general -> AnimationState local+    , generalizeSignal :: Signal local -> Signal general+    }++locally :: Monad m+        => Narrowing general local+        -> ReactT local m x+        -> ReactT general m x+locally narrowing nested = ReactT $ \anim -> do+    (nodes, x) <- runReactT nested (localizeAnimationState narrowing anim)+    return (map (nodeConvert (generalizeSignal narrowing)) nodes, x)++handlerConvert :: (localSig -> generalSig)+               -> EventHandler localSig+               -> EventHandler generalSig+handlerConvert generalize (EventHandler handle ty) =+    EventHandler (\raw -> generalize <$> handle raw) ty++nodeConvert :: (localSig -> generalSig)+             -> ReactNode localSig+             -> ReactNode generalSig+nodeConvert generalize (Parent name attrs handlers children) =+    Parent name attrs (map (handlerConvert generalize) handlers)+        (map (nodeConvert generalize) children)+nodeConvert generalize (Leaf name attrs handlers) =+    Leaf name attrs (map (handlerConvert generalize) handlers)+nodeConvert _ (Text str) = Text str
+ src/React/Render.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, NamedFieldPuns #-}++module React.Render+    ( render+    , cancelRender+    ) where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Data.Functor.Identity+import Data.IORef+import Data.List+import Data.Maybe+import Data.Monoid+import Data.String++import Haste hiding (fromString)+import Haste.Foreign+import Haste.JSON+import Haste.Prim++import React.Anim+import React.Attrs+import React.Class+import React.Elements+import React.Events+import React.Imports+import React.Interpret+import React.Local+import React.Types+++doRender :: Elem -> Double -> ReactClass ty -> IO ()+doRender elem time ReactClass{ classRender,+                               classTransition,+                               transitionRef,+                               runningAnimRef,+                               animRef,+                               stateRef } = do++    transitions <- readIORef transitionRef+    runningAnims <- readIORef runningAnimRef+    prevState <- readIORef stateRef+    prevAnim <- readIORef animRef++    let (newState, newAnims) =+            mapAccumL classTransition prevState transitions++        newAnims' = concat newAnims+        newRunningAnims = map (\conf -> RunningAnim conf time) newAnims'++        (runningAnims', endingAnims) = partition+            (\(RunningAnim AnimConfig{duration} beganAt) ->+                beganAt + duration > time)+            (runningAnims <> newRunningAnims)++        endingAnims' = zip endingAnims [1..]+        runningAnims'' = zip runningAnims' (map (lerp time) runningAnims')+        newAnim = stepRunningAnims prevAnim (endingAnims' ++ runningAnims'')++        -- TODO should this run before or after rendering?+        -- TODO expose a way to cancel / pass False in that case+        endAnimTrans = mapMaybe+            (\anim -> onComplete (config anim) True)+            endingAnims++    foreignNode <- runIdentity $+        interpret (classRender newState) newAnim (updateCb transitionRef)+    js_render foreignNode elem++    writeIORef stateRef newState+    writeIORef animRef newAnim+    writeIORef runningAnimRef runningAnims'+    writeIORef transitionRef endAnimTrans+++updateCb :: IORef [signal] -> signal -> IO ()+updateCb ref update = modifyIORef ref (update:)+++render :: Elem+       -> ReactClass ty+       -> IO RenderHandle+render elem cls@ReactClass{transitionRef, runningAnimRef} = do+    let renderCb time = do+            transitions <- readIORef transitionRef+            runningAnims <- readIORef runningAnimRef++            -- only rerender when dirty+            when (length transitions + length runningAnims > 0) $+                doRender elem time cls++            js_raf $ toPtr renderCb+            return ()++    doRender elem 0 cls+    js_raf $ toPtr renderCb+++cancelRender :: RenderHandle -> IO ()+cancelRender = js_cancelRaf
src/React/Types.hs view
@@ -1,22 +1,31 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses,-    FlexibleInstances, FlexibleContexts, GADTs, Rank2Types #-}+    FlexibleInstances, FlexibleContexts, TypeFamilies,+    ExistentialQuantification, ImpredicativeTypes #-} module React.Types where  import Control.Applicative+import Control.DeepSeq import Control.Monad import Data.Functor.Identity import Data.Monoid import Data.String +import Data.Void import Haste import Haste.Foreign import Haste.JSON import Haste.Prim+import Lens.Family2 + newtype ForeignNode = ForeignNode JSAny deriving (Pack, Unpack) newtype RawAttrs = RawAttrs JSAny  deriving (Pack, Unpack) newtype ReactArray = ReactArray JSAny deriving (Pack, Unpack)+newtype ForeignClass = ForeignClass JSAny deriving (Pack, Unpack) +newtype RenderHandle = RenderHandle Int+    deriving (Pack, Unpack)+ data EvtType     = ChangeEvt     | KeyDownEvt@@ -27,8 +36,8 @@     | MouseEnterEvt     | MouseLeaveEvt -data StatefulEventHandler s = StatefulEventHandler-    { handler :: s -> RawEvent -> s+data EventHandler signal = EventHandler+    { handler :: RawEvent -> Maybe signal     , evtType :: EvtType     } @@ -36,122 +45,275 @@  type Attrs = [(JSString, JSON)] -data ReactNode s = Parent JSString Attrs [StatefulEventHandler s] [ReactNode s]-                 | Leaf JSString Attrs [StatefulEventHandler s]-                 -- | Pre Attrs Handlers [ReactNode] -- it'd be super cool to restrict this to a string somehow (restrict the underlying monad so it can only set attrs and string?)-                 | Text String -- TODO(joel) JSString?+-- it'd be super cool to restrict `Pre` to a string somehow (restrict the+-- underlying monad so it can only set attrs and string?) -type MockLens s a = Functor f => (a -> f a) -> s -> f s+data ReactNode signal+    = Parent JSString Attrs [EventHandler signal] [ReactNode signal]+    | Leaf JSString Attrs [EventHandler signal]+    -- | Pre Attrs Handlers [ReactNode]+    | Text String -- TODO(joel) JSString? -mockGet :: MockLens s a -> s -> a-mockGet l = getConst . l Const -mockMod :: MockLens s a -> (a -> a) -> s -> s-mockMod l f = runIdentity . l (Identity . f)+-- | Standard easing functions. These are used to 'interpolate' smoothly.+--+-- See <http://joelburget.com/react-haskell/ here> for visualizations.+data Easing+    = Linear -mockSet :: MockLens s a -> a -> s -> s-mockSet l a = mockMod l (const a)+    | EaseInQuad+    | EaseOutQuad+    | EaseInOutQuad -handlerConvert :: MockLens a b-               -> StatefulEventHandler b-               -> StatefulEventHandler a-handlerConvert l (StatefulEventHandler f ty) = StatefulEventHandler-    (\a raw -> mockSet l (f (mockGet l a) raw) a)-    ty+    | EaseInCubic+    | EaseOutCubic+    | EaseInOutCubic -nodeConvert :: MockLens a b -> ReactNode b -> ReactNode a-nodeConvert l (Parent name attrs handlers children) =-    Parent name attrs (map (handlerConvert l) handlers)-        (map (nodeConvert l) children)-nodeConvert l (Leaf name attrs handlers) =-    Leaf name attrs (map (handlerConvert l) handlers)-nodeConvert l (Text str) = Text str+    | EaseInQuart+    | EaseOutQuart+    | EaseInOutQuart -newtype StatefulReactT s m a = StatefulReactT-    { runStatefulReactT :: s -> m ([ReactNode s], s, a) }+    | EaseInQuint+    | EaseOutQuint+    | EaseInOutQuint -type StatefulReact s = StatefulReactT s Identity-type PureReact = StatefulReact () ()+    | EaseInElastic+    | EaseOutElastic+    | EaseInOutElastic -getState :: Monad m => StatefulReactT s m s-getState = StatefulReactT $ \s -> return ([], s, s)+    | EaseInBounce+    | EaseOutBounce+    | EaseInOutBounce -instance (Monad m, Monoid a) => Monoid (StatefulReactT s m a) where-    mempty = StatefulReactT $ \s -> return ([], s, mempty)-    mappend f1 f2 = StatefulReactT $ \s -> do-        ~(c1, s1, a) <- runStatefulReactT f1 s-        ~(c2, s2, b) <- runStatefulReactT f2 s1-        return (c1 <> c2, s2, a <> b)+    | EaseBezier Double Double Double Double+    | EaseInSine+    | EaseOutSine+    deriving (Show, Eq, Ord) -instance Monad m => Functor (StatefulReactT s m) where+-- | Properties that can animate.+--+-- Numeric values like 'width' and 'height', as well as colors.+class Animatable a where+    -- TODO is `to` always `animZero`?+    -- | Use an easing function to interpolate between two values+    interpolate :: Easing -- ^ easing function+                -> a -- ^ from+                -> a -- ^ to+                -> Double -- ^ [0..1] ratio of /time/ elapsed+                -> a++    -- | Add two animations+    animAdd :: a -> a -> a++    -- | Subtract two animations+    animSub :: a -> a -> a+    animZero :: a+++-- | A 'ReactKey' is a type, which conventionally has no constructors,+-- mapping to the type of state, animation state, and signals associated+-- with a page fragment or class.+--+-- Example:+--+-- @+-- data Slider -- note the key has no constructors+-- data SliderState = Open | Closed+-- data SliderSignal = SlideOpen | SlideClosed+--+-- instance ReactKey Slider where+--     type ClassState Slider = SliderState+--     type AnimationState Slider = Double+--     type Signal Slider = SliderSignal+--+-- -- this page fragment has access to the animation state 'Double' and can+-- -- emit 'SliderSignal's.+-- pageFragment :: React Slider ()+-- pageFragment = div_ ...+--+-- -- this class stores the class state and animation state. its internals+-- -- can emit `SliderSignal`s.+-- sliderClass :: ReactClass Slider ()+-- sliderClass = ...+-- @+class ReactKey ty where+    -- | The state needed to render a class (ignoring animation)+    type ClassState ty :: *++    -- | The state needed to animate a class+    type AnimationState ty :: *++    -- | The type of signals a class can send+    type Signal ty :: *+++-- Unit's ClassState and AnimationState are uninteresting. Its Signal is+-- entirely uninhabited.+instance ReactKey () where+    type ClassState     () = ()+    type AnimationState () = ()+    type Signal         () = Void+++-- things you might want to control about an animation:+-- * duration+-- * from+-- * to+-- * lens+-- * easing+-- * oncomplete+-- * chaining+-- * delay++-- possible configurations:+-- * set new state, animate from old to new at same time+--   - need to connect ClassState and AnimationState somehow+-- * animate manually from -> to++data AnimConfig ty = forall a. (Animatable a) => AnimConfig {+      -- | How long this animation lasts in milliseconds+      duration :: Double+      -- | Where does this animation start and end?+    , endpoints :: (a, a)+    -- , lens :: Lens' anim a XXX+      -- | Pointer to this field within 'AnimationState'+    , lens :: Traversal' (AnimationState ty) a+      -- | How is the animation eased?+    , easing :: Easing+      -- | Do something when it's finished?+    , onComplete :: Bool -> Maybe (Signal ty)+    }+++data RunningAnim ty = RunningAnim+    { config :: AnimConfig ty+    , beganAt :: Double+    }+++newtype ReactT ty m a = ReactT+    { runReactT :: AnimationState ty -> m ([ReactNode (Signal ty)], a) }+++type React ty = ReactT ty Identity+++instance (Monad m, Monoid a) => Monoid (ReactT ty m a) where+    mempty = ReactT $ \_ -> return ([], mempty)+    mappend f1 f2 = ReactT $ \anim -> do+        ~(c1, a) <- runReactT f1 anim+        ~(c2, b) <- runReactT f2 anim+        return (c1 <> c2, a <> b)+++instance Monad m => Functor (ReactT ty m) where     fmap = liftM -instance Monad m => Applicative (StatefulReactT s m) where++instance Monad m => Applicative (ReactT ty m) where     pure = return     (<*>) = ap -instance (Monad m, a ~ ()) => IsString (StatefulReactT s m a) where-    fromString str = StatefulReactT $ \s -> return ([Text str], s, ()) -instance Monad m => Monad (StatefulReactT s m) where-    return a = StatefulReactT $ \s -> return ([], s, a)-    m >>= f = StatefulReactT $ \s -> do-        ~(c1, s1, a) <- runStatefulReactT m s-        ~(c2, s2, b) <- runStatefulReactT (f a) s1-        return (c1 <> c2, s2, b)+instance (Monad m, a ~ ()) => IsString (ReactT ty m a) where+    fromString str = ReactT $ \_ -> return ([Text str], ()) --- TODO thinking there should be some notion of single / multiple?--- We should only ever apply an attribute / handler to one element here.------ div <! attr $ ...------ vs++instance Monad m => Monad (ReactT ty m) where+    return a = ReactT $ \_ -> return ([], a)+    m >>= f = ReactT $ \anim -> do+        ~(c1, a) <- runReactT m anim+        ~(c2, b) <- runReactT (f a) anim+        return (c1 <> c2, b)+++-- attributes++data AttrOrHandler signal+    = StaticAttr JSString JSON+    | Handler (EventHandler signal)+++mkStaticAttr :: JSString -> (a -> JSON) -> a -> AttrOrHandler signal+mkStaticAttr name f a = StaticAttr name (f a)+++mkEventHandler :: (NFData signal)+               => (RawEvent -> signal)+               -> EvtType+               -> (signal -> Maybe signal')+               -> AttrOrHandler signal'+mkEventHandler unNative ty handle =+    -- important - you must deepseq the event immediately - otherwise+    -- react's pooling will collect and destroy it.+    let handle' raw = handle $!! unNative raw+    in Handler (EventHandler handle' ty)+++separateAttrs :: [AttrOrHandler signal] -> ([EventHandler signal], Attrs)+separateAttrs [] = ([], [])+separateAttrs ((StaticAttr k v):xs) =+    let (hs, as) = separateAttrs xs in (hs, (k, v):as)+separateAttrs ((Handler h):xs) =+    let (hs, as) = separateAttrs xs in (h:hs, as)+++-- terms++-- | Parent nodes always take children, but can also optionally take a list+-- of arguments. ----- (div >> div) <! attr+-- Example of the first case, which exercises the simpler instance: ----- in fact, I think we should only ever apply attrs to--- `React -> React`+-- @+-- div_ $ ... children ...+-- @ ----- except things with no children?+-- Example of the second, which exercises the more complicated instance: ----- input <! attr+-- @+-- span_ [class_ "example"] $ ... children ...+-- @+class TermParent result where+    -- | The argument to a parent term is either:+    --+    -- * a list of attributes (@[AttrOrHandler (Signal ty)]@), which leads+    --   to a result type of @ReactT ty m a -> ReactT ty m a@.+    --+    -- * or children (@ReactT ty m a@), which leads to a result type of+    --   @ReactT ty m a@.+    type TermParentArg result :: * -instance Monad m => Attributable (StatefulReactT s m a) (JSString, JSON) where-    react <! attr = StatefulReactT $ \s -> do-        ~(children, s', a) <- runStatefulReactT react s-        return (children <!> attr, s', a)+    termParent :: JSString -> TermParentArg result -> result -instance Monad m =>-         Attributable (StatefulReactT s m a) (StatefulEventHandler s) where-    react <! attr = StatefulReactT $ \s -> do-        ~(children, s', a) <- runStatefulReactT react s-        return (children <!< attr, s', a) -instance Attributable (StatefulReactT s m a) x =>-         Attributable (StatefulReactT s m a -> StatefulReactT s m a) x where-    f <! attr = (<! attr) . f+instance (Monad m, f ~ ReactT ty m a) => TermParent (f -> ReactT ty m a) where+    type TermParentArg (f -> ReactT ty m a) = [AttrOrHandler (Signal ty)] -class Attributable h a where-    (<!) :: h -> a -> h+    termParent name attrs children = ReactT $ \anim -> do+        ~(childNodes, a) <- runReactT children anim+        let (hs, as) = separateAttrs attrs+        return ([Parent name as hs childNodes], a) -(<!?) :: Attributable h a => h -> (Bool, a) -> h-h <!? (True, a) = h <! a-h <!? (False, _) = h -(<!>) :: [ReactNode s] -> (JSString, JSON) -> [ReactNode s]-[elem] <!> attr = [go elem] where-    go (Parent name as hs cs) = Parent name (attr:as) hs cs-    go (Leaf name as hs)      = Leaf name (attr:as) hs-    go (Text str)             = Text str-_ <!> _ = error "attr applied to multiple elems!"+instance Monad m => TermParent (ReactT ty m a) where+    type TermParentArg (ReactT ty m a) = ReactT ty m a -(<!<) :: [ReactNode s] -> StatefulEventHandler s -> [ReactNode s]-[elem] <!< hndl = [go elem] where-    go (Parent name as hs cs) = Parent name as (hndl:hs) cs-    go (Leaf name as hs)      = Leaf name as (hndl:hs)-    go (Text str)             = Text str-_ <!< _ = error "handler applied to multiple elems!"+    termParent name children = ReactT $ \anim -> do+        ~(childNodes, a) <- runReactT children anim+        return ([Parent name [] [] childNodes], a) ++termLeaf :: (Monad m, sig ~ Signal ty)+         => JSString+         -> [AttrOrHandler sig]+         -> ReactT ty m ()+termLeaf name attrs = ReactT $ \_ -> do+    let (hs, as) = separateAttrs attrs+    return ([Leaf name as hs], ())+++-- | Low level properties common to all events data EventProperties e =   EventProperties { bubbles :: !Bool                   , cancelable :: !Bool@@ -167,6 +329,10 @@                   , eventType :: !JSString -- type                   } +instance NFData e => NFData (EventProperties e) where+    rnf (EventProperties a b c d e f g h) =+        a `seq` b `seq` c `seq` d `seq` e `seq` f `seq` g `seq` h `seq` ()+ data ModifierKeys =   ModifierKeys { altKey :: !Bool                , ctrlKey :: !Bool@@ -174,6 +340,9 @@                , shiftKey :: !Bool                } deriving (Eq, Show) +instance NFData ModifierKeys where+    rnf (ModifierKeys a b c d) = a `seq` b `seq` c `seq` d `seq` ()+ data MouseEvent =   MouseEvent { -- mouseEventProperties :: !(EventProperties e)                mouseModifierKeys :: !ModifierKeys@@ -188,6 +357,10 @@              , screenY :: !Double              } deriving Show +instance NFData MouseEvent where+    rnf (MouseEvent a b c d e f g h) =+        a `seq` b `seq` c `seq` d `seq` e `seq` f `seq` g `seq` h `seq` ()+ data KeyboardEvent =   KeyboardEvent { -- keyboardEventProperties :: ! (EventProperties e)                   keyboardModifierKeys :: !ModifierKeys@@ -200,10 +373,20 @@                 , which :: !Int                 } deriving Show -newtype ChangeEvent = ChangeEvent { targetValue :: JSString }+instance NFData KeyboardEvent where+    rnf (KeyboardEvent a b c d e f g h) =+        a `seq` b `seq` c `seq` d `seq` e `seq` f `seq` g `seq` h `seq` () +newtype ChangeEvent = ChangeEvent { targetValue :: JSString } deriving Show++instance NFData ChangeEvent where+    rnf e@(ChangeEvent str) = str `seq` ()+ data FocusEvent e =   FocusEvent { -- focusEventProperties :: ! (EventProperties e)                domEventTarget :: !e -- NativeElem              , relatedTarget :: !e -- NativeElem              }++instance NFData e => NFData (FocusEvent e) where+    rnf (FocusEvent a b) = a `seq` b `seq` ()