Skip to content

Commit

Permalink
- Added JQuery library
Browse files Browse the repository at this point in the history 
- Some changes
  • Loading branch information
@serras
serras authored and Alejandro committed Jan 26, 2011
1 parent 5304d5f commit 3c5d221
Show file tree
Hide file tree
Showing 4 changed files with 7,070 additions and 55 deletions.
1 change: 1 addition & 0 deletions Example-HTML.html
View file
Expand Up @@ -61,6 +61,7 @@
<body>

<div id="example_count"> </div>
<input type="button" id="example_button" />

</body>
</html>
185 changes: 138 additions & 47 deletions Example.hs
View file
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 {
Expand Down Expand Up @@ -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
Expand All @@ -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,())
Expand Down Expand Up @@ -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*
Expand All @@ -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

Expand All @@ -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 []
Expand All @@ -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
Expand Down Expand Up @@ -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 ()
Expand Down

0 comments on commit 3c5d221

Please sign in to comment.