Permalink
Browse files

- Added JQuery library

- Some changes
  • Loading branch information...
1 parent 5304d5f commit 3c5d221883ab12da309f4f79c318eb1e5432edd9 @serras committed with Alejandro Jan 26, 2011
Showing with 7,070 additions and 55 deletions.
  1. +1 −0 Example-HTML.html
  2. +138 −47 Example.hs
  3. +6,883 −0 jquery-1.4.3.js
  4. +48 −8 lib.js
View
@@ -61,6 +61,7 @@
<body>
<div id="example_count"> </div>
+<input type="button" id="example_button" />
</body>
</html>
View
@@ -13,24 +13,36 @@ import qualified Prelude (id, (.))
data JSRawInput = JSRawInput {
- jsMousePosition :: (Int, Int)
+ jsMousePosition :: (Int, Int),
+ jsTime :: (Int, Int, Int)
}
deriving Show
data JSResponse = JSInit
+ | JSLifeBeat
| JSLabelCreateResp
+ | JSButtonCreateResp
+ | JSButtonCommandEvent
| JSTimeoutCreateResp
| JSTimeoutTickResp
| JSDeComp (Event JSResponse,Event JSResponse)
+ -- deriving Show
data JSRequest = JSLabelCreateReq JSLabelState
| JSLabelSetReq JSLabelState
| JSTimeoutReq JSTimeoutState
+ | JSButtonCreateReq JSButtonState
+ | JSButtonSetReq JSButtonState
| 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)
+-- Compositional path to a widget.
+-- A True entry means go down the left/top branch,
+-- False means go down the right/bottom.
+type JSPath = [Bool]
+
-- Lifting/lowering
jsUnGUI :: JSGUI b c -> Responder b c
@@ -122,12 +134,13 @@ jsLabel conf0 =
stateChanged <- edgeBy maybeChanged initState -< state
-- Creation
- isCreated <- hold False -< mapFilterE maybeCreate resp
- let doCreate = if isCreated then noEvent else Event ()
+ -- 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))
+ -- let req = lMerge (tag doCreate (JSLabelCreateReq state))
+ -- (tag stateChanged (JSLabelSetReq state))
+ let req = tag stateChanged (JSLabelSetReq state)
returnA -< (req,())
-- The mouse widget
@@ -136,6 +149,10 @@ jsMouse :: JSGUI () (Int, Int)
jsMouse = JSGUI $ proc (inp,_,_) -> do
returnA -< (noEvent, jsMousePosition inp)
+jsCurrentTime :: JSGUI () (Int, Int,Int)
+jsCurrentTime = JSGUI $ proc (inp,_,_) -> do
+ returnA -< (noEvent, jsTime inp)
+
-- The timeout widget
data JSTimeoutState = JSTimeoutState {
@@ -192,6 +209,57 @@ jsTimeout conf0 =
returnA -< (req,tick)
+
+-- The button widget
+
+data JSButtonState = JSButtonState {
+ bsId :: String,
+ bsLabel :: String
+ } deriving (Eq, Show)
+
+type JSButtonConf = JSButtonState -> JSButtonState
+
+btext :: String -> JSButtonConf
+btext l bs = bs {bsLabel = l}
+
+id_ :: String -> JSButtonConf
+id_ i bs = bs {bsId = i}
+
+jsButton :: JSButtonConf -> JSGUI JSButtonConf (Event ())
+jsButton conf0 =
+ let -- Initial state
+ defState = JSButtonState {bsId = "id", bsLabel = "Default"}
+ initState = conf0 defState
+
+ -- Detect creation
+ -- maybeCreate JSButtonCreateResp = Just True
+ -- maybeCreate _ = Nothing
+
+ -- Detect button press
+ maybeCommand JSButtonCommandEvent = Just ()
+ maybeCommand _ = Nothing
+
+ in JSGUI $ proc (_,resp,conf) -> do
+ -- Keep track of the state.
+ rec state <- iPre initState -< conf state
+
+ -- Has the state changed? If so, generate set request.
+ stateChanged <- edgeBy maybeChanged initState -< state
+
+ -- isCreated <- hold False -< mapFilterE maybeCreate resp
+
+ -- let doCreate = if isCreated then noEvent else Event ()
+
+ -- Merge create/set requests.
+ -- let req = lMerge (tag doCreate (JSButtonCreateReq state))
+ -- (tag stateChanged (JSButtonSetReq state))
+
+ let req = tag stateChanged (JSButtonSetReq state)
+ -- Pass button presses through.
+ let press = mapFilterE maybeCommand resp
+
+ returnA -< (req,press)
+
-- Internal GUI state
type JSGUIState = Int
@@ -203,15 +271,18 @@ startGUI (JSGUI g) = do
epoch <- getCurrentTime
gsr <- newIORef epoch
rh <- reactInit initSense (actuate gsr) g
- -- addEvent "timeout" $ respond gsr rh NoEvent
+ addEvent "lifebeat" "" $ respond gsr rh (Event JSLifeBeat)
return ()
-- Get an input sample from the OS.
getRawInput :: IO JSRawInput
getRawInput = do
mouseX <- getMouseX
mouseY <- getMouseY
- return JSRawInput {jsMousePosition = (mouseX, mouseY)}
+ h <- getCurrentHours
+ m <- getCurrentMinutes
+ s <- getCurrentSeconds
+ return JSRawInput {jsMousePosition = (mouseX, mouseY), jsTime = (h,m,s)}
-- The very first input sample.
initSense :: IO (JSRawInput,Event JSResponse,())
@@ -246,7 +317,7 @@ actuate gsr rh _ (wre,_) =
t <- readIORef gsr
-- putStrLn "actuate"
-- putStrLn $ show t
- resp <- handleWidgetReq gsr rh wre
+ resp <- handleWidgetReq gsr rh [] wre
-- Reset layout if contents changed.
-- *No layouting in this example*
@@ -259,44 +330,53 @@ actuate gsr rh _ (wre,_) =
return False
-handleWidgetReq :: JSGUIRef -> JSRHandle -> (Event JSRequest) -> IO (Event JSResponse)
-handleWidgetReq _ _ NoEvent = do
+handleWidgetReq :: JSGUIRef -> JSRHandle -> JSPath -> (Event JSRequest) -> IO (Event JSResponse)
+handleWidgetReq _ _ _ NoEvent = do
-- alert $ stringToJSString "No event"
return NoEvent
-handleWidgetReq _ _ (Event (JSLabelCreateReq t)) = do
- -- alert $ stringToJSString "Label create"
+handleWidgetReq _ _ _ (Event (JSLabelCreateReq t)) = do
let ldiv = labelDiv t
- -- alert $ stringToJSString "Label div obtained"
let ltext = labelText t
- -- alert $ stringToJSString "Label text obtained"
- changeText (stringToJSString ldiv) (stringToJSString ltext)
- -- alert $ stringToJSString "Label created"
+ changeDiv (stringToJSString ldiv) (stringToJSString ltext)
+ -- alert $ stringToJSString "Zas"
return $ Event JSLabelCreateResp
-handleWidgetReq _ _ (Event (JSLabelSetReq t)) = do
- -- alert $ stringToJSString "Label set"
- -- alert $ stringToJSString "Label create"
+handleWidgetReq _ _ _ (Event (JSLabelSetReq t)) = do
let ldiv = labelDiv t
- -- alert $ stringToJSString "Label div obtained"
let ltext = labelText t
- -- alert $ stringToJSString "Label text obtained"
- changeText (stringToJSString ldiv) (stringToJSString ltext)
- -- alert $ stringToJSString "Label set"
+ changeDiv (stringToJSString ldiv) (stringToJSString ltext)
+ -- alert $ stringToJSString "Zos"
return NoEvent
-handleWidgetReq gsr rh (Event (JSTimeoutReq t)) = do
- -- alert $ stringToJSString "timeout"
- addEvent "timeout" $ respond gsr rh (Event JSTimeoutTickResp)
+handleWidgetReq _ _ _ (Event (JSButtonCreateReq t)) = do
+ let bid = bsId t
+ let btext = bsLabel t
+ changeButtonText (stringToJSString bid) (stringToJSString btext)
+ return $ Event JSButtonCreateResp
+handleWidgetReq gsr rh path (Event (JSButtonSetReq t)) = do
+ let bid = bsId t
+ let btext = bsLabel t
+ changeButtonText (stringToJSString bid) (stringToJSString btext)
+ addEvent "click" bid $ respond gsr rh (pathify (Event JSTimeoutTickResp) path)
+ return NoEvent
+handleWidgetReq gsr rh _ (Event (JSTimeoutReq t)) = do
+ addEvent "timeout" "" $ respond gsr rh (Event JSTimeoutTickResp)
return $ Event JSTimeoutCreateResp
-handleWidgetReq gsr rh (Event (JSComp (lreq, rreq))) = do
- -- alert $ stringToJSString "comp"
- lresp <- handleWidgetReq gsr rh lreq
- rresp <- handleWidgetReq gsr rh rreq
+handleWidgetReq gsr rh path (Event (JSComp (lreq, rreq))) = do
+ lresp <- handleWidgetReq gsr rh (True:path) lreq
+ rresp <- handleWidgetReq gsr rh (False:path) rreq
return $ case (lresp, rresp) of
(NoEvent, NoEvent) -> noEvent
resp -> Event (JSDeComp resp)
-handleWidgetReq _ _ _ = do
- -- alert $ stringToJSString "nothing"
+handleWidgetReq _ _ _ _ = do
return NoEvent
+-- Construct a JSResponse corresponding to a given
+-- path. This response will then be directed to the
+-- correct widget.
+pathify :: Event JSResponse -> JSPath -> Event JSResponse
+pathify e [] = e
+pathify e (True:path) = pathify (Event (JSDeComp (e,noEvent))) path
+pathify e (False:path) = pathify (Event (JSDeComp (noEvent,e))) path
+
------------------------------------------------------------------
-- Utility functions from Yampa, UHC blog and Javascript reference
@@ -306,15 +386,20 @@ foreign import prim "primStringToPackedString" stringToJSString :: String -> JSS
jsStringToString :: JSString -> String
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.getCurrentTime()" getCurrentTime :: IO Int
+foreign import jscript "lib.getCurrentHours()" getCurrentHours :: IO Int
+foreign import jscript "lib.getCurrentMinutes()" getCurrentMinutes :: IO Int
+foreign import jscript "lib.getCurrentSeconds()" getCurrentSeconds :: IO Int
+
+foreign import jscript "lib.mouseX()" getMouseX :: IO Int
+foreign import jscript "lib.mouseY()" getMouseY :: IO Int
+foreign import jscript "lib.changeDiv(%*)" changeDiv :: JSString -> JSString -> IO ()
+foreign import jscript "lib.changeButtonText(%*)" changeButtonText :: 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 ()
+foreign import jscript "lib.addEvent(%*)" addEvent' :: JSString -> JSString -> IO ()
initEvents :: IO ()
initEvents = do ref <- newIORef []
@@ -330,10 +415,10 @@ 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)
+addEvent :: String -> String -> IO () -> IO ()
+addEvent w_id w_params cb = do s <- getState
+ setState $ (w_id, cb) : s
+ addEvent' (stringToJSString w_id) (stringToJSString w_params)
foreign export jscript "eventCallback" eventCallback :: JSString -> IO ()
eventCallback w_id = do s <- getState
@@ -402,13 +487,19 @@ ensureTimeElapses t0 t1 getTime = do
-- THE EXAMPLE --
-----------------
+accumulator :: JSGUI (Event ()) Int
+accumulator = JSGUI $ proc (_,_,tick) -> do
+ sum <- accum 0 -< tick `tag` (+1)
+ sum_ <- hold 0 -< sum
+ returnA -< (noEvent, sum_)
+
example :: JSGUI () ()
example = proc _ -> do
- rec mpos <- jsMouse -< ()
- tick <- jsTimeout ((timeId "example_time") . (time 3000)) -< id
- -- sum <- edgeTag (+1) -< tick
- -- count <- accum 1 -< sum
- _ <- jsLabel (div_ "example_count") -< (label $ show mpos)
+ -- tick <- jsTimeout ((timeId "example_time") . (time 3000)) -< id
+ -- sum <- accumulator -< tick
+ press <- jsButton (id_ "example_button") -< (btext "Hello")
+ sum <- accumulator -< press
+ _ <- jsLabel (div_ "example_count") -< (label $ show sum)
returnA -< ()
jQueryMain :: IO ()
Oops, something went wrong.

0 comments on commit 3c5d221

Please sign in to comment.