Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

- More work on JS library

  • Loading branch information...
commit e3d8408fac34e8e2eb55c07ff3696d51311ac6b7 1 parent 9d3c5d1
Alejandro Serrano authored Alejandro committed
Showing with 161 additions and 45 deletions.
  1. +10 −8 AFRP.hs
  2. +49 −0 Example-HTML.html
  3. +59 −17 Example.hs
  4. +43 −20 lib.js
18 AFRP.hs
View
@@ -1336,10 +1336,10 @@ loopIntegral sf = loop (second integral >>> sf)
-- sf ......... Signal function to reactimate.
reactimate :: IO a
- -> (Bool -> IO (DTime, Maybe a))
- -> (Bool -> b -> IO Bool)
- -> SF a b
- -> IO ()
+ -> (Bool -> IO (DTime, Maybe a))
+ -> (Bool -> b -> IO Bool)
+ -> SF a b
+ -> IO ()
reactimate init sense actuate (SF {sfTF = tf0}) =
do
a0 <- init
@@ -1349,10 +1349,12 @@ reactimate init sense actuate (SF {sfTF = tf0}) =
loop sf a b = do
done <- actuate True b
unless (a `seq` b `seq` done) $ do
- (dt, ma') <- sense False
- let a' = maybe a id ma'
- (sf', b') = (sfTF' sf) dt a'
- loop sf' a' b'
+ (dt, ma_prime) <- sense False
+ let a_prime = maybe a id ma_prime
+ (sf_prime, b_prime) = (sfTF' sf) dt a_prime
+ loop sf_prime a_prime b_prime
+
+
-- An API for animating a signal function when some other library
-- needs to own the top-level control flow:
49 Example-HTML.html
View
@@ -0,0 +1,49 @@
+<!DOCTYPE html><html><head><title>Example</title>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/jscript/libEH-RTS.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Base.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Char.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Enum.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Float.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_MutVar.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Read.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_ST.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_STRef.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Show.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_StackTrace.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Types.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Ptr.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_ByteArray.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_IOBase.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_OldException.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_OldIO.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Run.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/Generics/UHC_Generics_Tuple.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Generics.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Bounded.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Eq.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/UHC/UHC_Ord.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/Data/Data_Maybe.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/Data/Data_IORef.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/uhcbase-1.1.2/uhc-1.1.2/jscript/plain/Control/Control_Monad.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/base-3.0.0.0/uhc-1.1.2/jscript/plain/Prelude.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/base-3.0.0.0/uhc-1.1.2/jscript/plain/Control/Control_Category.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/base-3.0.0.0/uhc-1.1.2/jscript/plain/Control/Monad/Control_Monad_Instances.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/base-3.0.0.0/uhc-1.1.2/jscript/plain/Data/Data_Function.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/base-3.0.0.0/uhc-1.1.2/jscript/plain/Control/Monad/Control_Monad_Fix.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/base-3.0.0.0/uhc-1.1.2/jscript/plain/Control/Control_Arrow.mjs"></script>
+<script type="text/javascript" src="/usr/local/lib/uhc-1.1.2/lib/pkg/haskell98-1.0.1.1/uhc-1.1.2/jscript/plain/Monad.mjs"></script>
+<script type="text/javascript" src="jquery-1.4.3.js"></script>
+<script type="text/javascript" src="lib.js"></script>
+<script type="text/javascript" src="AFRPMiscellany.mjs"></script>
+<script type="text/javascript" src="AFRPForceable.mjs"></script>
+<script type="text/javascript" src="AFRPDiagnostics.mjs"></script>
+<script type="text/javascript" src="AFRPEvent.mjs"></script>
+<script type="text/javascript" src="AFRP.mjs"></script>
+<script type="text/javascript" src="Example.no-arrows.js"></script>
+<script type="text/javascript">
+$(document).ready(jQueryMain);
+</script>
+</head>
+<body>
+</body>
+</html>
76 Example.hs
View
@@ -13,8 +13,9 @@ import qualified Prelude (id, (.))
data JSRawInput = JSRawInput {
- jsMousePosition :: (Int, Int)
- }
+ jsMousePosition :: (Int, Int)
+ }
+ deriving Show
data JSResponse = JSInit
| JSLabelCreateResp
| JSDeComp (Event JSResponse,Event JSResponse)
@@ -139,7 +140,8 @@ startGUI (JSGUI g) = do
epoch <- getCurrentTime
gsr <- newIORef epoch
rh <- reactInit initSense (actuate gsr) g
- addEvent (stringToJSString "") (stringToJSString "timeout") gsr rh NoEvent
+ addEvent "timeout" $ respond gsr rh NoEvent
+ -- addEvent "timeout" $ putStrLn "hola"
return ()
-- Get an input sample from the OS.
@@ -160,7 +162,9 @@ respond :: JSGUIRef -> JSRHandle -> Event JSResponse -> IO ()
respond gsr rh resp = do
-- Obtain input sample.
prevt <- readIORef gsr
+ putStrLn $ show prevt
inp <- getRawInput
+ putStrLn $ show inp
-- Make sure time's elapsed since the last call to react.
-- With the timer set up in startGUI, this is probably
@@ -178,6 +182,8 @@ actuate :: JSGUIRef -> JSRHandle -> Bool -> (Event JSRequest,()) -> IO Bool
actuate gsr rh _ (wre,_) =
do -- Handle requests, if any.
t <- readIORef gsr
+ putStrLn "actuate"
+ putStrLn $ show t
resp <- handleWidgetReq gsr rh wre
-- Reset layout if contents changed.
@@ -188,7 +194,6 @@ actuate gsr rh _ (wre,_) =
case resp of
NoEvent -> return ()
_ -> respond gsr rh resp
-
return False
@@ -204,17 +209,48 @@ handleWidgetReq _ _ (Event (JSLabelSetReq t)) = do
------------------------------------------------------------------
-- Utility functions from Yampa, UHC blog and Javascript reference
-
+-- String related
type JSString = PackedString
-stringToJSString :: String -> JSString
+foreign import prim "primStringToPackedString" 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 "addEvent(%*)" addEvent :: JSString -> JSString -> JSGUIRef -> JSRHandle -> Event JSResponse -> IO ()
-foreign import jscript "changeText(%*)" changeText :: JSString -> JSString -> IO ()
-
+jsStringToString = packedStringToString
+
+foreign import jscript "lib.getCurrentTime()" getCurrentTime :: IO Int
+foreign import jscript "lib.mouseX()" getMouseX :: IO Int
+foreign import jscript "lib.mouseY()" getMouseY :: IO Int
+foreign import jscript "lib.changeText(%*)" changeText :: JSString -> JSString -> IO ()
+foreign import jscript "window.alert(%*)" alert :: JSString -> IO ()
+
+foreign import jscript "lib.setState(%*)" setState' :: IORef [(String, IO ())] -> IO ()
+foreign import jscript "lib.getState()" getState' :: IO (IORef [(String, IO ())])
+foreign import jscript "lib.addEvent(%*)" addEvent' :: JSString -> IO ()
+
+initEvents :: IO ()
+initEvents = do ref <- newIORef []
+ setState' ref
+
+setState :: [(String, IO ())] -> IO ()
+setState s = do ref <- getState'
+ info <- readIORef ref
+ ref <- newIORef s
+ setState' ref
+
+getState :: IO [(String, IO ())]
+getState = do ref <- getState'
+ readIORef ref
+
+addEvent :: String -> IO () -> IO ()
+addEvent w_id cb = do s <- getState
+ setState $ (w_id, cb) : s
+ addEvent' (stringToJSString w_id)
+
+foreign export jscript "eventCallback" eventCallback :: JSString -> IO ()
+eventCallback w_id = do s <- getState
+ let w_id' = jsStringToString w_id
+ case lookup w_id' s of
+ Nothing -> return ()
+ Just cb -> do _ <- cb
+ return ()
------------------------------------
-- Fake code for compiling in GHC --
@@ -254,7 +290,7 @@ maybeChanged s s' = if s == s' then Nothing else Just ()
-- t1 :: Int -- current time, in milliseconds
-- getTime :: IO Int -- returns the current time, in milliseconds
-- result: (dtf,t1)
--- dtf -- the elapsed time since last sample, in seconds, as a Float
+-- dtf -- the elapsed time since last sample, in seconds, as a Floatforeign export jscript "jQueryMain" jQueryMain :: IO ()
-- t1 -- the current time, in millisec.
--
-- We perform the floating point conversion, and perform our comparison
@@ -277,9 +313,15 @@ ensureTimeElapses t0 t1 getTime = do
example :: JSGUI () ()
example = proc _ -> do
- rec mpos <- jsMouse -< ()
- _ <- jsLabel (div_ "example") -< (label $ show (fst mpos))
+ mpos <- jsMouse -< ()
+ -- _ <- jsLabel (div_ "example") -< (label $ show (fst mpos))
returnA -< ()
+jQueryMain :: IO ()
+jQueryMain = do initEvents
+ startGUI example
+
+foreign export jscript "jQueryMain" jQueryMain :: IO ()
+
main :: IO ()
-main = startGUI example
+main = return ()
63 lib.js
View
@@ -1,13 +1,21 @@
-function getCurrentTime() {
+var lib=
+ (lib ? lib : {});
+
+lib.alert = function(s) {
+ window.alert(s);
+};
+
+lib.getCurrentTime = function() {
var d = new Date();
return d.getTime();
-}
+};
-function mousePosition() {
- var posx = 0;
+lib.mousePosition = function() {
+ /* var posx = 0;
var posy = 0;
+ var e = jQuery.event;
if (!e) var e = window.event;
- if (e.pageX || e.pageY) {
+ if (e.pageX || e.pageY) {
posx = e.pageX;
posy = e.pageY;
}
@@ -20,28 +28,43 @@ function mousePosition() {
// posx and posy contain the mouse position relative to the document
// Do something with this information
- return [posx, posy];
-}
+ return [posx, posy]; */
+
+ /*
+ var doc = $(document);
+ return [doc.pageX, doc.pageY];
+ */
+
+ return [2,4];
+};
-function mouseX() {
- var position = mousePosition();
+lib.mouseX = function() {
+ var position = lib.mousePosition();
return position[0];
-}
+};
-function mouseY() {
- var position = mousePosition();
+lib.mouseY = function() {
+ var position = lib.mousePosition();
return position[1];
-}
+};
-function changeText(div, text) {
+lib.changeText = function(div, text) {
document.getElementById(div).innerHTML = text;
-}
+};
+
+lib.state = undefined;
+lib.setState = function(t) {
+ lib.state = t;
+};
+lib.getState = function() {
+ return lib.state;
+};
-function addEvent(div, event, guiref, rhandle, response) {
- if (event == "timeout") {
+lib.addEvent = function(ev_name) {
+ if (ev_name == "timeout") {
var closure = function() {
- respond(guiref, rhandle, response);
- }
+ eventCallback(ev_name);
+ };
setTimeout(closure, 30);
}
-}
+};
Please sign in to comment.
Something went wrong with that request. Please try again.