module React.Class
( ReactClass(..)
, ClassConfig(..)
, ClassCtx
, PropRequired(..)
, PropType(..)
, createClass
, smartClass
, dumbClass
) where
import Control.Applicative
import Control.Monad
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as H
import Data.IORef
import Data.Maybe
import Data.Text (Text)
import System.IO.Unsafe
import React.GHCJS
import React.Imports
import React.Interpret
import React.PropTypes
import React.Registry
import React.Types
data ClassConfig props state insig exsig ctx = ClassConfig
{ renderFn :: props -> state -> ReactNode insig
, initialState :: state
, name :: JSString
, transition :: (state, insig) -> (state, Maybe exsig)
, startupSignals :: [insig]
, childContext :: Maybe (H.HashMap Text ctx)
}
dumbClass :: ClassConfig props () sig sig JSString
dumbClass = ClassConfig
{ name = "Anonymous Stateless Class"
, renderFn = \_ _ -> "give this class a `render`!"
, initialState = ()
, transition = \(state, sig) -> (state, Just sig)
, startupSignals = []
, childContext = Nothing
}
smartClass :: ClassConfig props state insig exsig JSString
smartClass = ClassConfig
{ name = "Anonymous Stateful Class"
, renderFn = \_ _ -> "give this class a `render`!"
, initialState = error "must define `initialState`!"
, transition = error "must define `transition`!"
, startupSignals = []
, childContext = Nothing
}
willMount :: ClassRegistry props state insig exsig -> state -> JSRef Int -> IO ()
willMount registry state idRef = do
Just componentId <- fromJSRef idRef
setState registry state componentId
willUnmount :: ClassRegistry props state insig exsig -> JSRef Int -> IO ()
willUnmount registry idRef = do
Just componentId <- fromJSRef idRef
deallocRegistry registry componentId
type ClassCtx a = (ToJSRef a, PropTypable a)
render :: ClassRegistry props state insig exsig
-> (props -> state -> ReactNode insig)
-> JSRef (Int, JSAny)
-> JSAny
-> IO ()
render registry renderFn inRefs returnObj = do
Just (componentId, thisObj) <- fromJSRef inRefs
RegistryStuff thisProps thisState thisHandler <-
lookupRegistry registry componentId
let rendered = renderFn thisProps thisState
handler sig = do
js_forceUpdate thisObj
thisHandler sig
ret <- reactNodeToJSAny handler componentId rendered
setProp ("value" :: JSString) ret returnObj
createClass :: ClassCtx ctx
=> ClassConfig props state insig exsig ctx
-> ReactClass props state insig exsig ctx
createClass ClassConfig{renderFn,
initialState,
name,
transition,
startupSignals,
childContext} =
let classRegistry = unsafePerformIO $ ClassRegistry
<$> newIORef H.empty
<*> newIORef 0
foreignObj = do
obj <- newObj
setProp ("displayName" :: JSString) name obj
renderCb <- syncCallback2 NeverRetain True
(render classRegistry renderFn)
setProp ("render" :: JSString) renderCb obj
when (isJust childContext) $ do
let childContext' = fromJust childContext
ctxObj <- newObj
ctxTypeObj <- newObj
forM_ (H.toList childContext') $ \(k, v) -> do
ref <- toJSRef v
setProp k ref ctxObj
let ty = toJsPropType (propType v)
setProp k ty ctxTypeObj
setProp' "childContext" ctxObj obj
setProp' "childContextTypes" ctxTypeObj obj
willMountCb <- syncCallback1 NeverRetain True
(willMount classRegistry initialState)
setProp ("componentWillMount" :: JSString) willMountCb obj
willUnmountCb <- syncCallback1 NeverRetain True
(willUnmount classRegistry)
setProp ("componentWillUnmount" :: JSString) willUnmountCb obj
return obj
foreignClass = unsafePerformIO $ js_createClass <$> foreignObj
in ReactClass foreignClass transition classRegistry