From a63984a1d2ca60f524190de8d1f5a49dbad106fa Mon Sep 17 00:00:00 2001 From: John Cant Date: Tue, 3 Feb 2015 12:20:53 +0000 Subject: [PATCH 1/8] WIP --- lib/stubs.js | 11 +++-- src/React.hs | 1 - src/React/Attrs.hs | 3 ++ src/React/Class.hs | 95 +++++++++++++++++++++++++++++++----------- src/React/Elements.hs | 3 ++ src/React/Imports.hs | 19 +++++++-- src/React/Interpret.hs | 14 +++++-- src/React/Render.hs | 70 ++----------------------------- src/React/Types.hs | 8 ++++ 9 files changed, 123 insertions(+), 101 deletions(-) diff --git a/lib/stubs.js b/lib/stubs.js index 78b3c7c..0bf929b 100644 --- a/lib/stubs.js +++ b/lib/stubs.js @@ -242,6 +242,7 @@ function js_id(a) {return a;} // custom function js_React_DOM_leaf(name, a) { return React.DOM[name](a); } function js_React_DOM_parent(name, a, c) { return React.DOM[name](a, c); } +function js_React_DOM_class(klass) { return React.createElement(klass, null); } function js_parseChangeEvent(raw) { // wrap the string in two constructors - Ptr and JSString @@ -320,9 +321,12 @@ function js_raf(cb) { }); } -function js_createClass(render, setState) { +function js_createClass(render, initialState, hs) { return React.createClass({ - render: render + render: function() { + return render(hs, this.state); + }, + getInitialState: function() { return initialState } }); } @@ -331,7 +335,8 @@ function js_bezier(x0, y0, x1, y1, x) { } function js_render(e, r){ - React.render(e, r); + debugger + React.render(React.createElement(e, null), r); } function js_cancelRaf(id) { diff --git a/src/React.hs b/src/React.hs index 0d675cb..943fb38 100644 --- a/src/React.hs +++ b/src/React.hs @@ -22,7 +22,6 @@ module React , GeneralizeSignal(..) -- React.Render - , cancelRender , render -- React.Types diff --git a/src/React/Attrs.hs b/src/React/Attrs.hs index 8c07fb8..932f298 100644 --- a/src/React/Attrs.hs +++ b/src/React/Attrs.hs @@ -83,6 +83,9 @@ points_ = mkStaticAttr "points" Str transform_ :: JSString -> AttrOrHandler signal transform_ = mkStaticAttr "transform" Str +multiple_ :: Bool -> AttrOrHandler signal +multiple_ = mkStaticAttr "multiple" Bool + -- fillOpacity fontFamily fontSize fx fy gradientTransform -- gradientUnits markerEnd markerMid markerStart offset opacity -- patternContentUnits patternUnits preserveAspectRatio r rx ry diff --git a/src/React/Class.hs b/src/React/Class.hs index f5f43f5..4df39aa 100644 --- a/src/React/Class.hs +++ b/src/React/Class.hs @@ -5,6 +5,11 @@ module React.Class ) where import Data.IORef +import Data.List +import Data.Monoid +import Data.Maybe +import Data.Functor.Identity +import React.Interpret import React.Anim import React.Imports @@ -20,19 +25,10 @@ import Haste.Prim -- a tool for scoping. -- -- Use 'createClass' to construct. -data ReactClass state sig anim = ReactClass - { classRender :: state -> React state sig anim () - , classTransition :: sig - -> state - -> (state, [AnimConfig sig anim]) - - , foreignClass :: ForeignClass - - , stateRef :: IORef state - , animRef :: IORef anim - , runningAnimRef :: IORef [RunningAnim sig anim] - , transitionRef :: IORef [sig] - } +data ReactClass state sig anim = + ReactClass { foreignClass :: ForeignClass + , classTransition :: (sig -> state -> (state, [AnimConfig sig anim])) + } -- | 'ReactClass' smart constructor. @@ -44,18 +40,69 @@ createClass :: (state -> React state sig anim ()) -- ^ render function -> [sig] -- signals to send on startup -> IO (ReactClass state sig anim) 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 + foreignClass <- js_createClass + (toPtr $ classForeignRender render transition) + (toPtr initialState) + (toPtr $ + ReactClassInstance + animRef + runningAnimRef + transitionRef) + + return $ ReactClass foreignClass transition + +classForeignRender :: (state -> React state sig anim ()) + -> (sig -> state -> (state, [AnimConfig sig anim])) + -> ReactClassInstance sig anim + -> state + -> IO ForeignNode +classForeignRender classRender + classTransition + ReactClassInstance { animRef + , runningAnimRef + , transitionRef + } + prevState = do + + transitions <- readIORef transitionRef + runningAnims <- readIORef runningAnimRef + prevAnim <- readIORef animRef + + let time = 0 + + let (newState, newAnims) = + mapAccumL (flip classTransition) prevState transitions + newAnims' = concat newAnims + newRunningAnims = map (`RunningAnim` 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) + + writeIORef animRef newAnim + writeIORef runningAnimRef runningAnims' + writeIORef transitionRef endAnimTrans + + return foreignNode + + +updateCb :: IORef [signal] -> signal -> IO () +updateCb ref update = modifyIORef ref (update:) diff --git a/src/React/Elements.hs b/src/React/Elements.hs index 9102c52..7670511 100644 --- a/src/React/Elements.hs +++ b/src/React/Elements.hs @@ -5,6 +5,7 @@ import Haste.Prim import React.Imports import React.Types +import React.Class -- | Parent nodes always take children, but can also optionally take a list @@ -88,6 +89,8 @@ reactLeaf :: Monad m -> ReactT state sig animj m () reactLeaf name = termLeaf (\as' _ -> js_React_DOM_leaf name as') +reactClass_ :: Monad m => ReactClass cstate csig canim -> [AttrOrHandler sig] -> ReactT state sig anim m () +reactClass_ rc = termLeaf (\_ _ -> js_React_DOM_class $ foreignClass rc) text_ :: JSString -> React state sig anim () text_ str = ReactT $ \_ -> return ([Text (fromJSStr str)], ()) diff --git a/src/React/Imports.hs b/src/React/Imports.hs index 50b00d2..bea2990 100644 --- a/src/React/Imports.hs +++ b/src/React/Imports.hs @@ -14,9 +14,9 @@ import Haste.JSON import Haste.Prim #ifdef __HASTE__ -foreign import ccall js_render :: ForeignNode -> Elem -> IO () +foreign import ccall js_render :: ForeignClass -> Elem -> IO () #else -js_render :: ForeignNode -> Elem -> IO () +js_render :: ForeignClass -> Elem -> IO () js_render = error "cannot evaluate js_render in ghc" #endif @@ -28,10 +28,14 @@ js_bezier = error "cannot evaluate js_bezier in ghc" #endif #ifdef __HASTE__ -foreign import ccall js_createClass :: Ptr (state -> React state sig anim ()) +foreign import ccall js_createClass :: Ptr (ReactClassInstance sig anim -> state -> IO ForeignNode) + -> Ptr state + -> Ptr (ReactClassInstance sig anim) -> IO ForeignClass #else -js_createClass :: Ptr (state -> React state sig anim ()) +js_createClass :: (Ptr state -> ForeignNode) + -> Ptr state + -> ReactClassInstance sig anim -> IO ForeignClass js_createClass = error "cannot evaluate js_createClass in ghc" #endif @@ -64,6 +68,13 @@ js_React_DOM_parent :: JSString -> RawAttrs -> ReactArray -> IO ForeignNode js_React_DOM_parent = error "cannot evaluate js_React_DOM_parent in ghc" #endif +#ifdef __HASTE__ +foreign import ccall js_React_DOM_class :: ForeignClass -> IO ForeignNode +#else +js_React_DOM_class :: ForeignClass -> IO ForeignNode +js_React_DOM_class = error "cannot evaluate js_React_DOM_class in ghc" +#endif + #ifdef __HASTE__ foreign import ccall js_empty_arr :: IO RawAttrs #else diff --git a/src/React/Interpret.hs b/src/React/Interpret.hs index dd5ebc8..4ecbe7e 100644 --- a/src/React/Interpret.hs +++ b/src/React/Interpret.hs @@ -75,7 +75,7 @@ interpret :: Monad m -> (sig -> IO ()) -> m (IO ForeignNode) interpret react anim cb = do - ~(child:_, ()) <- runReactT react anim + ~(child:otherChildren, ()) <- runReactT react anim return $ interpret' cb child @@ -84,10 +84,18 @@ interpret' :: (signal -> IO ()) -> IO ForeignNode interpret' cb = \case Parent f as hs children -> do + putStrLn "parentStart" children' <- forM children (interpret' cb) let hs' = map (unHandler cb) hs - element f as hs' children' + node <- element f as hs' children' + putStrLn "parentEnd" + putStrLn $ show (length children) + return node Leaf f as hs -> do + putStrLn "Leaf" let hs' = map (unHandler cb) hs element f as hs' [] - Text str -> js_React_DOM_text (toJSStr str) + Text str -> do + node <- js_React_DOM_text (toJSStr str) + putStrLn "text" + return node diff --git a/src/React/Render.hs b/src/React/Render.hs index 416331b..b424b4e 100644 --- a/src/React/Render.hs +++ b/src/React/Render.hs @@ -2,7 +2,6 @@ module React.Render ( render - , cancelRender ) where import Control.Applicative @@ -31,72 +30,11 @@ import React.Local import React.Types -doRender :: Elem -> Double -> ReactClass state sig anim -> 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 (flip classTransition) prevState transitions - newAnims' = concat newAnims - newRunningAnims = map (`RunningAnim` time) newAnims' +render :: ReactClass state sig anim + -> Elem + -> IO () +render ReactClass{foreignClass, classTransition} elem = js_render foreignClass elem - (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 state sig anim - -> 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 diff --git a/src/React/Types.hs b/src/React/Types.hs index 1d12615..edc52b9 100644 --- a/src/React/Types.hs +++ b/src/React/Types.hs @@ -17,6 +17,14 @@ import Haste.JSON import Haste.Prim import Lens.Family2 +import Data.IORef + + +data ReactClassInstance sig anim = + ReactClassInstance { animRef :: IORef anim + , runningAnimRef :: IORef [RunningAnim sig anim] + , transitionRef :: IORef [sig] + } newtype ForeignNode = ForeignNode JSAny deriving (Pack, Unpack) newtype RawAttrs = RawAttrs JSAny deriving (Pack, Unpack) From f31480c1a9384c5499a991cd8acae515b911988a Mon Sep 17 00:00:00 2001 From: John Cant Date: Sat, 7 Feb 2015 19:24:44 +0000 Subject: [PATCH 2/8] Invoke classes breaking handlers and animations --- lib/stubs.js | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/lib/stubs.js b/lib/stubs.js index 0bf929b..cf2d086 100644 --- a/lib/stubs.js +++ b/lib/stubs.js @@ -324,9 +324,14 @@ function js_raf(cb) { function js_createClass(render, initialState, hs) { return React.createClass({ render: function() { - return render(hs, this.state); + // render :: a -> b -> IO ForeignNode + // need either + // - something like runIO + // - render to not run in the IO monad + // - React to use continuation style passing + return render(hs, this.state.hs)[1]; }, - getInitialState: function() { return initialState } + getInitialState: function() { debugger; return {hs: initialState} } }); } From 19ac7b092fe6f1945e9914600ec5f1938bcc0d11 Mon Sep 17 00:00:00 2001 From: John Cant Date: Wed, 11 Feb 2015 08:55:47 +0000 Subject: [PATCH 3/8] Temporarily remove animations --- lib/stubs.js | 13 +- src/React.hs | 10 +- src/React/Anim.hs | 358 ++++++++++++++++++++--------------------- src/React/Class.hs | 85 +++------- src/React/Elements.hs | 79 ++++----- src/React/Imports.hs | 13 +- src/React/Interpret.hs | 11 +- src/React/Local.hs | 8 +- src/React/Render.hs | 3 +- src/React/Types.hs | 226 +++++++++++++------------- 10 files changed, 385 insertions(+), 421 deletions(-) diff --git a/lib/stubs.js b/lib/stubs.js index cf2d086..a144a53 100644 --- a/lib/stubs.js +++ b/lib/stubs.js @@ -242,7 +242,7 @@ function js_id(a) {return a;} // custom function js_React_DOM_leaf(name, a) { return React.DOM[name](a); } function js_React_DOM_parent(name, a, c) { return React.DOM[name](a, c); } -function js_React_DOM_class(klass) { return React.createElement(klass, null); } +function js_React_DOM_class(klass) { debugger; return React.createElement(klass, null); } function js_parseChangeEvent(raw) { // wrap the string in two constructors - Ptr and JSString @@ -321,7 +321,7 @@ function js_raf(cb) { }); } -function js_createClass(render, initialState, hs) { +function js_createClass(render, initialState) { return React.createClass({ render: function() { // render :: a -> b -> IO ForeignNode @@ -329,9 +329,9 @@ function js_createClass(render, initialState, hs) { // - something like runIO // - render to not run in the IO monad // - React to use continuation style passing - return render(hs, this.state.hs)[1]; + return B(A(render(, this.state.hs)))[1]; }, - getInitialState: function() { debugger; return {hs: initialState} } + getInitialState: function() { return {hs: initialState} } }); } @@ -340,10 +340,13 @@ function js_bezier(x0, y0, x1, y1, x) { } function js_render(e, r){ - debugger React.render(React.createElement(e, null), r); } function js_cancelRaf(id) { window.cancelAnimationFrame(id); } + +function js_overState(inst, func) { + return React.replaceState({hs: func(inst, inst.state.hs)}); +} diff --git a/src/React.hs b/src/React.hs index 943fb38..bf8d041 100644 --- a/src/React.hs +++ b/src/React.hs @@ -9,9 +9,9 @@ module React ( module X -- React.Anim - , Color(..) - , getAnimationState - , Animatable(..) -- XXX + --, Color(..) + --, getAnimationState + --, Animatable(..) -- XXX -- React.Class , ReactClass() @@ -30,8 +30,8 @@ module React , React' , Pure , RenderHandle(..) - , AnimConfig(..) - , Easing(..) + --, AnimConfig(..) + --, Easing(..) , EventProperties(..) , ModifierKeys(..) , MouseEvent(..) diff --git a/src/React/Anim.hs b/src/React/Anim.hs index e8d29b1..6f08aad 100644 --- a/src/React/Anim.hs +++ b/src/React/Anim.hs @@ -1,180 +1,180 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiWayIf, - FlexibleContexts #-} +--{-# 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 state sig anim m anim -getAnimationState = ReactT $ \anim -> return ([], anim) - -stepRunningAnims :: anim -> [(RunningAnim sig anim, Double)] -> anim -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 sig anim -> 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 +-- +--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 state sig anim m anim +--getAnimationState = ReactT $ \anim -> return ([], anim) +-- +--stepRunningAnims :: anim -> [(RunningAnim sig anim, Double)] -> anim +--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 sig anim -> 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 diff --git a/src/React/Class.hs b/src/React/Class.hs index 4df39aa..139af32 100644 --- a/src/React/Class.hs +++ b/src/React/Class.hs @@ -4,105 +4,64 @@ module React.Class , createClass ) where -import Data.IORef import Data.List import Data.Monoid import Data.Maybe import Data.Functor.Identity import React.Interpret -import React.Anim import React.Imports import React.Types import Haste import Haste.JSON import Haste.Prim +--import Haste.Foreign -- | A 'ReactClass' is a standalone component of a user interface which --- contains the state necessary to render and animate itself. Classes are +-- contains the state necessary to render itself. Classes are -- a tool for scoping. -- -- Use 'createClass' to construct. -data ReactClass state sig anim = +data ReactClass state sig = ReactClass { foreignClass :: ForeignClass - , classTransition :: (sig -> state -> (state, [AnimConfig sig anim])) + , classTransition :: (sig -> state -> state) } -- | 'ReactClass' smart constructor. -createClass :: (state -> React state sig anim ()) -- ^ render function - -> (sig -> state -> (state, [AnimConfig sig anim])) +createClass :: (state -> React state sig ()) -- ^ render function + -> (sig -> state -> state) -- ^ transition function -> state -- ^ initial state - -> anim -- ^ initial animation state -> [sig] -- signals to send on startup - -> IO (ReactClass state sig anim) -createClass render transition initialState initialAnim initialTrans = do - animRef <- newIORef initialAnim - runningAnimRef <- newIORef [] - transitionRef <- newIORef initialTrans + -> IO (ReactClass state sig) +createClass render transition initialState initialTrans = do + putStrLn "Creating Class" foreignClass <- js_createClass (toPtr $ classForeignRender render transition) (toPtr initialState) - (toPtr $ - ReactClassInstance - animRef - runningAnimRef - transitionRef) return $ ReactClass foreignClass transition -classForeignRender :: (state -> React state sig anim ()) - -> (sig -> state -> (state, [AnimConfig sig anim])) - -> ReactClassInstance sig anim - -> state +classForeignRender :: (state -> React state sig ()) + -> (sig -> state -> state) + -> Ptr ForeignClassInstance + -> Ptr state -> IO ForeignNode classForeignRender classRender classTransition - ReactClassInstance { animRef - , runningAnimRef - , transitionRef - } - prevState = do + pthis + pstate = do - transitions <- readIORef transitionRef - runningAnims <- readIORef runningAnimRef - prevAnim <- readIORef animRef + putStrLn "classForeignRender start" + n<-runIdentity $ + interpret (classRender $ fromPtr pstate) (updateCb pthis classTransition) + putStrLn "classForeignRender done" + return n - let time = 0 +updateCb :: Ptr ForeignClassInstance -> (sig -> state -> state) -> sig -> IO () +updateCb this trans sig = js_overState this $ toPtr (toPtr.(trans sig).fromPtr) - let (newState, newAnims) = - mapAccumL (flip classTransition) prevState transitions - newAnims' = concat newAnims - newRunningAnims = map (`RunningAnim` 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) - - writeIORef animRef newAnim - writeIORef runningAnimRef runningAnims' - writeIORef transitionRef endAnimTrans - - return foreignNode - - -updateCb :: IORef [signal] -> signal -> IO () -updateCb ref update = modifyIORef ref (update:) diff --git a/src/React/Elements.hs b/src/React/Elements.hs index 7670511..efa2618 100644 --- a/src/React/Elements.hs +++ b/src/React/Elements.hs @@ -35,21 +35,21 @@ class TermParent result where termParent :: ForeignRender -> TermParentArg result -> result -instance (Monad m, f ~ ReactT state sig anim m a) => - TermParent (f -> ReactT state sig anim m a) where - type TermParentArg (f -> ReactT state sig anim m a) = [AttrOrHandler sig] +instance (Monad m, f ~ ReactT state sig m a) => + TermParent (f -> ReactT state sig m a) where + type TermParentArg (f -> ReactT state sig m a) = [AttrOrHandler sig] - termParent render attrs children = ReactT $ \anim -> do - ~(childNodes, a) <- runReactT children anim + termParent render attrs children = ReactT $ do + ~(childNodes, a) <- runReactT children let (hs, as) = separateAttrs attrs return ([Parent render as hs childNodes], a) -instance Monad m => TermParent (ReactT state sig anim m a) where - type TermParentArg (ReactT state sig anim m a) = ReactT state sig anim m a +instance Monad m => TermParent (ReactT state sig m a) where + type TermParentArg (ReactT state sig m a) = ReactT state sig m a - termParent render children = ReactT $ \anim -> do - ~(childNodes, a) <- runReactT children anim + termParent render children = ReactT $ do + ~(childNodes, a) <- runReactT children return ([Parent render [] [] childNodes], a) @@ -70,8 +70,8 @@ reactParent name = termParent (js_React_DOM_parent name) termLeaf :: Monad m => ForeignRender -> [AttrOrHandler sig] - -> ReactT state sig anim m () -termLeaf render attrs = ReactT $ \_ -> do + -> ReactT state sig m () +termLeaf render attrs = ReactT $ do let (hs, as) = separateAttrs attrs return ([Leaf render as hs], ()) @@ -79,21 +79,24 @@ termLeaf render attrs = ReactT $ \_ -> do foreignLeaf :: Monad m => ForeignRender -> [AttrOrHandler sig] - -> ReactT state sig anim m () + -> ReactT state sig m () foreignLeaf = termLeaf reactLeaf :: Monad m => JSString -> [AttrOrHandler sig] - -> ReactT state sig animj m () + -> ReactT state sig m () reactLeaf name = termLeaf (\as' _ -> js_React_DOM_leaf name as') -reactClass_ :: Monad m => ReactClass cstate csig canim -> [AttrOrHandler sig] -> ReactT state sig anim m () +reactClass_ :: Monad m + => ReactClass cstate csig + -> [AttrOrHandler sig] + -> ReactT state sig m () reactClass_ rc = termLeaf (\_ _ -> js_React_DOM_class $ foreignClass rc) -text_ :: JSString -> React state sig anim () -text_ str = ReactT $ \_ -> return ([Text (fromJSStr str)], ()) +text_ :: JSString -> React state sig () +text_ str = ReactT $ return ([Text (fromJSStr str)], ()) a_ :: TermParent t => TermParentArg t -> t a_ = reactParent "a" @@ -369,49 +372,49 @@ video_ :: TermParent t => TermParentArg t -> t video_ = reactParent "video" -area_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +area_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () area_ = reactLeaf "area" -base_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +base_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () base_ = reactLeaf "base" -br_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +br_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () br_ = reactLeaf "br" -col_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +col_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () col_ = reactLeaf "col" -embed_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +embed_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () embed_ = reactLeaf "embed" -hr_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +hr_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () hr_ = reactLeaf "hr" -img_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +img_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () img_ = reactLeaf "img" -input_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +input_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () input_ = reactLeaf "input" -keygen_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +keygen_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () keygen_ = reactLeaf "keygen" -link_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +link_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () link_ = reactLeaf "link" -meta_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +meta_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () meta_ = reactLeaf "meta" -param_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +param_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () param_ = reactLeaf "param" -source_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +source_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () source_ = reactLeaf "source" -track_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +track_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () track_ = reactLeaf "track" -wbr_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +wbr_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () wbr_ = reactLeaf "wbr" -- script :: RawAttrs -> JSString -> IO ForeignNode @@ -451,23 +454,23 @@ stop_ = reactParent "stop" tspan_ :: TermParent t => TermParentArg t -> t tspan_ = reactParent "tspan" -circle_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +circle_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () circle_ = reactLeaf "circle" -ellipse_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +ellipse_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () ellipse_ = reactLeaf "ellipse" -line_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +line_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () line_ = reactLeaf "line" -path_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +path_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () path_ = reactLeaf "path" -polygon_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +polygon_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () polygon_ = reactLeaf "polygon" -polyline_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +polyline_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () polyline_ = reactLeaf "polyline" -rect_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig anim m () +rect_ :: Monad m => [AttrOrHandler sig] -> ReactT state sig m () rect_ = reactLeaf "rect" diff --git a/src/React/Imports.hs b/src/React/Imports.hs index bea2990..eef90e3 100644 --- a/src/React/Imports.hs +++ b/src/React/Imports.hs @@ -13,6 +13,13 @@ import Haste.Foreign import Haste.JSON import Haste.Prim +#ifdef __HASTE__ +foreign import ccall js_overState:: Ptr ForeignClassInstance -> Ptr (Ptr state -> Ptr state) -> IO () +#else +js_overState:: Ptr ForeignClassInstance -> Ptr (Ptr state -> Ptr state) -> IO () +js_overState = error "cannot evaluate js_overState in ghc" +#endif + #ifdef __HASTE__ foreign import ccall js_render :: ForeignClass -> Elem -> IO () #else @@ -28,14 +35,12 @@ js_bezier = error "cannot evaluate js_bezier in ghc" #endif #ifdef __HASTE__ -foreign import ccall js_createClass :: Ptr (ReactClassInstance sig anim -> state -> IO ForeignNode) +foreign import ccall js_createClass :: Ptr (Ptr ForeignClassInstance -> Ptr state -> IO ForeignNode) -> Ptr state - -> Ptr (ReactClassInstance sig anim) -> IO ForeignClass #else -js_createClass :: (Ptr state -> ForeignNode) +js_createClass :: Ptr (Ptr ForeignClassInstance -> Ptr state -> ForeignNode) -> Ptr state - -> ReactClassInstance sig anim -> IO ForeignClass js_createClass = error "cannot evaluate js_createClass in ghc" #endif diff --git a/src/React/Interpret.hs b/src/React/Interpret.hs index 4ecbe7e..222a73c 100644 --- a/src/React/Interpret.hs +++ b/src/React/Interpret.hs @@ -70,12 +70,11 @@ setIx arr i Null = return () -- getDomNode r = fmap fromPtr (js_React_getDomNode r) interpret :: Monad m - => ReactT state sig anim m () - -> anim + => ReactT state sig m () -> (sig -> IO ()) -> m (IO ForeignNode) -interpret react anim cb = do - ~(child:otherChildren, ()) <- runReactT react anim +interpret react cb = do + ~(child:otherChildren, ()) <- runReactT react return $ interpret' cb child @@ -85,17 +84,17 @@ interpret' :: (signal -> IO ()) interpret' cb = \case Parent f as hs children -> do putStrLn "parentStart" + putStrLn $ show (length children) children' <- forM children (interpret' cb) let hs' = map (unHandler cb) hs node <- element f as hs' children' putStrLn "parentEnd" - putStrLn $ show (length children) return node Leaf f as hs -> do putStrLn "Leaf" let hs' = map (unHandler cb) hs element f as hs' [] Text str -> do - node <- js_React_DOM_text (toJSStr str) putStrLn "text" + node <- js_React_DOM_text (toJSStr str) return node diff --git a/src/React/Local.hs b/src/React/Local.hs index f310589..b547748 100644 --- a/src/React/Local.hs +++ b/src/React/Local.hs @@ -25,12 +25,12 @@ instance GeneralizeSignal Void a where locally :: (Monad m, GeneralizeSignal sigloc siggen) - => ReactT stateloc sigloc anim m x - -> ReactT stategen siggen anim m x + => ReactT stateloc sigloc m x + -> ReactT stategen siggen m x locally nested = result where - result = ReactT $ \anim -> do + result = ReactT $ do let gensig = nodeConvert generalizeSignal - (nodes, x) <- runReactT nested anim + (nodes, x) <- runReactT nested return (map gensig nodes, x) diff --git a/src/React/Render.hs b/src/React/Render.hs index b424b4e..d0e22dc 100644 --- a/src/React/Render.hs +++ b/src/React/Render.hs @@ -19,7 +19,6 @@ import Haste.Foreign import Haste.JSON import Haste.Prim -import React.Anim import React.Attrs import React.Class import React.Elements @@ -33,7 +32,7 @@ import React.Types -render :: ReactClass state sig anim +render :: ReactClass state sig -> Elem -> IO () render ReactClass{foreignClass, classTransition} elem = js_render foreignClass elem diff --git a/src/React/Types.hs b/src/React/Types.hs index edc52b9..2a761bf 100644 --- a/src/React/Types.hs +++ b/src/React/Types.hs @@ -20,11 +20,7 @@ import Lens.Family2 import Data.IORef -data ReactClassInstance sig anim = - ReactClassInstance { animRef :: IORef anim - , runningAnimRef :: IORef [RunningAnim sig anim] - , transitionRef :: IORef [sig] - } +data ForeignClassInstance newtype ForeignNode = ForeignNode JSAny deriving (Pack, Unpack) newtype RawAttrs = RawAttrs JSAny deriving (Pack, Unpack) @@ -64,131 +60,131 @@ data ReactNode signal | Text String -- TODO(joel) JSString? --- | Standard easing functions. These are used to 'interpolate' smoothly. --- --- See for visualizations. -data Easing - = Linear - - | EaseInQuad - | EaseOutQuad - | EaseInOutQuad - - | EaseInCubic - | EaseOutCubic - | EaseInOutCubic - - | EaseInQuart - | EaseOutQuart - | EaseInOutQuart - - | EaseInQuint - | EaseOutQuint - | EaseInOutQuint - - | EaseInElastic - | EaseOutElastic - | EaseInOutElastic - - | EaseInBounce - | EaseOutBounce - | EaseInOutBounce - - | EaseBezier Double Double Double Double - | EaseInSine - | EaseOutSine - deriving (Show, Eq, Ord) - --- | 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 - - --- 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 sig anim = forall a. (Animatable a) => AnimConfig { - -- | How long this animation lasts in milliseconds - duration :: Double - -- | Where does this animation start and end? - , endpoints :: (a, a) - -- | Pointer to this field within 'AnimationState' - , lens :: Lens' anim a - -- | How is the animation eased? - , easing :: Easing - -- | Do something when it's finished? - , onComplete :: Bool -> Maybe sig - } - - -data RunningAnim sig anim = RunningAnim - { config :: AnimConfig sig anim - , beganAt :: Double - } - - -newtype ReactT state sig anim m a = ReactT - { runReactT :: anim -> m ([ReactNode sig], a) } - - -type React state sig anim = ReactT state sig anim Identity -type React' state sig anim = ReactT state sig anim Identity () +-- -- | Standard easing functions. These are used to 'interpolate' smoothly. +-- -- +-- -- See for visualizations. +-- data Easing +-- = Linear +-- +-- | EaseInQuad +-- | EaseOutQuad +-- | EaseInOutQuad +-- +-- | EaseInCubic +-- | EaseOutCubic +-- | EaseInOutCubic +-- +-- | EaseInQuart +-- | EaseOutQuart +-- | EaseInOutQuart +-- +-- | EaseInQuint +-- | EaseOutQuint +-- | EaseInOutQuint +-- +-- | EaseInElastic +-- | EaseOutElastic +-- | EaseInOutElastic +-- +-- | EaseInBounce +-- | EaseOutBounce +-- | EaseInOutBounce +-- +-- | EaseBezier Double Double Double Double +-- | EaseInSine +-- | EaseOutSine +-- deriving (Show, Eq, Ord) +-- +-- -- | 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 +-- +-- +-- -- 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 sig anim = forall a. (Animatable a) => AnimConfig { +-- -- | How long this animation lasts in milliseconds +-- duration :: Double +-- -- | Where does this animation start and end? +-- , endpoints :: (a, a) +-- -- | Pointer to this field within 'AnimationState' +-- , lens :: Lens' anim a +-- -- | How is the animation eased? +-- , easing :: Easing +-- -- | Do something when it's finished? +-- , onComplete :: Bool -> Maybe sig +-- } +-- +-- +-- data RunningAnim sig anim = RunningAnim +-- { config :: AnimConfig sig anim +-- , beganAt :: Double +-- } + + +newtype ReactT state sig m a = ReactT + { runReactT :: m ([ReactNode sig], a) } + + +type React state sig = ReactT state sig Identity +type React' state sig = ReactT state sig Identity () type Pure a = a () Void () -instance (Monad m, Monoid a) => Monoid (ReactT state sig anim m a) where - mempty = ReactT $ \_ -> return ([], mempty) - mappend f1 f2 = ReactT $ \anim -> do - ~(c1, a) <- runReactT f1 anim - ~(c2, b) <- runReactT f2 anim +instance (Monad m, Monoid a) => Monoid (ReactT state sig m a) where + mempty = ReactT $ return ([], mempty) + mappend f1 f2 = ReactT $ do + ~(c1, a) <- runReactT f1 + ~(c2, b) <- runReactT f2 return (c1 <> c2, a <> b) -instance Monad m => Functor (ReactT state sig anim m) where +instance Monad m => Functor (ReactT state sig m) where fmap = liftM -instance Monad m => Applicative (ReactT state sig anim m) where +instance Monad m => Applicative (ReactT state sig m) where pure = return (<*>) = ap -instance (Monad m, a ~ ()) => IsString (ReactT state sig anim m a) where - fromString str = ReactT $ \_ -> return ([Text str], ()) +instance (Monad m, a ~ ()) => IsString (ReactT state sig m a) where + fromString str = ReactT $ return ([Text str], ()) -instance Monad m => Monad (ReactT state sig anim m) where - return a = ReactT $ \_ -> return ([], a) - m >>= f = ReactT $ \anim -> do - ~(c1, a) <- runReactT m anim - ~(c2, b) <- runReactT (f a) anim +instance Monad m => Monad (ReactT state sig m) where + return a = ReactT $ return ([], a) + m >>= f = ReactT $ do + ~(c1, a) <- runReactT m + ~(c2, b) <- runReactT (f a) return (c1 <> c2, b) From 294e1190ed1ffb892a38f8a73d87b0119ca29462 Mon Sep 17 00:00:00 2001 From: John Cant Date: Thu, 12 Feb 2015 16:49:07 +0000 Subject: [PATCH 4/8] Completely rm animations. Tighter JS integration. --- lib/stubs.js | 10 +++++----- src/React/Class.hs | 16 ++++++---------- src/React/Imports.hs | 8 ++++---- src/React/Interpret.hs | 5 ----- src/React/Types.hs | 3 +-- 5 files changed, 16 insertions(+), 26 deletions(-) diff --git a/lib/stubs.js b/lib/stubs.js index a144a53..762878e 100644 --- a/lib/stubs.js +++ b/lib/stubs.js @@ -242,7 +242,7 @@ function js_id(a) {return a;} // custom function js_React_DOM_leaf(name, a) { return React.DOM[name](a); } function js_React_DOM_parent(name, a, c) { return React.DOM[name](a, c); } -function js_React_DOM_class(klass) { debugger; return React.createElement(klass, null); } +function js_React_DOM_class(klass) { return React.createElement(klass, null); } function js_parseChangeEvent(raw) { // wrap the string in two constructors - Ptr and JSString @@ -321,7 +321,7 @@ function js_raf(cb) { }); } -function js_createClass(render, initialState) { +function js_createClass(render, initialState, _) { return React.createClass({ render: function() { // render :: a -> b -> IO ForeignNode @@ -329,9 +329,9 @@ function js_createClass(render, initialState) { // - something like runIO // - render to not run in the IO monad // - React to use continuation style passing - return B(A(render(, this.state.hs)))[1]; + return B(A(render, [[0, this], [0, this.state.hs], 0]))[1]; }, - getInitialState: function() { return {hs: initialState} } + getInitialState: function() { debugger; return {hs: B(A(initialState, [0]))} } }); } @@ -348,5 +348,5 @@ function js_cancelRaf(id) { } function js_overState(inst, func) { - return React.replaceState({hs: func(inst, inst.state.hs)}); + inst.replaceState({hs: B(A(func, [[0, inst.state.hs], 0]))[1]}); } diff --git a/src/React/Class.hs b/src/React/Class.hs index 139af32..20739c9 100644 --- a/src/React/Class.hs +++ b/src/React/Class.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns, OverloadedStrings, BangPatterns #-} module React.Class ( ReactClass(..) , createClass @@ -39,7 +39,6 @@ createClass :: (state -> React state sig ()) -- ^ render function -> IO (ReactClass state sig) createClass render transition initialState initialTrans = do - putStrLn "Creating Class" foreignClass <- js_createClass (toPtr $ classForeignRender render transition) (toPtr initialState) @@ -48,20 +47,17 @@ createClass render transition initialState initialTrans = do classForeignRender :: (state -> React state sig ()) -> (sig -> state -> state) - -> Ptr ForeignClassInstance + -> ForeignClassInstance -> Ptr state -> IO ForeignNode classForeignRender classRender classTransition - pthis + this pstate = do - putStrLn "classForeignRender start" - n<-runIdentity $ - interpret (classRender $ fromPtr pstate) (updateCb pthis classTransition) - putStrLn "classForeignRender done" - return n + runIdentity $ + interpret (classRender $ fromPtr pstate) (updateCb this classTransition) -updateCb :: Ptr ForeignClassInstance -> (sig -> state -> state) -> sig -> IO () +updateCb :: ForeignClassInstance -> (sig -> state -> state) -> sig -> IO () updateCb this trans sig = js_overState this $ toPtr (toPtr.(trans sig).fromPtr) diff --git a/src/React/Imports.hs b/src/React/Imports.hs index eef90e3..38232bf 100644 --- a/src/React/Imports.hs +++ b/src/React/Imports.hs @@ -14,9 +14,9 @@ import Haste.JSON import Haste.Prim #ifdef __HASTE__ -foreign import ccall js_overState:: Ptr ForeignClassInstance -> Ptr (Ptr state -> Ptr state) -> IO () +foreign import ccall js_overState:: ForeignClassInstance -> Ptr (Ptr state -> Ptr state) -> IO () #else -js_overState:: Ptr ForeignClassInstance -> Ptr (Ptr state -> Ptr state) -> IO () +js_overState:: ForeignClassInstance -> Ptr (Ptr state -> Ptr state) -> IO () js_overState = error "cannot evaluate js_overState in ghc" #endif @@ -35,11 +35,11 @@ js_bezier = error "cannot evaluate js_bezier in ghc" #endif #ifdef __HASTE__ -foreign import ccall js_createClass :: Ptr (Ptr ForeignClassInstance -> Ptr state -> IO ForeignNode) +foreign import ccall js_createClass :: Ptr (ForeignClassInstance -> Ptr state -> IO ForeignNode) -> Ptr state -> IO ForeignClass #else -js_createClass :: Ptr (Ptr ForeignClassInstance -> Ptr state -> ForeignNode) +js_createClass :: Ptr (ForeignClassInstance -> Ptr state -> ForeignNode) -> Ptr state -> IO ForeignClass js_createClass = error "cannot evaluate js_createClass in ghc" diff --git a/src/React/Interpret.hs b/src/React/Interpret.hs index 222a73c..7b27097 100644 --- a/src/React/Interpret.hs +++ b/src/React/Interpret.hs @@ -83,18 +83,13 @@ interpret' :: (signal -> IO ()) -> IO ForeignNode interpret' cb = \case Parent f as hs children -> do - putStrLn "parentStart" - putStrLn $ show (length children) children' <- forM children (interpret' cb) let hs' = map (unHandler cb) hs node <- element f as hs' children' - putStrLn "parentEnd" return node Leaf f as hs -> do - putStrLn "Leaf" let hs' = map (unHandler cb) hs element f as hs' [] Text str -> do - putStrLn "text" node <- js_React_DOM_text (toJSStr str) return node diff --git a/src/React/Types.hs b/src/React/Types.hs index 2a761bf..d9f1091 100644 --- a/src/React/Types.hs +++ b/src/React/Types.hs @@ -20,8 +20,7 @@ import Lens.Family2 import Data.IORef -data ForeignClassInstance - +newtype ForeignClassInstance = ForeignClassInstance JSAny deriving (Pack, Unpack) newtype ForeignNode = ForeignNode JSAny deriving (Pack, Unpack) newtype RawAttrs = RawAttrs JSAny deriving (Pack, Unpack) newtype ReactArray = ReactArray JSAny deriving (Pack, Unpack) From 92b220ec2a4fa3c9a3a735421c0336c7f50be0b5 Mon Sep 17 00:00:00 2001 From: John Cant Date: Sat, 14 Feb 2015 19:46:00 +0000 Subject: [PATCH 5/8] Reintroduce animations. Compiling. --- lib/stubs.js | 12 ++ react-haskell.cabal | 2 + src/React.hs | 4 +- src/React/Anim.hs | 444 ++++++++++++++++++++++++---------------- src/React/Anim/Class.hs | 102 +++++++++ src/React/Class.hs | 18 +- src/React/ElemTypes.hs | 44 ++++ src/React/Elements.hs | 76 +------ src/React/Imports.hs | 22 ++ src/React/Render.hs | 40 +--- src/React/Types.hs | 128 ++++-------- 11 files changed, 505 insertions(+), 387 deletions(-) create mode 100644 src/React/Anim/Class.hs create mode 100644 src/React/ElemTypes.hs diff --git a/lib/stubs.js b/lib/stubs.js index 762878e..aed8240 100644 --- a/lib/stubs.js +++ b/lib/stubs.js @@ -347,6 +347,18 @@ function js_cancelRaf(id) { window.cancelAnimationFrame(id); } +function js_getState(inst) { + return inst.state; +} + +function js_setState(inst, state) { + inst.replaceState({hs: state}); +} + function js_overState(inst, func) { inst.replaceState({hs: B(A(func, [[0, inst.state.hs], 0]))[1]}); } + +function js_performance_now() { + return window.performance.now(); +} diff --git a/react-haskell.cabal b/react-haskell.cabal index 2deb988..e5d825a 100644 --- a/react-haskell.cabal +++ b/react-haskell.cabal @@ -54,9 +54,11 @@ library exposed-modules: React other-modules: React.Anim, + React.Anim.Class, React.Attrs, React.Class, React.Elements, + React.ElemTypes React.Events, React.Imports, React.Interpret, diff --git a/src/React.hs b/src/React.hs index bf8d041..e492655 100644 --- a/src/React.hs +++ b/src/React.hs @@ -57,13 +57,13 @@ module React -- store elem in monad -- escaping / dangerouslySetInnerHTML -import React.Anim import React.Class -- import React.Imports -- import React.Interpret import React.Local -import React.Render import React.Types +import React.Render +import React.ElemTypes import React.Attrs as X import React.Elements as X diff --git a/src/React/Anim.hs b/src/React/Anim.hs index 6f08aad..e1eca08 100644 --- a/src/React/Anim.hs +++ b/src/React/Anim.hs @@ -1,180 +1,266 @@ ---{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiWayIf, --- FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiWayIf, FlexibleContexts, ExistentialQuantification, Rank2Types #-} 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 state sig anim m anim ---getAnimationState = ReactT $ \anim -> return ([], anim) --- ---stepRunningAnims :: anim -> [(RunningAnim sig anim, Double)] -> anim ---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 sig anim -> 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 + +import Control.Applicative +import Data.IORef +import Data.Monoid + +import Haste +import Lens.Family2 + +import React.Imports +import React.Types + + +-- | Standard easing functions. These are used to 'interpolate' smoothly. +-- +-- See for visualizations. +data Easing + = Linear + + | EaseInQuad + | EaseOutQuad + | EaseInOutQuad + + | EaseInCubic + | EaseOutCubic + | EaseInOutCubic + + | EaseInQuart + | EaseOutQuart + | EaseInOutQuart + + | EaseInQuint + | EaseOutQuint + | EaseInOutQuint + + | EaseInElastic + | EaseOutElastic + | EaseInOutElastic + + | EaseInBounce + | EaseOutBounce + | EaseInOutBounce + + | EaseBezier Double Double Double Double + | EaseInSine + | EaseOutSine + deriving (Show, Eq, Ord) + +-- | 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 + +-- 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 sig anim = forall a. (Animatable a) => AnimConfig { + -- | How long this animation lasts in milliseconds + duration :: Double + -- | Where does this animation start and end? + , endpoints :: (a, a) + -- | Pointer to this field within 'AnimationState' + , lens :: Lens' anim a + -- | How is the animation eased? + , easing :: Easing + -- | Do something when it's finished? + , onComplete :: Bool -> Maybe sig + } + + +data RunningAnim sig anim = RunningAnim + { config :: AnimConfig sig anim + , beganAt :: Double + } + + +-- 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 + + +stepRunningAnims :: anim -> [(RunningAnim sig anim, Double)] -> anim +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 sig anim -> 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 diff --git a/src/React/Anim/Class.hs b/src/React/Anim/Class.hs new file mode 100644 index 0000000..74f33f4 --- /dev/null +++ b/src/React/Anim/Class.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE NamedFieldPuns #-} +module React.Anim.Class where + +import Lens.Family2 +import Data.Functor.Identity +import Data.Monoid +import Data.List +import Data.Maybe +import Haste.Prim + +import React.Types +import React.Imports +import React.Interpret +import React.Anim + +import qualified React.Class as V + + + +-- Animation is now a kind of middleware between React JS and ReactClass. + + +data WithAnimState u sig anim = + WithAnimState { userState :: u + , anim :: anim + , runningAnims :: [RunningAnim sig anim] + } + +-- This class can wrap V.ReactClass, but only if the V.ReactClass transition lives inside the IO monad, or the render lives inside the IO monad. +-- Instead, it will just have to be a different implementation +createClass :: (state -> anim -> React (WithAnimState state sig anim) sig ()) + -> (sig -> state -> (state, [AnimConfig sig anim])) + -> state + -> anim + -> [sig] + -> IO (ReactClass (WithAnimState state sig anim) sig) +createClass render transition initialState anim initialTrans = do + + foreignClass <- js_createClass + (toPtr $ classForeignRender render transition) + (toPtr $ WithAnimState + initialState + anim + []) + + return $ ReactClass foreignClass + + +classForeignRender :: (state -> anim -> React (WithAnimState state sig anim) sig ()) + -> (sig -> state -> (state, [AnimConfig sig anim])) + -> ForeignClassInstance + -> Ptr (WithAnimState state sig anim) + -> IO ForeignNode +classForeignRender classRender + classTransition + this + pstate = do + + let (WithAnimState ustate a ra) = fromPtr pstate + + runIdentity $ + interpret (classRender ustate a) (updateCb this classTransition) + +updateCb :: ForeignClassInstance + -> (sig -> state -> (state, [AnimConfig sig anim])) + -> sig + -> IO () +updateCb this trans sig = do + time <- js_performance_now + state@WithAnimState{userState, anim, runningAnims} <- fromPtr =<< js_getState this + + let (newState, newAnims) = trans sig userState + + newRunningAnims = map (`RunningAnim` time) newAnims + + js_raf $ toPtr $ animTick this + js_setState this $ toPtr $ WithAnimState newState anim runningAnims + + +animTick :: ForeignClassInstance + -> Double + -> IO () +animTick this time = do + + state@WithAnimState{userState, anim, runningAnims} <- fromPtr =<< js_getState this + + let (runningAnims', endingAnims) = partition + (\(RunningAnim AnimConfig{duration} beganAt) -> + beganAt + duration > time) + runningAnims + + endingAnims' = zip endingAnims [1..] + runningAnims'' = zip runningAnims' (map (lerp time) runningAnims') + newAnim = stepRunningAnims anim (endingAnims' ++ runningAnims'') + + endAnimTrans = mapMaybe + (\anim -> onComplete (config anim) True) + endingAnims + + js_raf $ toPtr $ animTick this + js_setState this $ toPtr $ WithAnimState userState newAnim (map fst runningAnims'') + diff --git a/src/React/Class.hs b/src/React/Class.hs index 20739c9..64b2e7f 100644 --- a/src/React/Class.hs +++ b/src/React/Class.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NamedFieldPuns, OverloadedStrings, BangPatterns #-} +{-# LANGUAGE NamedFieldPuns, OverloadedStrings, BangPatterns, TypeFamilies #-} module React.Class ( ReactClass(..) , createClass @@ -9,8 +9,8 @@ import Data.Monoid import Data.Maybe import Data.Functor.Identity import React.Interpret - import React.Imports +import React.ElemTypes import React.Types import Haste @@ -24,10 +24,7 @@ import Haste.Prim -- a tool for scoping. -- -- Use 'createClass' to construct. -data ReactClass state sig = - ReactClass { foreignClass :: ForeignClass - , classTransition :: (sig -> state -> state) - } + -- | 'ReactClass' smart constructor. @@ -43,7 +40,7 @@ createClass render transition initialState initialTrans = do (toPtr $ classForeignRender render transition) (toPtr initialState) - return $ ReactClass foreignClass transition + return $ ReactClass foreignClass classForeignRender :: (state -> React state sig ()) -> (sig -> state -> state) @@ -58,6 +55,11 @@ classForeignRender classRender runIdentity $ interpret (classRender $ fromPtr pstate) (updateCb this classTransition) -updateCb :: ForeignClassInstance -> (sig -> state -> state) -> sig -> IO () +updateCb :: ForeignClassInstance + -> (sig -> state -> state) + -> sig + -> IO () updateCb this trans sig = js_overState this $ toPtr (toPtr.(trans sig).fromPtr) + + diff --git a/src/React/ElemTypes.hs b/src/React/ElemTypes.hs new file mode 100644 index 0000000..df86c32 --- /dev/null +++ b/src/React/ElemTypes.hs @@ -0,0 +1,44 @@ +module React.ElemTypes where + +import Haste.Prim +import React.Types +import React.Imports + +-- Useful for defining elements + +foreignParent :: TermParent t + => ForeignRender + -> TermParentArg t + -> t +foreignParent = termParent + + +reactParent :: TermParent t + => JSString + -> TermParentArg t + -> t +reactParent name = termParent (js_React_DOM_parent name) + + +termLeaf :: Monad m + => ForeignRender + -> [AttrOrHandler sig] + -> ReactT state sig m () +termLeaf render attrs = ReactT $ do + let (hs, as) = separateAttrs attrs + return ([Leaf render as hs], ()) + + +foreignLeaf :: Monad m + => ForeignRender + -> [AttrOrHandler sig] + -> ReactT state sig m () +foreignLeaf = termLeaf + + +reactLeaf :: Monad m + => JSString + -> [AttrOrHandler sig] + -> ReactT state sig m () +reactLeaf name = termLeaf (\as' _ -> js_React_DOM_leaf name as') + diff --git a/src/React/Elements.hs b/src/React/Elements.hs index efa2618..9421d0c 100644 --- a/src/React/Elements.hs +++ b/src/React/Elements.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances, NamedFieldPuns #-} module React.Elements where import Haste.Prim @@ -6,6 +6,7 @@ import Haste.Prim import React.Imports import React.Types import React.Class +import React.ElemTypes -- | Parent nodes always take children, but can also optionally take a list @@ -22,78 +23,9 @@ import React.Class -- @ -- 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 :: * - termParent :: ForeignRender -> TermParentArg result -> result - - -instance (Monad m, f ~ ReactT state sig m a) => - TermParent (f -> ReactT state sig m a) where - type TermParentArg (f -> ReactT state sig m a) = [AttrOrHandler sig] - - termParent render attrs children = ReactT $ do - ~(childNodes, a) <- runReactT children - let (hs, as) = separateAttrs attrs - return ([Parent render as hs childNodes], a) - - -instance Monad m => TermParent (ReactT state sig m a) where - type TermParentArg (ReactT state sig m a) = ReactT state sig m a - - termParent render children = ReactT $ do - ~(childNodes, a) <- runReactT children - return ([Parent render [] [] childNodes], a) - - -foreignParent :: TermParent t - => ForeignRender - -> TermParentArg t - -> t -foreignParent = termParent - - -reactParent :: TermParent t - => JSString - -> TermParentArg t - -> t -reactParent name = termParent (js_React_DOM_parent name) - - -termLeaf :: Monad m - => ForeignRender - -> [AttrOrHandler sig] - -> ReactT state sig m () -termLeaf render attrs = ReactT $ do - let (hs, as) = separateAttrs attrs - return ([Leaf render as hs], ()) - - -foreignLeaf :: Monad m - => ForeignRender - -> [AttrOrHandler sig] - -> ReactT state sig m () -foreignLeaf = termLeaf - - -reactLeaf :: Monad m - => JSString - -> [AttrOrHandler sig] - -> ReactT state sig m () -reactLeaf name = termLeaf (\as' _ -> js_React_DOM_leaf name as') - -reactClass_ :: Monad m - => ReactClass cstate csig - -> [AttrOrHandler sig] - -> ReactT state sig m () -reactClass_ rc = termLeaf (\_ _ -> js_React_DOM_class $ foreignClass rc) +reactClass_ :: ReactClass state sig -> React state sig () +reactClass_ ReactClass{foreignClass} = termLeaf (\_ _ -> js_React_DOM_class $ foreignClass) [] text_ :: JSString -> React state sig () text_ str = ReactT $ return ([Text (fromJSStr str)], ()) diff --git a/src/React/Imports.hs b/src/React/Imports.hs index 38232bf..1937463 100644 --- a/src/React/Imports.hs +++ b/src/React/Imports.hs @@ -13,6 +13,28 @@ import Haste.Foreign import Haste.JSON import Haste.Prim + +#ifdef __HASTE +foreign import ccall js_performance_now:: IO Double +#else +js_performance_now:: IO Double +js_performance_now = error "cannot evaluate js_performance_now in ghc" +#endif + +#ifdef __HASTE__ +foreign import ccall js_getState:: ForeignClassInstance -> IO (Ptr state) +#else +js_getState:: ForeignClassInstance -> IO (Ptr state) +js_getState = error "cannot evaluate js_getState in ghc" +#endif + +#ifdef __HASTE__ +foreign import ccall js_setState:: ForeignClassInstance -> Ptr state -> IO () +#else +js_setState:: ForeignClassInstance -> Ptr state -> IO () +js_setState = error "cannot evaluate js_setState in ghc" +#endif + #ifdef __HASTE__ foreign import ccall js_overState:: ForeignClassInstance -> Ptr (Ptr state -> Ptr state) -> IO () #else diff --git a/src/React/Render.hs b/src/React/Render.hs index d0e22dc..7bce11f 100644 --- a/src/React/Render.hs +++ b/src/React/Render.hs @@ -1,39 +1,11 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts, NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} +module React.Render where -module React.Render - ( render - ) 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.Attrs -import React.Class -import React.Elements -import React.Events -import React.Imports -import React.Interpret -import React.Local import React.Types +import React.Imports +import Haste.DOM - - -render :: ReactClass state sig - -> Elem - -> IO () -render ReactClass{foreignClass, classTransition} elem = js_render foreignClass elem - +render :: ReactClass state sig -> Elem -> IO () +render ReactClass{foreignClass} elem = js_render foreignClass elem diff --git a/src/React/Types.hs b/src/React/Types.hs index d9f1091..7b4a690 100644 --- a/src/React/Types.hs +++ b/src/React/Types.hs @@ -20,6 +20,9 @@ import Lens.Family2 import Data.IORef +data ReactClass state sig = + ReactClass { foreignClass :: ForeignClass + } newtype ForeignClassInstance = ForeignClassInstance JSAny deriving (Pack, Unpack) newtype ForeignNode = ForeignNode JSAny deriving (Pack, Unpack) newtype RawAttrs = RawAttrs JSAny deriving (Pack, Unpack) @@ -51,104 +54,13 @@ type Attrs = [(JSString, JSON)] -- it'd be super cool to restrict `Pre` to a string somehow (restrict the -- underlying monad so it can only set attrs and string?) - + -- data ReactNode signal = Parent ForeignRender Attrs [EventHandler signal] [ReactNode signal] | Leaf ForeignRender Attrs [EventHandler signal] -- | Pre Attrs Handlers [ReactNode] | Text String -- TODO(joel) JSString? - --- -- | Standard easing functions. These are used to 'interpolate' smoothly. --- -- --- -- See for visualizations. --- data Easing --- = Linear --- --- | EaseInQuad --- | EaseOutQuad --- | EaseInOutQuad --- --- | EaseInCubic --- | EaseOutCubic --- | EaseInOutCubic --- --- | EaseInQuart --- | EaseOutQuart --- | EaseInOutQuart --- --- | EaseInQuint --- | EaseOutQuint --- | EaseInOutQuint --- --- | EaseInElastic --- | EaseOutElastic --- | EaseInOutElastic --- --- | EaseInBounce --- | EaseOutBounce --- | EaseInOutBounce --- --- | EaseBezier Double Double Double Double --- | EaseInSine --- | EaseOutSine --- deriving (Show, Eq, Ord) --- --- -- | 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 --- --- --- -- 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 sig anim = forall a. (Animatable a) => AnimConfig { --- -- | How long this animation lasts in milliseconds --- duration :: Double --- -- | Where does this animation start and end? --- , endpoints :: (a, a) --- -- | Pointer to this field within 'AnimationState' --- , lens :: Lens' anim a --- -- | How is the animation eased? --- , easing :: Easing --- -- | Do something when it's finished? --- , onComplete :: Bool -> Maybe sig --- } --- --- --- data RunningAnim sig anim = RunningAnim --- { config :: AnimConfig sig anim --- , beganAt :: Double --- } - - newtype ReactT state sig m a = ReactT { runReactT :: m ([ReactNode sig], a) } @@ -295,3 +207,35 @@ data FocusEvent e = instance NFData e => NFData (FocusEvent e) where rnf (FocusEvent a b) = a `seq` b `seq` () + +-- Useful for defining elements +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 :: * + + termParent :: ForeignRender -> TermParentArg result -> result + + +instance (Monad m, f ~ ReactT state sig m a) => + TermParent (f -> ReactT state sig m a) where + type TermParentArg (f -> ReactT state sig m a) = [AttrOrHandler sig] + + termParent render attrs children = ReactT $ do + ~(childNodes, a) <- runReactT children + let (hs, as) = separateAttrs attrs + return ([Parent render as hs childNodes], a) + + +instance Monad m => TermParent (ReactT state sig m a) where + type TermParentArg (ReactT state sig m a) = ReactT state sig m a + + termParent render children = ReactT $ do + ~(childNodes, a) <- runReactT children + return ([Parent render [] [] childNodes], a) + From b7773686565afbb9773357d54015b91b2feaac7c Mon Sep 17 00:00:00 2001 From: John Cant Date: Sat, 14 Feb 2015 20:46:32 +0000 Subject: [PATCH 6/8] Fix reactClass_ --- src/React/Elements.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/React/Elements.hs b/src/React/Elements.hs index 9421d0c..d7d3a51 100644 --- a/src/React/Elements.hs +++ b/src/React/Elements.hs @@ -24,8 +24,11 @@ import React.ElemTypes -- span_ [class_ "example"] $ ... children ... -- @ -reactClass_ :: ReactClass state sig -> React state sig () -reactClass_ ReactClass{foreignClass} = termLeaf (\_ _ -> js_React_DOM_class $ foreignClass) [] +reactClass_ :: Monad m + => ReactClass cstate csig + -> [AttrOrHandler sig] + -> ReactT state sig m () +reactClass_ ReactClass{foreignClass} = termLeaf (\_ _ -> js_React_DOM_class $ foreignClass) text_ :: JSString -> React state sig () text_ str = ReactT $ return ([Text (fromJSStr str)], ()) From 631754627c7e1b8b71d44b8af2b1034ec3c76ffd Mon Sep 17 00:00:00 2001 From: John Cant Date: Mon, 16 Feb 2015 10:57:14 +0000 Subject: [PATCH 7/8] Animations not starting immediately now working --- example/src/Chain.hs | 9 +++++---- example/src/Circles.hs | 13 +++++++------ example/src/Easing.hs | 14 ++++++++------ example/src/Simple.hs | 12 +++++++----- example/src/Slide.hs | 10 ++++++---- lib/stubs.js | 4 ++-- react-haskell.cabal | 7 ++----- src/React.hs | 4 ---- src/React/Anim/Class.hs | 31 +++++++++++++++++++++++++++---- src/React/Imports.hs | 2 +- src/React/Render.hs | 4 ++-- 11 files changed, 67 insertions(+), 43 deletions(-) diff --git a/example/src/Chain.hs b/example/src/Chain.hs index a8e64e7..77c9f87 100644 --- a/example/src/Chain.hs +++ b/example/src/Chain.hs @@ -8,6 +8,8 @@ import Haste hiding (fromString) import Haste.JSON import Lens.Family2 hiding (view) import React +import React.Anim +import React.Anim.Class -- model @@ -71,9 +73,8 @@ derive t | t < 1 = ) derive t = (finalWidth, finalHeight) -view :: ChainState -> Chain React' -view status = div_ [ class_ "chain-container" ] $ do - animState <- getAnimationState +view :: ChainState -> Double -> Chain ReactA' +view status animState = div_ [ class_ "chain-container" ] $ do let numStatus = if status == Open then 1 else 0 t = animState + numStatus @@ -92,6 +93,6 @@ view status = div_ [ class_ "chain-container" ] $ do ] "" -chainClass :: IO (Chain ReactClass) +chainClass :: IO (Chain ReactClassA') chainClass = createClass view transition initialClassState initialAnimationState [] diff --git a/example/src/Circles.hs b/example/src/Circles.hs index 0bda86f..79376d2 100644 --- a/example/src/Circles.hs +++ b/example/src/Circles.hs @@ -10,6 +10,8 @@ import Lens.Family2 import Haste hiding (fromString) import Haste.JSON import React +import React.Anim +import React.Anim.Class -- model @@ -93,7 +95,7 @@ fillorange = Color 245 175 51 fill_' = fill_ . fromString . show -circ :: Circ -> Color -> Circles React' +circ :: Circ -> Color -> Circles ReactA' circ c = circ' True (const (Just (SingleFlash c))) (coord c) @@ -101,7 +103,7 @@ circ' :: Bool -> (MouseEvent -> Maybe Transition) -> (Double, Double) -> Color - -> Circles React' + -> Circles ReactA' circ' clickable handler (x, y) color = let lst = [ cx_ x , cy_ y @@ -115,9 +117,8 @@ circ' clickable handler (x, y) color = in circle_ (if clickable then lst' else lst) -mainView :: CircState -> Circles React' -mainView (CircState c _) = div_ $ do - AnimState c1 c2 c3 c4 trans <- getAnimationState +mainView :: CircState -> AnimState -> Circles ReactA' +mainView (CircState c _) (AnimState c1 c2 c3 c4 trans) = div_ $ do svg_ [ width_ 600 , height_ 600 @@ -130,6 +131,6 @@ mainView (CircState c _) = div_ $ do circ' False (const Nothing) (coord c `animSub` trans) fillblue -circlesClass :: IO (Circles ReactClass) +circlesClass :: IO (Circles ReactClassA') circlesClass = createClass mainView transition initialState initialAnimationState [RepeatingFlash] diff --git a/example/src/Easing.hs b/example/src/Easing.hs index 1010bca..4501fb6 100644 --- a/example/src/Easing.hs +++ b/example/src/Easing.hs @@ -11,6 +11,9 @@ import Prelude hiding (lookup) import Haste hiding (fromString) import Haste.JSON hiding ((!)) import React hiding (repeat) +import React.Anim +import React.Anim.Class + import Lens.Family2 hiding (view) -- model @@ -84,16 +87,15 @@ transition Toggle (Easings Open easings) = -- view -buttonBox :: Ease React' +buttonBox :: Ease ReactA' buttonBox = div_ [ class_ "button-box" ] $ button_ [ class_ "btn btn--m btn--gray-border" , onClick (const (Just Toggle)) ] "toggle easing" -view :: EasingState -> Ease React' -view (Easings direction easings) = div_ $ do - EasingMap runningEasings <- getAnimationState +view :: EasingState -> AnimState -> Ease ReactA' +view (Easings direction easings) (EasingMap runningEasings) = div_ $ do let t = if direction == Closed then 0 else 1 buttonBox @@ -126,7 +128,7 @@ safeShow x = in if take 2 shown == "--" then drop 2 shown else shown -- Trying to replicate http://www.objc.io/issue-12/view-layer-synergy.html -subView :: Double -> Easing -> Ease React' +subView :: Double -> Easing -> Ease ReactA' subView t easing = svg_ [ width_ 100 , height_ 100 , viewBox_ "0 0 100 100" @@ -177,6 +179,6 @@ subView t easing = svg_ [ width_ 100 ] -easingClass :: IO (Ease ReactClass) +easingClass :: IO (Ease ReactClassA') easingClass = createClass view transition initialClassState initialAnimationState [] diff --git a/example/src/Simple.hs b/example/src/Simple.hs index 59dafd6..fad83c2 100644 --- a/example/src/Simple.hs +++ b/example/src/Simple.hs @@ -4,6 +4,7 @@ module Simple (simpleClass) where import Haste import Haste.JSON import React +import React.Class -- model @@ -15,16 +16,16 @@ data SimpleState = SimpleState , fighter2 :: JSString , typing :: JSString -- what the user's currently typing } -type Simple a = a SimpleState Transition () +type Simple a = a SimpleState Transition initialState = SimpleState "little mac!" "pit" "" -- update -transition :: Transition -> SimpleState -> (SimpleState, [AnimConfig Transition ()]) -transition (Typing str) state = (state{typing=str}, []) +transition :: Transition -> SimpleState -> SimpleState +transition (Typing str) state = state{typing=str} transition Enter SimpleState{fighter1, typing} = - (SimpleState typing fighter1 "", []) + SimpleState typing fighter1 "" -- view @@ -32,6 +33,7 @@ view :: SimpleState -> Simple React' view (SimpleState fighter1 fighter2 typing) = div_ $ do div_ $ do "send a new competitor into the ring: " + div_ [] $ text_ typing input_ [ value_ typing @@ -52,4 +54,4 @@ view (SimpleState fighter1 fighter2 typing) = div_ $ do text_ fighter2 simpleClass :: IO (Simple ReactClass) -simpleClass = createClass view transition initialState () [] +simpleClass = createClass view transition initialState [] diff --git a/example/src/Slide.hs b/example/src/Slide.hs index ba37e68..c7280a1 100644 --- a/example/src/Slide.hs +++ b/example/src/Slide.hs @@ -8,6 +8,8 @@ import Haste import Haste.JSON import Lens.Family2 hiding (view) import React +import React.Anim +import React.Anim.Class -- model @@ -42,9 +44,9 @@ transition Toggle Closed = (Open, [ slide (-paneWidth) ]) -- view -view :: SlideState -> Slide React' -view slid = div_ [ class_ "slider-container" ] $ do - animWidth <- getAnimationState +view :: SlideState -> Double -> Slide ReactA' +view slid animWidth = div_ [ class_ "slider-container" ] $ do + let inherentWidth = case slid of Open -> paneWidth Closed -> 0 @@ -55,6 +57,6 @@ view slid = div_ [ class_ "slider-container" ] $ do ] "" -slideClass :: IO (Slide ReactClass) +slideClass :: IO (Slide ReactClassA') slideClass = createClass view transition initialClassState initialAnimationState [] diff --git a/lib/stubs.js b/lib/stubs.js index aed8240..f210263 100644 --- a/lib/stubs.js +++ b/lib/stubs.js @@ -331,7 +331,7 @@ function js_createClass(render, initialState, _) { // - React to use continuation style passing return B(A(render, [[0, this], [0, this.state.hs], 0]))[1]; }, - getInitialState: function() { debugger; return {hs: B(A(initialState, [0]))} } + getInitialState: function() { return {hs: B(A(initialState, [0]))} } }); } @@ -348,7 +348,7 @@ function js_cancelRaf(id) { } function js_getState(inst) { - return inst.state; + return inst.state.hs; } function js_setState(inst, state) { diff --git a/react-haskell.cabal b/react-haskell.cabal index e5d825a..ef51023 100644 --- a/react-haskell.cabal +++ b/react-haskell.cabal @@ -51,14 +51,11 @@ source-repository head location: https://github.com/joelburget/react-haskell.git library - exposed-modules: React + exposed-modules: React, React.Class, React.Anim, React.Anim.Class other-modules: - React.Anim, - React.Anim.Class, React.Attrs, - React.Class, React.Elements, - React.ElemTypes + React.ElemTypes, React.Events, React.Imports, React.Interpret, diff --git a/src/React.hs b/src/React.hs index e492655..a11b005 100644 --- a/src/React.hs +++ b/src/React.hs @@ -13,10 +13,6 @@ module React --, getAnimationState --, Animatable(..) -- XXX - -- React.Class - , ReactClass() - , createClass - -- React.Local , locally , GeneralizeSignal(..) diff --git a/src/React/Anim/Class.hs b/src/React/Anim/Class.hs index 74f33f4..2a95b14 100644 --- a/src/React/Anim/Class.hs +++ b/src/React/Anim/Class.hs @@ -1,5 +1,10 @@ {-# LANGUAGE NamedFieldPuns #-} -module React.Anim.Class where +module React.Anim.Class + ( ReactClass(..) + , createClass + , ReactA' + , ReactClassA' + ) where import Lens.Family2 import Data.Functor.Identity @@ -26,6 +31,9 @@ data WithAnimState u sig anim = , runningAnims :: [RunningAnim sig anim] } +type ReactA' state sig anim = React' (WithAnimState state sig anim) sig +type ReactClassA' state sig anim = ReactClass (WithAnimState state sig anim) sig + -- This class can wrap V.ReactClass, but only if the V.ReactClass transition lives inside the IO monad, or the render lives inside the IO monad. -- Instead, it will just have to be a different implementation createClass :: (state -> anim -> React (WithAnimState state sig anim) sig ()) @@ -34,7 +42,20 @@ createClass :: (state -> anim -> React (WithAnimState state sig anim) sig ()) -> anim -> [sig] -> IO (ReactClass (WithAnimState state sig anim) sig) -createClass render transition initialState anim initialTrans = do +createClass render transition initialState anim initialSigs = do + +-- TODO(johncant) wrong place. Need initialState :: IO state +-- time <- js_performance_now +-- +-- let (state, newAnims) = mapAccumL +-- (\state sig -> +-- transition sig state) +-- initialState +-- initialSigs +-- +-- newAnims' = concat newAnims +-- +-- newRunningAnims = map (`RunningAnim` time) newAnims' foreignClass <- js_createClass (toPtr $ classForeignRender render transition) @@ -71,10 +92,10 @@ updateCb this trans sig = do let (newState, newAnims) = trans sig userState - newRunningAnims = map (`RunningAnim` time) newAnims + newRunningAnims = runningAnims <> (map (`RunningAnim` time) newAnims) js_raf $ toPtr $ animTick this - js_setState this $ toPtr $ WithAnimState newState anim runningAnims + js_setState this $ toPtr $ WithAnimState newState anim newRunningAnims animTick :: ForeignClassInstance @@ -84,6 +105,8 @@ animTick this time = do state@WithAnimState{userState, anim, runningAnims} <- fromPtr =<< js_getState this + mapM_ (putStrLn.show) $ map (duration.config) runningAnims + let (runningAnims', endingAnims) = partition (\(RunningAnim AnimConfig{duration} beganAt) -> beganAt + duration > time) diff --git a/src/React/Imports.hs b/src/React/Imports.hs index 1937463..39d1a08 100644 --- a/src/React/Imports.hs +++ b/src/React/Imports.hs @@ -14,7 +14,7 @@ import Haste.JSON import Haste.Prim -#ifdef __HASTE +#ifdef __HASTE__ foreign import ccall js_performance_now:: IO Double #else js_performance_now:: IO Double diff --git a/src/React/Render.hs b/src/React/Render.hs index 7bce11f..f9e9d18 100644 --- a/src/React/Render.hs +++ b/src/React/Render.hs @@ -7,5 +7,5 @@ import React.Imports import Haste.DOM -render :: ReactClass state sig -> Elem -> IO () -render ReactClass{foreignClass} elem = js_render foreignClass elem +render :: Elem -> ReactClass state sig -> IO () +render elem ReactClass{foreignClass} = js_render foreignClass elem From ebc0a60b1ffb2d1c0b47527ef3a86e1cbe8c0eca Mon Sep 17 00:00:00 2001 From: John Cant Date: Wed, 18 Feb 2015 22:32:38 +0000 Subject: [PATCH 8/8] Restore full animation functionality --- lib/stubs.js | 4 +- src/React/Anim/Class.hs | 116 +++++++++++++++++++++++++++------------- src/React/Class.hs | 2 +- src/React/Imports.hs | 4 +- 4 files changed, 84 insertions(+), 42 deletions(-) diff --git a/lib/stubs.js b/lib/stubs.js index f210263..07796f8 100644 --- a/lib/stubs.js +++ b/lib/stubs.js @@ -321,7 +321,7 @@ function js_raf(cb) { }); } -function js_createClass(render, initialState, _) { +function js_createClass(render, getInitialState, _) { return React.createClass({ render: function() { // render :: a -> b -> IO ForeignNode @@ -331,7 +331,7 @@ function js_createClass(render, initialState, _) { // - React to use continuation style passing return B(A(render, [[0, this], [0, this.state.hs], 0]))[1]; }, - getInitialState: function() { return {hs: B(A(initialState, [0]))} } + getInitialState: function() { return {hs: B(A(getInitialState, [[0, this], 0]))} } }); } diff --git a/src/React/Anim/Class.hs b/src/React/Anim/Class.hs index 2a95b14..b57bbe2 100644 --- a/src/React/Anim/Class.hs +++ b/src/React/Anim/Class.hs @@ -29,6 +29,7 @@ data WithAnimState u sig anim = WithAnimState { userState :: u , anim :: anim , runningAnims :: [RunningAnim sig anim] + , renderHandle :: Maybe RenderHandle } type ReactA' state sig anim = React' (WithAnimState state sig anim) sig @@ -44,25 +45,27 @@ createClass :: (state -> anim -> React (WithAnimState state sig anim) sig ()) -> IO (ReactClass (WithAnimState state sig anim) sig) createClass render transition initialState anim initialSigs = do --- TODO(johncant) wrong place. Need initialState :: IO state --- time <- js_performance_now --- --- let (state, newAnims) = mapAccumL --- (\state sig -> --- transition sig state) --- initialState --- initialSigs --- --- newAnims' = concat newAnims --- --- newRunningAnims = map (`RunningAnim` time) newAnims' + let initialStateM = (\this -> do + + time <- js_performance_now + rh <- js_raf . toPtr $ animTick this transition + + let state = foldl + (flip $ wrapTrans transition time) + (WithAnimState + initialState + anim + [] + $ Just rh) + initialSigs + + return state) + + foreignClass <- js_createClass (toPtr $ classForeignRender render transition) - (toPtr $ WithAnimState - initialState - anim - []) + (toPtr initialStateM) return $ ReactClass foreignClass @@ -77,7 +80,7 @@ classForeignRender classRender this pstate = do - let (WithAnimState ustate a ra) = fromPtr pstate + let (WithAnimState ustate a ra rh) = fromPtr pstate runIdentity $ interpret (classRender ustate a) (updateCb this classTransition) @@ -88,38 +91,77 @@ updateCb :: ForeignClassInstance -> IO () updateCb this trans sig = do time <- js_performance_now - state@WithAnimState{userState, anim, runningAnims} <- fromPtr =<< js_getState this + state <- fromPtr =<< js_getState this + + let newState = wrapTrans trans time sig state - let (newState, newAnims) = trans sig userState + case renderHandle newState of + Just h -> js_cancelRaf h + Nothing -> return () - newRunningAnims = runningAnims <> (map (`RunningAnim` time) newAnims) + newHandle <- js_raf . toPtr $ animTick this trans - js_raf $ toPtr $ animTick this - js_setState this $ toPtr $ WithAnimState newState anim newRunningAnims + js_setState + this + $ toPtr + newState{renderHandle=Just newHandle} animTick :: ForeignClassInstance + -> (sig -> state -> (state, [AnimConfig sig anim])) -> Double -> IO () -animTick this time = do - - state@WithAnimState{userState, anim, runningAnims} <- fromPtr =<< js_getState this +animTick this trans time = do - mapM_ (putStrLn.show) $ map (duration.config) runningAnims + state@WithAnimState{runningAnims} <- fromPtr =<< js_getState this let (runningAnims', endingAnims) = partition (\(RunningAnim AnimConfig{duration} beganAt) -> beganAt + duration > time) runningAnims - endingAnims' = zip endingAnims [1..] - runningAnims'' = zip runningAnims' (map (lerp time) runningAnims') - newAnim = stepRunningAnims anim (endingAnims' ++ runningAnims'') - - endAnimTrans = mapMaybe - (\anim -> onComplete (config anim) True) - endingAnims - - js_raf $ toPtr $ animTick this - js_setState this $ toPtr $ WithAnimState userState newAnim (map fst runningAnims'') - + endAnimSigTimes = mapMaybe + (\(RunningAnim AnimConfig{ duration + , onComplete + } + beganAt) -> do + + sig <- onComplete True + return ( sig + , beganAt + duration + ) + ) + endingAnims + + newState@(WithAnimState _ anim newRunningAnims _) = foldl + (\st (sig, time) -> + wrapTrans trans time sig st) + state{ + runningAnims=runningAnims' + } + endAnimSigTimes + + runningAnims'' = zip newRunningAnims $ map (lerp time) newRunningAnims + newAnim = stepRunningAnims anim (runningAnims'') + + newHandle <- js_raf $ toPtr $ animTick this trans + + js_setState this $ toPtr $ newState{ anim=newAnim + , renderHandle=Just newHandle + } + +wrapTrans :: (sig -> state -> (state, [AnimConfig sig anim])) + -> Double + -> sig + -> WithAnimState state sig anim + -> WithAnimState state sig anim +wrapTrans trans + time + sig + (WithAnimState ustate + anim + runningAnims + rh) + = WithAnimState newUState anim newRunningAnims rh + where (newUState, animConfs) = trans sig ustate + newRunningAnims = runningAnims <> (zipWith RunningAnim animConfs (Data.List.repeat time)) diff --git a/src/React/Class.hs b/src/React/Class.hs index 64b2e7f..09fa7a1 100644 --- a/src/React/Class.hs +++ b/src/React/Class.hs @@ -38,7 +38,7 @@ createClass render transition initialState initialTrans = do foreignClass <- js_createClass (toPtr $ classForeignRender render transition) - (toPtr initialState) + (toPtr (\_ -> return initialState)) return $ ReactClass foreignClass diff --git a/src/React/Imports.hs b/src/React/Imports.hs index 39d1a08..bf8a665 100644 --- a/src/React/Imports.hs +++ b/src/React/Imports.hs @@ -58,11 +58,11 @@ js_bezier = error "cannot evaluate js_bezier in ghc" #ifdef __HASTE__ foreign import ccall js_createClass :: Ptr (ForeignClassInstance -> Ptr state -> IO ForeignNode) - -> Ptr state + -> Ptr (ForeignClassInstance -> IO state) -> IO ForeignClass #else js_createClass :: Ptr (ForeignClassInstance -> Ptr state -> ForeignNode) - -> Ptr state + -> Ptr (ForeignClassInstance -> IO state) -> IO ForeignClass js_createClass = error "cannot evaluate js_createClass in ghc" #endif