diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Joel Burget + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/stubs.js b/lib/stubs.js new file mode 100644 --- /dev/null +++ b/lib/stubs.js @@ -0,0 +1,243 @@ +// EventProperties +function js_bubbles(obj) {return obj.bubbles;} +function js_cancelable(obj) {return obj.cancelable;} +function js_currentTarget(obj) {return obj.currentTarget;} +function js_defaultPrevented(obj) {return obj.defaultPrevented;} +function js_eventPhase(obj) {return obj.eventPhase;} +function js_isTrusted(obj) {return obj.isTrusted;} +// -- , nativeEvent :: DOMEvent +// -- , preventDefault :: IO () +// -- , stopPropagation :: IO () +function js_evtTarget(obj) {return obj.evtTarget;} +// --, timeStamp :: DateTime + +//ModifierKeys +function js_type(obj) {return obj.type;} +function js_altKey(obj) {return obj.altKey;} +function js_ctrlKey(obj) {return obj.ctrlKey;} +function js_metaKey(obj) {return obj.metaKey;} +function js_shiftKey(obj) {return obj.shiftKey;} + +//MouseEvent +function js_button(obj) {return obj.button;} +function js_buttons(obj) {return obj.buttons;} +function js_clientX(obj) {return obj.clientX;} +function js_clientY(obj) {return obj.clientY;} +function js_pageX(obj) {return obj.pageX;} +function js_pageY(obj) {return obj.pageY;} +//-- , relatedTarget :: Unpacked +function js_screenX(obj) {return obj.screenX;} +function js_screenY(obj) {return obj.screenY;} + +// KeyboardEvent +function js_charCode(obj) {return obj.charCode;} +function js_key(obj) {return obj.key;} +function js_keyCode(obj) {return obj.keyCode;} +function js_locale(obj) {return obj.locale;} +function js_location(obj) {return obj.location;} +function js_repeat(obj) {return obj.repeat;} +function js_which(obj) {return obj.which;} + +//ChangeEvent +function js_targetValue(obj) {return obj.target.value;} + +//FocusEvent +function js_focusEventProperties(obj) {return obj.focusEventProperties;} +function js_domEventTarget(obj) {return obj.domEventTarget;} +function js_relatedTarget(obj) {return obj.relatedTarget;} + +function js_empty_object() {return {};} +function js_set_field(obj, field, value) {obj[field] = value;} +function js_set_field_True(obj, field, value) {obj[field] = true;} +function js_set_field_False(obj, field, value) {obj[field] = false;} + +function js_set_onClick(cb, attrs) {attrs.onClick = function(e) {B(A(cb,[[0,e],0]));};} +function js_set_onDoubleClick(cb, attrs) {attrs.onDoubleClick = function(e) {B(A(cb,[[0,e],0]));};} +function js_set_onChange(cb, attrs) {attrs.onChange = function(e) {B(A(cb,[[0,e],0]));};} +function js_set_onKeyUp(cb, attrs) {attrs.onKeyUp = function(e) {B(A(cb,[[0,e],0]));};} +function js_set_onKeyPress(cb, attrs) {attrs.onKeyPress = function(e) {B(A(cb,[[0,e],0]));};} +function js_set_onKeyDown(cb, attrs) {attrs.onKeyDown = function(e) { B(A(cb,[[0,e],0]));};} +function js_set_onBlur(cb, attrs) {attrs.onBlur = function(e) {B(A(cb,[[0,e],0]));};} +function js_set_onMouseEnter(cb, attrs) {attrs.onMouseEnter = function(e) {B(A(cb,[[0,e],0]));};} +function js_set_onMouseLeave(cb, attrs) {attrs.onMouseLeave = function(e) {B(A(cb,[[0,e],0]));};} + +function js_React_DOM(tagName, attrs) {return React.DOM[tagName](attrs);} + +function js_empty() {return [];} +function js_push(a,v) {a.push(v);} + +// Ptr (Maybe React) +function js_React_getDomNode(r) { + try { + var ret = [1, [0, r.getDOMNode()]]; + } catch(e) { + return [0]; + } + return ret; +} + +// Normal elements +function js_React_DOM_a(a,c) {return React.DOM.a(a,c);} +function js_React_DOM_abbr(a,c) {return React.DOM.abbr(a,c);} +function js_React_DOM_address(a,c) {return React.DOM.address(a,c);} +function js_React_DOM_article(a,c) {return React.DOM.article(a,c);} +function js_React_DOM_aside(a,c) {return React.DOM.aside(a,c);} +function js_React_DOM_audio(a,c) {return React.DOM.audio(a,c);} +function js_React_DOM_b(a,c) {return React.DOM.b(a,c);} +function js_React_DOM_bdi(a,c) {return React.DOM.bdi(a,c);} +function js_React_DOM_bdo(a,c) {return React.DOM.bdo(a,c);} +function js_React_DOM_big(a,c) {return React.DOM.big(a,c);} +function js_React_DOM_blockquote(a,c) {return React.DOM.blockquote(a,c);} +function js_React_DOM_body(a,c) {return React.DOM.body(a,c);} +function js_React_DOM_button(a,c) {return React.DOM.button(a,c);} +function js_React_DOM_canvas(a,c) {return React.DOM.canvas(a,c);} +function js_React_DOM_caption(a,c) {return React.DOM.caption(a,c);} +function js_React_DOM_cite(a,c) {return React.DOM.cite(a,c);} +function js_React_DOM_code(a,c) {return React.DOM.code(a,c);} +function js_React_DOM_colgroup(a,c) {return React.DOM.colgroup(a,c);} +function js_React_DOM_data(a,c) {return React.DOM.data(a,c);} +function js_React_DOM_datalist(a,c) {return React.DOM.datalist(a,c);} +function js_React_DOM_dd(a,c) {return React.DOM.dd(a,c);} +function js_React_DOM_del(a,c) {return React.DOM.del(a,c);} +function js_React_DOM_details(a,c) {return React.DOM.details(a,c);} +function js_React_DOM_dfn(a,c) {return React.DOM.dfn(a,c);} +function js_React_DOM_div(a,c) {return React.DOM.div(a,c);} +function js_React_DOM_dl(a,c) {return React.DOM.dl(a,c);} +function js_React_DOM_dt(a,c) {return React.DOM.dt(a,c);} +function js_React_DOM_em(a,c) {return React.DOM.em(a,c);} +function js_React_DOM_fieldset(a,c) {return React.DOM.fieldset(a,c);} +function js_React_DOM_figcaption(a,c) {return React.DOM.figcaption(a,c);} +function js_React_DOM_figure(a,c) {return React.DOM.figure(a,c);} +function js_React_DOM_footer(a,c) {return React.DOM.footer(a,c);} +function js_React_DOM_form(a,c) {return React.DOM.form(a,c);} +function js_React_DOM_h1(a,c) {return React.DOM.h1(a,c);} +function js_React_DOM_h2(a,c) {return React.DOM.h2(a,c);} +function js_React_DOM_h3(a,c) {return React.DOM.h3(a,c);} +function js_React_DOM_h4(a,c) {return React.DOM.h4(a,c);} +function js_React_DOM_h5(a,c) {return React.DOM.h5(a,c);} +function js_React_DOM_h6(a,c) {return React.DOM.h6(a,c);} +function js_React_DOM_head(a,c) {return React.DOM.head(a,c);} +function js_React_DOM_header(a,c) {return React.DOM.header(a,c);} +function js_React_DOM_html(a,c) {return React.DOM.html(a,c);} +function js_React_DOM_i(a,c) {return React.DOM.i(a,c);} +function js_React_DOM_iframe(a,c) {return React.DOM.iframe(a,c);} +function js_React_DOM_ins(a,c) {return React.DOM.ins(a,c);} +function js_React_DOM_kbd(a,c) {return React.DOM.kbd(a,c);} +function js_React_DOM_label(a,c) {return React.DOM.label(a,c);} +function js_React_DOM_legend(a,c) {return React.DOM.legend(a,c);} +function js_React_DOM_li(a,c) {return React.DOM.li(a,c);} +function js_React_DOM_main(a,c) {return React.DOM.main(a,c);} +function js_React_DOM_map(a,c) {return React.DOM.map(a,c);} +function js_React_DOM_mark(a,c) {return React.DOM.mark(a,c);} +function js_React_DOM_menu(a,c) {return React.DOM.menu(a,c);} +function js_React_DOM_menuitem(a,c) {return React.DOM.menuitem(a,c);} +function js_React_DOM_meter(a,c) {return React.DOM.meter(a,c);} +function js_React_DOM_nav(a,c) {return React.DOM.nav(a,c);} +function js_React_DOM_noscript(a,c) {return React.DOM.noscript(a,c);} +function js_React_DOM_object(a,c) {return React.DOM.object(a,c);} +function js_React_DOM_ol(a,c) {return React.DOM.ol(a,c);} +function js_React_DOM_optgroup(a,c) {return React.DOM.optgroup(a,c);} +function js_React_DOM_option(a,c) {return React.DOM.option(a,c);} +function js_React_DOM_output(a,c) {return React.DOM.output(a,c);} +function js_React_DOM_p(a,c) {return React.DOM.p(a,c);} +function js_React_DOM_pre(a,c) {return React.DOM.pre(a,c);} +function js_React_DOM_progress(a,c) {return React.DOM.progress(a,c);} +function js_React_DOM_q(a,c) {return React.DOM.q(a,c);} +function js_React_DOM_rp(a,c) {return React.DOM.rp(a,c);} +function js_React_DOM_rt(a,c) {return React.DOM.rt(a,c);} +function js_React_DOM_ruby(a,c) {return React.DOM.ruby(a,c);} +function js_React_DOM_s(a,c) {return React.DOM.s(a,c);} +function js_React_DOM_samp(a,c) {return React.DOM.samp(a,c);} +function js_React_DOM_section(a,c) {return React.DOM.section(a,c);} +function js_React_DOM_select(a,c) {return React.DOM.select(a,c);} +function js_React_DOM_small(a,c) {return React.DOM.small(a,c);} +function js_React_DOM_span(a,c) {return React.DOM.span(a,c);} +function js_React_DOM_strong(a,c) {return React.DOM.strong(a,c);} +function js_React_DOM_sub(a,c) {return React.DOM.sub(a,c);} +function js_React_DOM_summary(a,c) {return React.DOM.summary(a,c);} +function js_React_DOM_sup(a,c) {return React.DOM.sup(a,c);} +function js_React_DOM_table(a,c) {return React.DOM.table(a,c);} +function js_React_DOM_tbody(a,c) {return React.DOM.tbody(a,c);} +function js_React_DOM_td(a,c) {return React.DOM.td(a,c);} +function js_React_DOM_tfoot(a,c) {return React.DOM.tfoot(a,c);} +function js_React_DOM_th(a,c) {return React.DOM.th(a,c);} +function js_React_DOM_thead(a,c) {return React.DOM.thead(a,c);} +function js_React_DOM_time(a,c) {return React.DOM.time(a,c);} +function js_React_DOM_tr(a,c) {return React.DOM.tr(a,c);} +function js_React_DOM_u(a,c) {return React.DOM.u(a,c);} +function js_React_DOM_ul(a,c) {return React.DOM.ul(a,c);} +function js_React_DOM_var(a,c) {return React.DOM.var(a,c);} +function js_React_DOM_video(a,c) {return React.DOM.video(a,c);} + +// No-child +function js_React_DOM_area(a) {return React.DOM.area(a);} +function js_React_DOM_base(a) {return React.DOM.base(a);} +function js_React_DOM_br(a) {return React.DOM.br(a);} +function js_React_DOM_col(a) {return React.DOM.col(a);} +function js_React_DOM_embed(a) {return React.DOM.embed(a);} +function js_React_DOM_hr(a) {return React.DOM.hr(a);} +function js_React_DOM_img(a) {return React.DOM.img(a);} +function js_React_DOM_input(a) {return React.DOM.input(a);} +function js_React_DOM_keygen(a) {return React.DOM.keygen(a);} +function js_React_DOM_link(a) {return React.DOM.link(a);} +function js_React_DOM_meta(a) {return React.DOM.meta(a);} +function js_React_DOM_param(a) {return React.DOM.param(a);} +function js_React_DOM_source(a) {return React.DOM.source(a);} +function js_React_DOM_track(a) {return React.DOM.track(a);} +function js_React_DOM_wbr(a) {return React.DOM.wbr(a);} + +// text-only +function js_React_DOM_script(a,t) {return React.DOM.script(a,t);} +function js_React_DOM_style(a,t) {return React.DOM.style(a,t);} +function js_React_DOM_textarea(a,t) {return React.DOM.textarea(a,t);} +function js_React_DOM_title(a,t) {return React.DOM.title(a,t);} +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_parseChangeEvent(raw) { + // wrap the string in two constructors - Ptr and JSString + return [0, raw.target.value]; +} + +function js_parseKeyboardEvent(raw) { + return [ + 0, + [ + 0, + raw.altKey, + raw.ctrlKey, + raw.metaKey, + raw.shiftKey, + ], + raw.charCode, + raw.key, + raw.keyCode, + raw.locale, + raw.location, + raw.repeat, + raw.which, + ]; +} + +function js_parseMouseEvent(raw) { + return [ + 0, + [ + 0, + raw.altKey, + raw.ctrlKey, + raw.metaKey, + raw.shiftKey, + ], + raw.button, + raw.clientX, + raw.clientY, + raw.pageX, + raw.pageY, + raw.screenX, + raw.screenY, + ]; +} diff --git a/react-haskell.cabal b/react-haskell.cabal new file mode 100644 --- /dev/null +++ b/react-haskell.cabal @@ -0,0 +1,57 @@ +name: react-haskell +version: 1.1.0.0 +synopsis: Haskell React bindings +description: + This package provides high level bindings to Facebook's library, meant for use with . + . + React is a JavaScript library for building user interfaces. React (and React-Haskell) is focused on just UI - it's not a framework. + . + Currently React-Haskell can render simple stateful components, but not what React calls classes. Put another way, React-Haskell doesn't support lifecycle methods yet. + . + Here's a simple example which demonstrates basic elements, attributes, state, and handling events. + . + > statefulView :: StatefulReact JSString () + > statefulView = div_ str <- getState + > input_ toJSStr $ map toUpper $ fromJSStr $ targetValue evt) +license: MIT +license-file: LICENSE +author: Joel Burget +maintainer: joelburget@gmail.com +category: Web +build-type: Simple +cabal-version: >=1.10 + +homepage: https://github.com/joelburget/react-haskell +bug-reports: https://github.com/joelburget/react-haskell/issues + +data-dir: lib +data-files: stubs.js + +source-repository head + type: git + location: https://github.com/joelburget/react-haskell.git + +library + exposed-modules: React + other-modules: + React.Attrs, + React.Elements, + React.Events, + React.Imports, + React.Types + other-extensions: + FlexibleInstances, + FlexibleContexts, + ForeignFunctionInterface, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + OverloadedStrings + build-depends: + base == 4.7.*, + transformers, + haste-lib >= 0.4 && <0.5, + monads-tf + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/React.hs b/src/React.hs new file mode 100644 --- /dev/null +++ b/src/React.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, LambdaCase, + MultiParamTypeClasses, FlexibleContexts #-} + +module React + ( module X + , getDomNode + , render + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +-- import Control.Monad.Writer +import Data.Functor.Identity +import Data.Monoid +import Data.String + +import Haste hiding (fromString) +import Haste.Foreign +import Haste.JSON +import Haste.Prim + +import Prelude hiding (div) + +import React.Attrs as X +import React.Elements as X +import React.Events as X +import React.Imports +import React.Types as X + +-- TODO +-- * restricted monads +-- * store elem in monad +-- * escaping / dangerouslySetInnerHTML +-- * http://chrisdone.com/posts/lucid + +interpret :: Monad m + => StatefulReactT s m () + -> s + -> (s -> IO ()) + -> m (IO ForeignNode) +interpret react s cb = do + ~(child:_, s', ()) <- runStatefulReactT react s + return $ interpret' s' cb child + +interpret' :: s + -> (s -> IO ()) + -> ReactNode s + -> IO ForeignNode +interpret' s cb = \case + Parent name as hs children -> do + children' <- forM children (interpret' s cb) + let hs' = map (unStateful s cb) hs + element js_React_DOM_parent name as hs' children' + Leaf name as hs -> do + let hs' = map (unStateful s cb) hs + voidElement js_React_DOM_leaf name as hs' + Text str -> js_React_DOM_text (toJSStr str) + +unStateful :: s + -> (s -> IO ()) + -> StatefulEventHandler s + -> (RawEvent -> IO (), EvtType) +unStateful s act (StatefulEventHandler handle ty) = (act . handle s, ty) + +element :: (JSString -> RawAttrs -> ReactArray -> IO ForeignNode) + -> JSString + -> Attrs + -> [(RawEvent -> IO (), EvtType)] + -> [ForeignNode] + -> IO ForeignNode +element constructor name attrs handlers content = do + attr <- js_empty_object + mapM_ (setField attr) attrs + mapM_ (makeHandler attr) handlers + + children <- js_ReactArray_empty + mapM_ (js_ReactArray_push children) content + constructor name attr children + +makeHandler :: RawAttrs -> (RawEvent -> IO (), EvtType) -> IO () +makeHandler obj (handle, ChangeEvt) = js_set_onChange (toPtr handle) obj +makeHandler obj (handle, KeyDownEvt) = js_set_onKeyDown (toPtr handle) obj +makeHandler obj (handle, KeyPressEvt) = js_set_onKeyPress (toPtr handle) obj +makeHandler obj (handle, KeyUpEvt) = js_set_onKeyUp (toPtr handle) obj +makeHandler obj (handle, ClickEvt) = js_set_onClick (toPtr handle) obj +makeHandler obj (handle, DoubleClickEvt) = js_set_onDoubleClick (toPtr handle) obj +makeHandler obj (handle, MouseEnterEvt) = js_set_onMouseEnter (toPtr handle) obj +makeHandler obj (handle, MouseLeaveEvt) = js_set_onMouseLeave (toPtr handle) obj + +voidElement :: (JSString -> RawAttrs -> IO ForeignNode) + -> JSString + -> Attrs + -> [(RawEvent -> IO (), EvtType)] + -> IO ForeignNode +voidElement constructor name attrs handlers = + element (\n a c -> constructor n a) name attrs handlers [] + +setField :: RawAttrs -> (JSString, JSON) -> IO () +setField attr (fld, Str v) = js_set_field_String attr fld v +setField attr (fld, Dict vs) = do + subObj <- js_empty_object + mapM_ (setField subObj) vs + js_set_field_Obj attr fld subObj +setField attr (fld, Num v) = js_set_field_Double attr fld v +setField attr (fld, Bool True) = js_set_field_True attr fld +setField attr (fld, Bool False) = js_set_field_False attr fld + +-- TODO this seems wrong +setField attr (fld, Null) = return () + +getDomNode :: ForeignNode -> IO (Maybe Elem) +getDomNode r = fmap fromPtr (js_React_getDomNode r) + +render :: s -> Elem -> StatefulReact s () -> IO () +render s elem r = do + let cb s' = render s' elem r + foreignNode <- runIdentity $ interpret r s cb + render' elem foreignNode + +render' :: Elem -> ForeignNode -> IO () +render' = ffi (toJSStr "(function(e,r){React.render(r,e);})") diff --git a/src/React/Attrs.hs b/src/React/Attrs.hs new file mode 100644 --- /dev/null +++ b/src/React/Attrs.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +module React.Attrs where + +import Haste.JSON +import Haste.Prim + +-- class ReactAttr a where + +type Attr = (JSString, JSON) + +mkAttr :: JSString -> (a -> JSON) -> a -> Attr +mkAttr name f a = (name, f a) + +-- exception +className :: JSString -> Attr +className = mkAttr "className" Str + +class_ :: JSString -> Attr +class_ = mkAttr "className" Str + +href_ :: JSString -> Attr +href_ = mkAttr "href" Str + +id_ :: JSString -> Attr +id_ = mkAttr "id" Str + +src_ :: JSString -> Attr +src_ = mkAttr "src" Str + +style_ :: JSON -> Attr +style_ = mkAttr "style" id + +value_ :: JSString -> Attr +value_ = mkAttr "value" Str + +placeholder_ :: JSString -> Attr +placeholder_ = mkAttr "placeholder" Str + +for_ :: JSString -> Attr +for_ = mkAttr "htmlFor" Str + +type_ :: JSString -> Attr +type_ = mkAttr "type" Str + +checked_ :: Bool -> Attr +checked_ = mkAttr "checked" Bool + +-- TODO think about supporting autoFocus / other camel-cased react names +autofocus_ :: Bool -> Attr +autofocus_ = mkAttr "autoFocus" Bool diff --git a/src/React/Elements.hs b/src/React/Elements.hs new file mode 100644 --- /dev/null +++ b/src/React/Elements.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE OverloadedStrings #-} +module React.Elements where + +import Haste.Prim + +import React.Types + +import Prelude hiding (div, span) + +makeParent :: Monad m + => JSString + -> StatefulReactT s m a + -> StatefulReactT s m () +makeParent name children = StatefulReactT $ \s -> do + ~(childNodes, s', _) <- runStatefulReactT children s + return ([Parent name [] [] childNodes], s', ()) + +makeLeaf :: Monad m + => JSString + -> StatefulReactT s m () +makeLeaf name = StatefulReactT $ \s -> return ([Leaf name [] []], s, ()) + +text_ :: JSString -> StatefulReact s () +text_ str = StatefulReactT $ \s -> return ([Text (fromJSStr str)], s, ()) + +a_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +a_ = makeParent "a" +abbr_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +abbr_ = makeParent "abbr" +address_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +address_ = makeParent "address" +article_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +article_ = makeParent "article" +aside_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +aside_ = makeParent "aside" +audio_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +audio_ = makeParent "audio" +b_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +b_ = makeParent "b" +bdi_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +bdi_ = makeParent "bdi" +bdo_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +bdo_ = makeParent "bdo" +big_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +big_ = makeParent "big" +blockquote_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +blockquote_ = makeParent "blockquote" +body_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +body_ = makeParent "body" +button_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +button_ = makeParent "button" +canvas_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +canvas_ = makeParent "canvas" +caption_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +caption_ = makeParent "caption" +cite_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +cite_ = makeParent "cite" +code_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +code_ = makeParent "code" +colgroup_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +colgroup_ = makeParent "colgroup" +data_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +data_ = makeParent "data" +datalist_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +datalist_ = makeParent "datalist" +dd_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +dd_ = makeParent "dd" +del_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +del_ = makeParent "del" +details_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +details_ = makeParent "details" +dfn_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +dfn_ = makeParent "dfn" +div_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +div_ = makeParent "div" +dl_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +dl_ = makeParent "dl" +dt_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +dt_ = makeParent "dt" +em_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +em_ = makeParent "em" +fieldset_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +fieldset_ = makeParent "fieldset" +figcaption_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +figcaption_ = makeParent "figcaption" +figure_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +figure_ = makeParent "figure" +footer_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +footer_ = makeParent "footer" +form_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +form_ = makeParent "form" +h1_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +h1_ = makeParent "h1" +h2_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +h2_ = makeParent "h2" +h3_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +h3_ = makeParent "h3" +h4_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +h4_ = makeParent "h4" +h5_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +h5_ = makeParent "h5" +h6_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +h6_ = makeParent "h6" +head_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +head_ = makeParent "head" +header_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +header_ = makeParent "header" +html_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +html_ = makeParent "html" +i_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +i_ = makeParent "i" +iframe_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +iframe_ = makeParent "iframe" +ins_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +ins_ = makeParent "ins" +kbd_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +kbd_ = makeParent "kbd" +label_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +label_ = makeParent "label" +legend_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +legend_ = makeParent "legend" +li_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +li_ = makeParent "li" +main_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +main_ = makeParent "main" +map_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +map_ = makeParent "map" +mark_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +mark_ = makeParent "mark" +menu_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +menu_ = makeParent "menu" +menuitem_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +menuitem_ = makeParent "menuitem" +meter_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +meter_ = makeParent "meter" +nav_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +nav_ = makeParent "nav" +noscript_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +noscript_ = makeParent "noscript" +object_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +object_ = makeParent "object" +ol_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +ol_ = makeParent "ol" +optgroup_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +optgroup_ = makeParent "optgroup" +option_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +option_ = makeParent "option" +output_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +output_ = makeParent "output" +p_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +p_ = makeParent "p" +pre_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +pre_ = makeParent "pre" +progress_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +progress_ = makeParent "progress" +q_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +q_ = makeParent "q" +rp_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +rp_ = makeParent "rp" +rt_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +rt_ = makeParent "rt" +ruby_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +ruby_ = makeParent "ruby" +s_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +s_ = makeParent "s" +samp_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +samp_ = makeParent "samp" +section_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +section_ = makeParent "section" +select_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +select_ = makeParent "select" +small_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +small_ = makeParent "small" +span_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +span_ = makeParent "span" +strong_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +strong_ = makeParent "strong" +sub_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +sub_ = makeParent "sub" +summary_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +summary_ = makeParent "summary" +sup_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +sup_ = makeParent "sup" +table_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +table_ = makeParent "table" +tbody_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +tbody_ = makeParent "tbody" +td_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +td_ = makeParent "td" +tfoot_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +tfoot_ = makeParent "tfoot" +th_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +th_ = makeParent "th" +thead_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +thead_ = makeParent "thead" +time_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +time_ = makeParent "time" +tr_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +tr_ = makeParent "tr" +u_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +u_ = makeParent "u" +ul_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +ul_ = makeParent "ul" +var_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +var_ = makeParent "var" +video_ :: Monad m => StatefulReactT s m a -> StatefulReactT s m () +video_ = makeParent "video" + +area_ :: Monad m => StatefulReactT s m () +area_ = makeLeaf "area" +base_ :: Monad m => StatefulReactT s m () +base_ = makeLeaf "base" +br_ :: Monad m => StatefulReactT s m () +br_ = makeLeaf "br" +col_ :: Monad m => StatefulReactT s m () +col_ = makeLeaf "col" +embed_ :: Monad m => StatefulReactT s m () +embed_ = makeLeaf "embed" +hr_ :: Monad m => StatefulReactT s m () +hr_ = makeLeaf "hr" +img_ :: Monad m => StatefulReactT s m () +img_ = makeLeaf "img" +input_ :: Monad m => StatefulReactT s m () +input_ = makeLeaf "input" +keygen_ :: Monad m => StatefulReactT s m () +keygen_ = makeLeaf "keygen" +link_ :: Monad m => StatefulReactT s m () +link_ = makeLeaf "link" +meta_ :: Monad m => StatefulReactT s m () +meta_ = makeLeaf "meta" +param_ :: Monad m => StatefulReactT s m () +param_ = makeLeaf "param" +source_ :: Monad m => StatefulReactT s m () +source_ = makeLeaf "source" +track_ :: Monad m => StatefulReactT s m () +track_ = makeLeaf "track" +wbr_ :: Monad m => StatefulReactT s m () +wbr_ = makeLeaf "wbr" + +-- script :: RawAttrs -> JSString -> IO ForeignNode +-- style :: RawAttrs -> JSString -> IO ForeignNode +-- textarea :: RawAttrs -> JSString -> IO ForeignNode +-- title :: RawAttrs -> JSString -> IO ForeignNode diff --git a/src/React/Events.hs b/src/React/Events.hs new file mode 100644 --- /dev/null +++ b/src/React/Events.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +module React.Events where + +import Haste +import Haste.Prim + +import React.Imports +import React.Types + +onChange :: (s -> ChangeEvent -> s) -> StatefulEventHandler s +onChange handler = StatefulEventHandler + (\s evt -> handler s (fromPtr (js_parseChangeEvent evt))) + ChangeEvt + +onKeyDown :: (s -> KeyboardEvent -> s) -> StatefulEventHandler s +onKeyDown handler = StatefulEventHandler + (\s evt -> handler s (fromPtr (js_parseKeyboardEvent evt))) + KeyDownEvt + +onKeyPress :: (s -> KeyboardEvent -> s) -> StatefulEventHandler s +onKeyPress handler = StatefulEventHandler + (\s evt -> handler s (fromPtr (js_parseKeyboardEvent evt))) + KeyPressEvt + +onKeyUp :: (s -> KeyboardEvent -> s) -> StatefulEventHandler s +onKeyUp handler = StatefulEventHandler + (\s evt -> handler s (fromPtr (js_parseKeyboardEvent evt))) + KeyUpEvt + +onMouseEnter :: (s -> MouseEvent -> s) -> StatefulEventHandler s +onMouseEnter handler = StatefulEventHandler + (\s evt -> handler s (fromPtr (js_parseMouseEvent evt))) + MouseEnterEvt + +onMouseLeave :: (s -> MouseEvent -> s) -> StatefulEventHandler s +onMouseLeave handler = StatefulEventHandler + (\s evt -> handler s (fromPtr (js_parseMouseEvent evt))) + MouseLeaveEvt + +onDoubleClick :: (s -> MouseEvent -> s) -> StatefulEventHandler s +onDoubleClick handler = StatefulEventHandler + (\s evt -> handler s (fromPtr (js_parseMouseEvent evt))) + DoubleClickEvt + +onClick :: (s -> MouseEvent -> s) -> StatefulEventHandler s +onClick handler = StatefulEventHandler + (\s evt -> handler s (fromPtr (js_parseMouseEvent evt))) + ClickEvt + +onEnter :: (s -> s) -> StatefulEventHandler s +onEnter f = onKeyPress handler where + handler s KeyboardEvent{key="Enter"} = f s + handler s _ = s diff --git a/src/React/Imports.hs b/src/React/Imports.hs new file mode 100644 --- /dev/null +++ b/src/React/Imports.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module React.Imports where + +import React.Types + +import Haste +import Haste.Foreign +import Haste.JSON +import Haste.Prim + +foreign import ccall js_React_DOM_leaf :: JSString -> RawAttrs -> IO ForeignNode +foreign import ccall js_React_DOM_parent :: JSString -> RawAttrs -> ReactArray -> IO ForeignNode + +foreign import ccall js_empty_object :: IO RawAttrs +foreign import ccall "js_set_field" js_set_field_String :: RawAttrs -> JSString -> JSString -> IO () +foreign import ccall "js_set_field" js_set_field_Double :: RawAttrs -> JSString -> Double -> IO () +foreign import ccall "js_set_field" js_set_field_Int :: RawAttrs -> JSString -> Int -> IO () +foreign import ccall "js_set_field" js_set_field_Obj :: RawAttrs -> JSString -> RawAttrs -> IO () +foreign import ccall js_set_field_True :: RawAttrs -> JSString -> IO () +foreign import ccall js_set_field_False :: RawAttrs -> JSString -> IO () +foreign import ccall js_targetValue :: RawEvent -> JSString + +foreign import ccall js_set_onClick :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_set_onDoubleClick :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_set_onChange :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_set_onKeyUp :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_set_onKeyPress :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_set_onKeyDown :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_set_onBlur :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_set_onMouseEnter :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_set_onMouseLeave :: Ptr (RawEvent -> IO ()) -> RawAttrs -> IO () +foreign import ccall js_React_getDomNode :: ForeignNode -> IO (Ptr (Maybe Elem)) + +foreign import ccall "js_empty" js_ReactArray_empty :: IO ReactArray +foreign import ccall "js_push" js_ReactArray_push :: ReactArray -> ForeignNode -> IO () + +foreign import ccall "js_id" js_React_DOM_text :: JSString -> IO ForeignNode + +foreign import ccall js_parseChangeEvent :: RawEvent -> Ptr ChangeEvent +foreign import ccall js_parseKeyboardEvent :: RawEvent -> Ptr KeyboardEvent +foreign import ccall js_parseMouseEvent :: RawEvent -> Ptr MouseEvent diff --git a/src/React/Types.hs b/src/React/Types.hs new file mode 100644 --- /dev/null +++ b/src/React/Types.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, + FlexibleInstances, FlexibleContexts, GADTs #-} +module React.Types where + +import Control.Applicative +import Control.Monad +import Data.Functor.Identity +import Data.Monoid +import Data.String + +import Haste +import Haste.Foreign +import Haste.JSON +import Haste.Prim + +newtype ForeignNode = ForeignNode JSAny deriving (Pack, Unpack) +newtype RawAttrs = RawAttrs JSAny deriving (Pack, Unpack) +newtype ReactArray = ReactArray JSAny deriving (Pack, Unpack) + +data EvtType + = ChangeEvt + | KeyDownEvt + | KeyPressEvt + | KeyUpEvt + | ClickEvt + | DoubleClickEvt + | MouseEnterEvt + | MouseLeaveEvt + +data StatefulEventHandler s = StatefulEventHandler + { handler :: s -> RawEvent -> s + , evtType :: EvtType + } + +newtype RawEvent = RawEvent JSAny deriving (Pack, Unpack) + +type Attrs = [(JSString, JSON)] + +data ReactNode s = Parent JSString Attrs [StatefulEventHandler s] [ReactNode s] + | Leaf JSString Attrs [StatefulEventHandler s] + -- | Pre Attrs Handlers [ReactNode] -- it'd be super cool to restrict this to a string somehow (restrict the underlying monad so it can only set attrs and string?) + | Text String -- TODO(joel) JSString? + + +getState :: StatefulReact s s +getState = StatefulReactT $ \s -> return ([], s, s) + +newtype StatefulReactT s m a = StatefulReactT + { runStatefulReactT :: s -> m ([ReactNode s], s, a) } + +type StatefulReact s = StatefulReactT s Identity + +-- runStatefulReact :: StatefulReactT s a -> s -> ([ReactNode s], s, a) +-- runStatefulReact react s = runIdentity $ runStatefulReact react s + +instance Monoid a => Monoid (StatefulReact s a) where + mempty = StatefulReactT $ \s -> return ([], s, mempty) + mappend f1 f2 = StatefulReactT $ \s -> do + ~(c1, s1, a) <- runStatefulReactT f1 s + ~(c2, s2, b) <- runStatefulReactT f2 s1 + return (c1 <> c2, s2, a <> b) + +instance Monad m => Functor (StatefulReactT s m) where + fmap = liftM + +instance Monad m => Applicative (StatefulReactT s m) where + pure = return + (<*>) = ap + +instance (Monad m, a ~ ()) => IsString (StatefulReactT s m a) where + fromString str = StatefulReactT $ \s -> return ([Text str], s, ()) + +instance Monad m => Monad (StatefulReactT s m) where + return a = StatefulReactT $ \s -> return ([], s, a) + m >>= f = StatefulReactT $ \s -> do + ~(c1, s1, a) <- runStatefulReactT m s + ~(c2, s2, b) <- runStatefulReactT (f a) s1 + return (c1 <> c2, s2, b) + +-- TODO thinking there should be some notion of single / multiple? +-- We should only ever apply an attribute / handler to one element here. +-- +-- div > div) React` +-- +-- except things with no children? +-- +-- input Attributable (StatefulReactT s m a) (JSString, JSON) where + react do + ~(children, s', a) <- runStatefulReactT react s + return (children attr, s', a) + +instance Monad m => + Attributable (StatefulReactT s m a) (StatefulEventHandler s) where + react do + ~(children, s', a) <- runStatefulReactT react s + return (children + Attributable (StatefulReactT s m a -> StatefulReactT s m a) x where + f a -> h + +( h -> (Bool, a) -> h +h ) :: [ReactNode s] -> (JSString, JSON) -> [ReactNode s] +[elem] attr = [go elem] where + go (Parent name as hs cs) = Parent name (attr:as) hs cs + go (Leaf name as hs) = Leaf name (attr:as) hs + go (Text str) = Text str +_ _ = error "attr applied to multiple elems!" + +( StatefulEventHandler s -> [ReactNode s] +[elem]