module React.Flux.Internal(
ReactViewRef(..)
, ReactViewKey(..)
, ReactElementRef(..)
, HandlerArg(..)
, PropertyOrHandler(..)
, property
, ReactElement(..)
, ReactElementM(..)
, elemText
, elemShow
, el
, childrenPassedToView
, elementToM
, mkReactElement
, toJSString
) where
import Data.String (IsString(..))
import Data.Aeson
import Data.Typeable (Typeable)
import Control.Monad.Writer
import Control.Monad.Identity (Identity(..))
#ifdef __GHCJS__
import Unsafe.Coerce
import qualified Data.JSString as JSS
import JavaScript.Array (JSArray)
import qualified JavaScript.Array as JSA
import GHCJS.Foreign.Callback
import qualified JavaScript.Object as JSO
import GHCJS.Types (JSVal, JSString, IsJSVal, jsval)
import GHCJS.Marshal (ToJSVal(..))
import GHCJS.Foreign (jsNull)
import React.Flux.Export
#else
import Data.Text (Text)
type Callback a = ()
type JSVal = ()
class ToJSVal a
instance ToJSVal Value
instance ToJSVal Text
instance ToJSVal ()
class IsJSVal a
type JSArray = JSVal
#endif
newtype ReactViewRef props = ReactViewRef { reactViewRef :: JSVal }
instance IsJSVal (ReactViewRef props)
newtype ReactElementRef = ReactElementRef { reactElementRef :: JSVal }
instance IsJSVal ReactElementRef
newtype HandlerArg = HandlerArg JSVal
instance IsJSVal HandlerArg
instance Show HandlerArg where
show _ = "HandlerArg"
data PropertyOrHandler handler =
forall ref. ToJSVal ref => Property
{ propertyName :: String
, propertyVal :: ref
}
| forall ref. ToJSVal ref => PropertyFromContext
{ propFromThisName :: String
, propFromThisVal :: JSVal -> ref
}
| NestedProperty
{ nestedPropertyName :: String
, nestedPropertyVals :: [PropertyOrHandler handler]
}
| ElementProperty
{ elementPropertyName :: String
, elementValue :: ReactElementM handler ()
}
| CallbackPropertyWithArgumentArray
{ caPropertyName :: String
, caFunc :: JSArray -> IO handler
}
| CallbackPropertyWithSingleArgument
{ csPropertyName :: String
, csFunc :: HandlerArg -> handler
}
instance Functor PropertyOrHandler where
fmap _ (Property name val) = Property name val
fmap _ (PropertyFromContext name f) = PropertyFromContext name f
fmap f (NestedProperty name vals) = NestedProperty name (map (fmap f) vals)
fmap f (ElementProperty name (ReactElementM mkElem)) =
ElementProperty name $ ReactElementM $ mapWriter (\((),e) -> ((), fmap f e)) mkElem
fmap f (CallbackPropertyWithArgumentArray name h) = CallbackPropertyWithArgumentArray name (fmap f . h)
fmap f (CallbackPropertyWithSingleArgument name h) = CallbackPropertyWithSingleArgument name (f . h)
property :: ToJSVal val => String -> val -> PropertyOrHandler handler
property = Property
class ReactViewKey key where
toKeyRef :: key -> IO JSVal
#if __GHCJS__
instance ReactViewKey String where
toKeyRef = return . unsafeCoerce . toJSString
instance ReactViewKey Int where
toKeyRef i = toJSVal 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 :: forall eventHandler.
(eventHandler -> IO ())
-> IO JSVal
-> IO [ReactElementRef]
-> ReactElementM eventHandler ()
-> IO (ReactElementRef, [Callback (JSVal -> IO ())])
#ifdef __GHCJS__
mkReactElement runHandler getContext getPropsChildren = runWriterT . mToElem
where
mToElem :: ReactElementM eventHandler () -> MkReactElementM ReactElementRef
mToElem eM = do
let e = execWriter $ runReactElementM eM
e' = case e of
Content txt -> ForeignElement (Left "span") [] (Content txt)
_ -> e
refs <- createElement e'
case refs of
[] -> lift $ js_ReactCreateElementNoChildren "div"
[x] -> return x
xs -> lift $ do
emptyObj <- JSO.create
let arr = jsval $ JSA.fromList $ map reactElementRef xs
js_ReactCreateElementName "div" emptyObj arr
addPropOrHandlerToObj :: JSO.Object -> PropertyOrHandler eventHandler -> MkReactElementM ()
addPropOrHandlerToObj obj (Property n val) = lift $ do
vRef <- toJSVal val
JSO.setProp (toJSString n) vRef obj
addPropOrHandlerToObj obj (PropertyFromContext n f) = lift $ do
ctx <- getContext
vRef <- toJSVal $ f ctx
JSO.setProp (toJSString n) vRef obj
addPropOrHandlerToObj obj (NestedProperty n vals) = do
nested <- lift $ JSO.create
mapM_ (addPropOrHandlerToObj nested) vals
lift $ JSO.setProp (toJSString n) (jsval nested) obj
addPropOrHandlerToObj obj (ElementProperty name rM) = do
ReactElementRef ref <- mToElem rM
lift $ JSO.setProp (toJSString name) ref obj
addPropOrHandlerToObj obj (CallbackPropertyWithArgumentArray name func) = do
cb <- lift $ syncCallback1 ContinueAsync $ \argref -> do
handler <- func $ unsafeCoerce argref
runHandler handler
tell [cb]
wrappedCb <- lift $ js_CreateArgumentsCallback cb
lift $ JSO.setProp (toJSString name) wrappedCb obj
addPropOrHandlerToObj obj (CallbackPropertyWithSingleArgument name func) = do
cb <- lift $ syncCallback1 ContinueAsync $ \ref ->
runHandler $ func $ HandlerArg ref
tell [cb]
lift $ JSO.setProp (toJSString name) (jsval cb) obj
createElement :: ReactElement eventHandler -> MkReactElementM [ReactElementRef]
createElement EmptyElement = return []
createElement (Append x y) = (++) <$> createElement x <*> createElement y
createElement (Content s) = return [js_ReactCreateContent s]
createElement ChildrenPassedToView = lift getPropsChildren
createElement (f@(ForeignElement{})) = do
obj <- lift $ JSO.create
mapM_ (addPropOrHandlerToObj obj) $ fProps f
childNodes <- createElement $ fChild f
let children = case map reactElementRef childNodes of
[] -> jsNull
[x] -> x
xs -> jsval $ JSA.fromList xs
e <- lift $ case fName f of
Left s -> js_ReactCreateElementName (toJSString s) obj children
Right ref -> js_ReactCreateForeignElement ref obj children
return [e]
createElement (ViewElement { ceClass = rc, ceProps = props, ceKey = mkey, ceChild = child }) = do
childNodes <- createElement child
propsE <- lift $ export props
let children = case map reactElementRef childNodes of
[] -> jsNull
[x] -> x
xs -> jsval $ JSA.fromList xs
e <- lift $ case mkey of
Just key -> do
keyRef <- toKeyRef key
js_ReactCreateKeyedElement rc keyRef propsE children
Nothing -> js_ReactCreateClass rc propsE children
return [e]
type MkReactElementM a = WriterT [Callback (JSVal -> IO ())] IO a
foreign import javascript unsafe
"React['createElement']($1)"
js_ReactCreateElementNoChildren :: JSString -> IO ReactElementRef
foreign import javascript unsafe
"React['createElement']($1, $2, $3)"
js_ReactCreateElementName :: JSString -> JSO.Object -> JSVal -> IO ReactElementRef
foreign import javascript unsafe
"React['createElement']($1, $2, $3)"
js_ReactCreateForeignElement :: ReactViewRef a -> JSO.Object -> JSVal -> IO ReactElementRef
foreign import javascript unsafe
"React['createElement']($1, {hs:$2}, $3)"
js_ReactCreateClass :: ReactViewRef a -> Export props -> JSVal -> IO ReactElementRef
foreign import javascript unsafe
"React['createElement']($1, {key: $2, hs:$3}, $4)"
js_ReactCreateKeyedElement :: ReactViewRef a -> JSVal -> Export props -> JSVal -> IO ReactElementRef
foreign import javascript unsafe
"hsreact$mk_arguments_callback($1)"
js_CreateArgumentsCallback :: Callback (JSVal -> IO ()) -> IO JSVal
js_ReactCreateContent :: String -> ReactElementRef
js_ReactCreateContent = ReactElementRef . unsafeCoerce . toJSString
toJSString :: String -> JSString
toJSString = JSS.pack
#else
mkReactElement _ _ _ _ = return (ReactElementRef (), [])
toJSString :: String -> String
toJSString = id
#endif