Permalink
Browse files

- Continue working on Example

- Added JS library
- Added compile script
  • Loading branch information...
1 parent 14e9771 commit 9d3c5d1e46daf49c9bee056e7962fbe0ef62dd75 Alejandro committed Dec 13, 2010
Showing with 229 additions and 11 deletions.
  1. +178 −11 Example.hs
  2. +4 −0 compile
  3. +47 −0 lib.js
View
@@ -4,6 +4,8 @@ import AFRP
import Control.Arrow
import Data.IORef
+-- I would use a Map instead of [(a,b)], but it's not available
+-- import Data.Map
import Control.Category
import Prelude hiding (id, (.))
@@ -14,13 +16,120 @@ data JSRawInput = JSRawInput {
jsMousePosition :: (Int, Int)
}
data JSResponse = JSInit
-data JSRequest = JSSetTextRequest
+ | JSLabelCreateResp
+ | JSDeComp (Event JSResponse,Event JSResponse)
+data JSRequest = JSLabelCreateReq JSLabelState
+ | JSLabelSetReq JSLabelState
+ | JSComp (Event JSRequest,Event JSRequest)
type Responder a b = SF (JSRawInput, Event JSResponse, a) (Event JSRequest, b)
+
+-- for now our GUI is just a map of elements, no layout
newtype JSGUI a b = JSGUI (Responder a b)
+-- Lifting/lowering
+
+jsUnGUI :: JSGUI b c -> Responder b c
+jsUnGUI (JSGUI w) = w
+
+jsSF :: SF b c -> JSGUI b c
+jsSF sf = JSGUI $ proc (_,_,b) -> do
+ c <- sf -< b
+ returnA -< (noEvent,c)
+
+jsArr :: (b -> c) -> JSGUI b c
+jsArr f = jsSF (arr f)
+
+jsFirst :: JSGUI b c -> JSGUI (b,d) (c,d)
+jsFirst (JSGUI w) = JSGUI $ proc (inp,resp,(b,d)) -> do
+ (req,c) <- w -< (inp,resp,b)
+ returnA -< (req,(c,d))
+
+decompResp :: Event JSResponse -> (Event JSResponse,Event JSResponse)
+decompResp (Event JSInit) = (Event JSInit, Event JSInit)
+decompResp (Event (JSDeComp (resp0,resp1))) = (resp0,resp1)
+decompResp _ = (noEvent,noEvent)
+
+compReq :: Event JSRequest -> Event JSRequest -> Event JSRequest
+compReq NoEvent NoEvent = noEvent
+compReq req0 req1 = Event (JSComp (req0,req1))
+
+jsComp :: JSGUI b c -> JSGUI c d -> JSGUI b d
+jsComp (JSGUI w1) (JSGUI w2) = JSGUI $ proc (inp,resp,b) -> do
+ let (resp1,resp2) = decompResp resp
+ (req1,c) <- w1 -< (inp,resp1,b)
+ (req2,d) <- w2 -< (inp,resp2,c)
+ returnA -< (compReq req1 req2,d)
+
+jsLoop :: JSGUI (b,d) (c,d) -> JSGUI b c
+jsLoop (JSGUI w) = JSGUI $ proc (inp,resp,b) -> do
+ rec (req,(c,d)) <- w -< (inp,resp,(b,d))
+ returnA -< (req,c)
+
+instance Category JSGUI where
+ (.) = flip jsComp
+ id = arr Prelude.id
+
+instance Arrow JSGUI where
+ arr = jsArr
+ first = jsFirst
+
+instance ArrowLoop JSGUI where
+ loop = jsLoop
+
type JSRHandle = ReactHandle (JSRawInput, Event JSResponse, ()) (Event JSRequest, ())
+-----------------------------------------------------------
+-- Static text (label) widget: Displays a string, and has
+-- no output.
+
+-- State
+
+data JSLabelState = JSLabelState {
+ labelDiv :: String,
+ labelText :: String
+ } deriving (Eq, Show)
+
+type JSLabelConf = JSLabelState -> JSLabelState
+
+-- Constructor
+
+label :: String -> JSLabelConf
+label text ls = ls {labelText = text}
+
+div_ :: String -> JSLabelConf
+div_ div ls = ls {labelDiv = div}
+
+-- The label GUI
+
+jsLabel :: JSLabelConf -> JSGUI JSLabelConf ()
+jsLabel conf0 =
+ let -- Initial state
+ defState = JSLabelState {labelDiv = "label", labelText = "Default"}
+ initState = conf0 defState
+
+ -- Detect creation
+ maybeCreate JSLabelCreateResp = Just True
+ maybeCreate _ = Nothing
+
+ in JSGUI $ proc (_,resp,conf) -> do
+ -- State
+ rec state <- iPre initState -< conf state
+ stateChanged <- edgeBy maybeChanged initState -< state
+
+ -- Creation
+ isCreated <- hold False -< mapFilterE maybeCreate resp
+ let doCreate = if isCreated then noEvent else Event ()
+
+ -- Output
+ let req = lMerge (tag doCreate (JSLabelCreateReq state))
+ (tag stateChanged (JSLabelSetReq state))
+ returnA -< (req,())
+
+jsMouse :: JSGUI () (Int, Int)
+jsMouse = JSGUI $ proc (inp,_,_) -> do
+ returnA -< (noEvent, jsMousePosition inp)
+
type JSGUIState = Int
type JSGUIRef = IORef JSGUIState
@@ -30,6 +139,7 @@ startGUI (JSGUI g) = do
epoch <- getCurrentTime
gsr <- newIORef epoch
rh <- reactInit initSense (actuate gsr) g
+ addEvent (stringToJSString "") (stringToJSString "timeout") gsr rh NoEvent
return ()
-- Get an input sample from the OS.
@@ -67,32 +177,75 @@ respond gsr rh resp = do
actuate :: JSGUIRef -> JSRHandle -> Bool -> (Event JSRequest,()) -> IO Bool
actuate gsr rh _ (wre,_) =
do -- Handle requests, if any.
- --(f,t,prevc) <- readIORef gsr
- --(resp,c,cch) <- handleWidgetReq gsr rh f [] prevc wre
+ t <- readIORef gsr
+ resp <- handleWidgetReq gsr rh wre
-- Reset layout if contents changed.
-- *No layouting in this example*
-- Turn around and respond to the widgets, if necessary.
-- Note that this causes a reentrant call to react.
- --case resp of
- -- NoEvent -> return ()
- -- _ -> respond gsr rh resp
+ case resp of
+ NoEvent -> return ()
+ _ -> respond gsr rh resp
return False
+
+handleWidgetReq :: JSGUIRef -> JSRHandle -> (Event JSRequest) -> IO (Event JSResponse)
+handleWidgetReq _ _ NoEvent = return NoEvent
+handleWidgetReq _ _ (Event (JSLabelCreateReq t)) = do
+ changeText (stringToJSString . labelDiv $ t) (stringToJSString . labelText $ t)
+ return $ Event JSLabelCreateResp
+handleWidgetReq _ _ (Event (JSLabelSetReq t)) = do
+ changeText (stringToJSString . labelDiv $ t) (stringToJSString . labelText $ t)
+ return NoEvent
+
------------------------------------------------------------------
-- Utility functions from Yampa, UHC blog and Javascript reference
+
type JSString = PackedString
stringToJSString :: String -> JSString
jsStringToString :: JSString -> String
-foreign import jscript "getCurrentTime()" getCurrentTime :: IO Int
-foreign import jscript "mouseX()" getMouseX :: IO Int
-foreign import jscript "mouseY()" getMouseY :: IO Int
-foreign import jscript "setInterval(%*)" setInterval :: (a -> ()) -> Int -> IO Int
-foreign import jscript "clearInterval(%*)" clearInterval :: Int -> IO ()
+foreign import jscript "getCurrentTime()" getCurrentTime :: IO Int
+foreign import jscript "mouseX()" getMouseX :: IO Int
+foreign import jscript "mouseY()" getMouseY :: IO Int
+foreign import jscript "addEvent(%*)" addEvent :: JSString -> JSString -> JSGUIRef -> JSRHandle -> Event JSResponse -> IO ()
+foreign import jscript "changeText(%*)" changeText :: JSString -> JSString -> IO ()
+
+
+------------------------------------
+-- Fake code for compiling in GHC --
+------------------------------------
+
+{-
+type JSString = String
+stringToJSString :: String -> JSString
+stringToJSString = id
+jsStringToString :: JSString -> String
+jsStringToString = id
+
+getCurrentTime :: IO Int
+getCurrentTime = return 3
+getMouseX = getCurrentTime
+getMouseY = getCurrentTime
+
+addEvent :: JSString -> JSString -> JSGUIRef -> JSRHandle -> Event JSResponse -> IO ()
+addEvent _ _ _ _ _ = return ()
+
+changeText :: JSString -> JSString -> IO ()
+changeText _ _ = return ()
+-}
+
+-- UNTIL HERE --
+----------------
+
+
+-- Utility to detect when a widget's state has changed
+maybeChanged :: Eq a => a -> a -> Maybe ()
+maybeChanged s s' = if s == s' then Nothing else Just ()
-- ensure an observable amount of time elapses by busy-waiting.
--
@@ -116,3 +269,17 @@ ensureTimeElapses t0 t1 getTime = do
else do t' <- getTime
ensureTimeElapses t0 t' getTime
+
+
+-----------------
+-- THE EXAMPLE --
+-----------------
+
+example :: JSGUI () ()
+example = proc _ -> do
+ rec mpos <- jsMouse -< ()
+ _ <- jsLabel (div_ "example") -< (label $ show (fst mpos))
+ returnA -< ()
+
+main :: IO ()
+main = startGUI example
View
@@ -0,0 +1,4 @@
+#!/bin/bash
+
+arrowp < ${1} > ${1/.hs/.no-arrows.hs}
+uhc -t jscript ${1/.hs/.no-arrows.hs}
View
47 lib.js
@@ -0,0 +1,47 @@
+function getCurrentTime() {
+ var d = new Date();
+ return d.getTime();
+}
+
+function mousePosition() {
+ var posx = 0;
+ var posy = 0;
+ if (!e) var e = window.event;
+ if (e.pageX || e.pageY) {
+ posx = e.pageX;
+ posy = e.pageY;
+ }
+ else if (e.clientX || e.clientY) {
+ posx = e.clientX + document.body.scrollLeft
+ + document.documentElement.scrollLeft;
+ posy = e.clientY + document.body.scrollTop
+ + document.documentElement.scrollTop;
+ }
+ // posx and posy contain the mouse position relative to the document
+ // Do something with this information
+
+ return [posx, posy];
+}
+
+function mouseX() {
+ var position = mousePosition();
+ return position[0];
+}
+
+function mouseY() {
+ var position = mousePosition();
+ return position[1];
+}
+
+function changeText(div, text) {
+ document.getElementById(div).innerHTML = text;
+}
+
+function addEvent(div, event, guiref, rhandle, response) {
+ if (event == "timeout") {
+ var closure = function() {
+ respond(guiref, rhandle, response);
+ }
+ setTimeout(closure, 30);
+ }
+}

0 comments on commit 9d3c5d1

Please sign in to comment.