Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 3c5d221883
Fetching contributors…

Cannot retrieve contributors at this time

513 lines (403 sloc) 16.386 kb
module Example where
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, (.))
import qualified Prelude (id, (.))
data JSRawInput = JSRawInput {
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
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 widget
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))
let req = tag stateChanged (JSLabelSetReq state)
returnA -< (req,())
-- The mouse widget
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 {
timeoutId :: String,
timeoutTime :: Int
} deriving (Eq, Show)
type JSTimeoutConf = JSTimeoutState -> JSTimeoutState
timeId :: String -> JSTimeoutConf
timeId id ts = ts {timeoutId = id}
time :: Int -> JSTimeoutConf
time t ts = ts {timeoutTime = t}
jsTimeout :: JSTimeoutConf -> JSGUI JSTimeoutConf (Event ())
jsTimeout conf0 =
let -- Initial state
defState = JSTimeoutState {timeoutId = "timeout", timeoutTime = 1000}
initState = conf0 defState
-- Detect creation
maybeCreate JSTimeoutCreateResp = Just True
maybeCreate _ = Nothing
-- Detect timeout tick
maybeTick JSTimeoutTickResp = Just ()
maybeTick _ = 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
-- Send a creation request if we haven't been created yet.
-- WARNING: this is probably a bad way to do this. It can
-- create an infinitely-dense stream of Events, which is a
-- big no-no in the AFRP world (at least, conceptually).
-- We used to use WXWInit for this purpose, but with the
-- dynamic switching of widgets, the system wouldn't know
-- when to send the WXWInit events to widgets that have
-- been switched-into.
let doCreate = if isCreated then noEvent else Event (JSTimeoutReq state)
-- Merge create/set requests.
let req = tag doCreate (JSTimeoutReq state)
-- Pass button presses through.
let tick = mapFilterE maybeTick resp
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
type JSGUIRef = IORef JSGUIState
-- Start event loop
startGUI :: JSGUI () () -> IO ()
startGUI (JSGUI g) = do
epoch <- getCurrentTime
gsr <- newIORef epoch
rh <- reactInit initSense (actuate gsr) g
addEvent "lifebeat" "" $ respond gsr rh (Event JSLifeBeat)
return ()
-- Get an input sample from the OS.
getRawInput :: IO JSRawInput
getRawInput = do
mouseX <- getMouseX
mouseY <- getMouseY
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,())
initSense = do
inp <- getRawInput
return (inp, Event JSInit, ())
-- Push an input sample/widget response.
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
-- unnecessary, but we'll leave it in to be safe.
et <- getCurrentTime
(dtf,t) <- ensureTimeElapses prevt et getCurrentTime
writeIORef gsr t
-- Let Yampa work its magic.
react rh (dtf,Just (inp,resp,()))
return ()
-- Process an output sample (i.e. a widget request).
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.
-- *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
return False
handleWidgetReq :: JSGUIRef -> JSRHandle -> JSPath -> (Event JSRequest) -> IO (Event JSResponse)
handleWidgetReq _ _ _ NoEvent = do
-- alert $ stringToJSString "No event"
return NoEvent
handleWidgetReq _ _ _ (Event (JSLabelCreateReq t)) = do
let ldiv = labelDiv t
let ltext = labelText t
changeDiv (stringToJSString ldiv) (stringToJSString ltext)
-- alert $ stringToJSString "Zas"
return $ Event JSLabelCreateResp
handleWidgetReq _ _ _ (Event (JSLabelSetReq t)) = do
let ldiv = labelDiv t
let ltext = labelText t
changeDiv (stringToJSString ldiv) (stringToJSString ltext)
-- alert $ stringToJSString "Zos"
return NoEvent
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 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
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
-- String related
type JSString = PackedString
foreign import prim "primStringToPackedString" stringToJSString :: String -> JSString
jsStringToString :: JSString -> String
jsStringToString = packedStringToString
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 -> 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 -> 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
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 --
------------------------------------
{-
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.
--
-- arguments:
-- t0 :: Int -- time of last sample
-- 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 Floatforeign export jscript "jQueryMain" jQueryMain :: IO ()
-- t1 -- the current time, in millisec.
--
-- We perform the floating point conversion, and perform our comparison
-- with respect to that conversion here to ensure that we are using
-- the same test as used by reactimate.
--
ensureTimeElapses :: Int -> Int -> IO Int -> IO (Double,Int)
ensureTimeElapses t0 t1 getTime = do
let dt = t1 - t0
dtf = (fromIntegral dt) / 1000
if (dtf > 0) then return (dtf,t1)
else do t' <- getTime
ensureTimeElapses t0 t' getTime
-----------------
-- 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
-- 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 ()
jQueryMain = do initEvents
startGUI example
foreign export jscript "jQueryMain" jQueryMain :: IO ()
main :: IO ()
main = return ()
Jump to Line
Something went wrong with that request. Please try again.