module React.Flux.Internal(
ReactViewRef(..)
, ReactViewKey(..)
, ReactElementRef(..)
, HandlerArg(..)
, PropertyOrHandler(..)
, ReactElement(..)
, ReactElementM(..)
, elemText
, elemShow
, el
, childrenPassedToView
, elementToM
, mkReactElement
) where
import Data.String (IsString(..))
import Data.Aeson
import Data.Aeson.Types (Pair)
import Data.Typeable (Typeable)
import Control.Monad.Writer
import Control.Monad.Identity (Identity(..))
#ifdef __GHCJS__
import GHCJS.Types (JSRef, castRef, JSString, JSArray, JSObject, JSFun)
import qualified GHCJS.Foreign as Foreign
import GHCJS.Marshal (toJSRef_aeson, ToJSRef(..), fromJSRef)
import React.Flux.Export
#else
type JSRef a = ()
type JSFun a = JSRef a
#endif
type Callback a = JSFun a
newtype ReactViewRef props = ReactViewRef { reactViewRef :: JSRef () }
newtype ReactElementRef = ReactElementRef { reactElementRef :: JSRef () }
newtype HandlerArg = HandlerArg (JSRef ())
instance Show HandlerArg where
show _ = "HandlerArg"
data PropertyOrHandler handler =
Property Pair
| EventHandler
{ evtHandlerName :: String
, evtHandler :: HandlerArg -> handler
}
| CallbackProperty
{ callbackName :: String
, callbackFn :: Value -> handler
}
instance Functor PropertyOrHandler where
fmap _ (Property p) = Property p
fmap f (EventHandler name h) = EventHandler name (f . h)
fmap f (CallbackProperty name g) = CallbackProperty name (f . g)
class ReactViewKey key where
toKeyRef :: key -> IO (JSRef ())
#if __GHCJS__
instance ReactViewKey String where
toKeyRef = return . castRef . Foreign.toJSString
instance ReactViewKey Int where
toKeyRef i = castRef <$> toJSRef i
#else
instance ReactViewKey String where
toKeyRef = const $ return ()
instance ReactViewKey Int where
toKeyRef = const $ return ()
#endif
data ReactElement eventHandler
= ForeignElement
{ fName :: Either String (ReactViewRef Object)
, fProps :: [PropertyOrHandler eventHandler]
, fChild :: ReactElement eventHandler
}
| forall props key. (Typeable props, ReactViewKey key) => ViewElement
{ ceClass :: ReactViewRef props
, ceKey :: Maybe key
, ceProps :: props
, ceChild :: ReactElement eventHandler
}
| ChildrenPassedToView
| Content String
| Append (ReactElement eventHandler) (ReactElement eventHandler)
| EmptyElement
instance Monoid (ReactElement eventHandler) where
mempty = EmptyElement
mappend x y = Append x y
instance Functor ReactElement where
fmap f (ForeignElement n p c) = ForeignElement n (map (fmap f) p) (fmap f c)
fmap f (ViewElement n k p c) = ViewElement n k p (fmap f c)
fmap _ ChildrenPassedToView = ChildrenPassedToView
fmap f (Append a b) = Append (fmap f a) (fmap f b)
fmap _ (Content s) = Content s
fmap _ EmptyElement = EmptyElement
newtype ReactElementM eventHandler a = ReactElementM { runReactElementM :: Writer (ReactElement eventHandler) a }
deriving (Functor, Applicative, Monad, Foldable)
elementToM :: a -> ReactElement eventHandler -> ReactElementM eventHandler a
elementToM a e = ReactElementM (WriterT (Identity (a, e)))
instance (a ~ ()) => Monoid (ReactElementM eventHandler a) where
mempty = elementToM () EmptyElement
mappend e1 e2 =
let ((),e1') = runWriter $ runReactElementM e1
((),e2') = runWriter $ runReactElementM e2
in elementToM () $ Append e1' e2'
instance (a ~ ()) => IsString (ReactElementM eventHandler a) where
fromString s = elementToM () $ Content s
elemText :: String -> ReactElementM eventHandler ()
elemText s = elementToM () $ Content s
elemShow :: Show a => a -> ReactElementM eventHandler ()
elemShow s = elementToM () $ Content $ show s
el :: String
-> [PropertyOrHandler eventHandler]
-> ReactElementM eventHandler a
-> ReactElementM eventHandler a
el name attrs (ReactElementM child) =
let (a, childEl) = runWriter child
in elementToM a $ ForeignElement (Left name) attrs childEl
childrenPassedToView :: ReactElementM eventHandler ()
childrenPassedToView = elementToM () ChildrenPassedToView
mkReactElement :: (eventHandler -> IO ())
-> IO [ReactElementRef]
-> ReactElementM eventHandler ()
-> IO (ReactElementRef, [Callback (JSRef () -> IO ())])
#ifdef __GHCJS__
mkReactElement runHandler getPropsChildren eM = runWriterT $ do
let e = execWriter $ runReactElementM eM
refs <- createElement getPropsChildren $ fmap runHandler e
case refs of
[] -> lift $ js_ReactCreateElementNoChildren "div"
[x] -> return x
xs -> lift $ do
emptyObj <- Foreign.newObj
arr <- Foreign.toArray $ map reactElementRef xs
js_ReactCreateElementName "div" emptyObj arr
foreign import javascript unsafe
"React['createElement']($1)"
js_ReactCreateElementNoChildren :: JSString -> IO ReactElementRef
foreign import javascript unsafe
"React['createElement']($1, $2, $3)"
js_ReactCreateElementName :: JSString -> JSObject b -> JSArray c -> IO ReactElementRef
foreign import javascript unsafe
"React['createElement']($1, $2, $3)"
js_ReactCreateForeignElement :: ReactViewRef a -> JSObject b -> JSArray c -> IO ReactElementRef
foreign import javascript unsafe
"React['createElement']($1, {hs:$2}, $3)"
js_ReactCreateClass :: ReactViewRef a -> Export props -> JSArray b -> IO ReactElementRef
foreign import javascript unsafe
"React['createElement']($1, {key: $2, hs:$3}, $4)"
js_ReactCreateKeyedElement :: ReactViewRef a -> JSRef key -> Export props -> JSArray b -> IO ReactElementRef
js_ReactCreateContent :: String -> ReactElementRef
js_ReactCreateContent = ReactElementRef . castRef . Foreign.toJSString
addPropOrHandlerToObj :: JSObject a -> PropertyOrHandler (IO ()) -> WriterT [Callback (JSRef () -> IO ())] IO ()
addPropOrHandlerToObj obj (Property (n, v)) = lift $ do
vRef <- toJSRef_aeson v
Foreign.setProp (Foreign.toJSString n) vRef obj
addPropOrHandlerToObj obj (EventHandler str handler) = do
cb <- lift $ Foreign.syncCallback1 Foreign.AlwaysRetain True $ \evtRef ->
handler $ HandlerArg evtRef
tell [cb]
lift $ Foreign.setProp (Foreign.toJSString str) cb obj
addPropOrHandlerToObj obj (CallbackProperty str handler) = do
cb <- lift $ Foreign.syncCallback1 Foreign.AlwaysRetain True $ \argref -> do
v <- fromJSRef $ castRef argref
handler $ maybe (error "Unable to decode callback value") id v
tell [cb]
lift $ Foreign.setProp (Foreign.toJSString str) cb obj
createElement :: IO [ReactElementRef] -> ReactElement (IO ()) -> WriterT [Callback (JSRef () -> IO ())] IO [ReactElementRef]
createElement _ EmptyElement = return []
createElement c (Append x y) = (++) <$> createElement c x <*> createElement c y
createElement _ (Content s) = return [js_ReactCreateContent s]
createElement c ChildrenPassedToView = lift c
createElement c (f@(ForeignElement{})) = do
obj <- lift $ Foreign.newObj
mapM_ (addPropOrHandlerToObj obj) $ fProps f
childNodes <- createElement c $ fChild f
childArr <- lift $ Foreign.toArray $ map reactElementRef childNodes
e <- lift $ case fName f of
Left s -> js_ReactCreateElementName (Foreign.toJSString s) obj childArr
Right ref -> js_ReactCreateForeignElement ref obj childArr
return [e]
createElement c (ViewElement { ceClass = rc, ceProps = props, ceKey = mkey, ceChild = child }) = do
childNodes <- createElement c child
propsE <- lift $ export props
arr <- lift $ Foreign.toArray $ map reactElementRef childNodes
e <- lift $ case mkey of
Just key -> do
keyRef <- toKeyRef key
js_ReactCreateKeyedElement rc keyRef propsE arr
Nothing -> js_ReactCreateClass rc propsE arr
return [e]
#else
mkReactElement _ _ _ = return (ReactElementRef (), [])
#endif