Permalink
Browse files

Updated example with fancier ajax request

  • Loading branch information...
1 parent 4191e17 commit 1adad1bfe7eb6d8d9f10981a83cdb583cd6558eb @bergmark bergmark committed Aug 12, 2012
Showing with 27 additions and 23 deletions.
  1. +2 −0 .gitignore
  2. +1 −0 TODO
  3. +6 −2 example/snaplets/fay/src/Dom.hs
  4. +17 −20 example/snaplets/fay/src/Index.hs
  5. +1 −1 example/src/Site.hs
View
@@ -2,3 +2,5 @@ dist
test-dest
example/log
example/snaplets/fay/js
+*.hi
+*.o
View
1 TODO
@@ -9,3 +9,4 @@
* TODO has to recompile if dependencies (imports) changed, should perhaps skip compileAll mode?
* Log messages should print relative paths
* Option for not overwriting js files if they are newer than hs files (for debugging)
+* Where should snap/fay shared functionality be stored?
@@ -1,8 +1,11 @@
-{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Dom where
+import Language.Fay.FFI
+import Language.Fay.Prelude
+
data Element
instance Foreign Element
@@ -34,7 +37,7 @@ byTag = ffi "document.getElementsByTagName(%1)"
byId :: String -> Fay Element
byId = ffi "document.getElementById(%1)"
-addEvent :: Foreign f => Element -> String -> (Event -> Fay f) -> Fay ()
+addEvent :: Foreign f => f -> String -> (Event -> Fay ()) -> Fay ()
addEvent = ffi "%1.addEventListener(%2,%3)"
addOnload :: Foreign f => Fay f -> Fay ()
@@ -60,3 +63,4 @@ printS = ffi "console.log(%1)"
print :: Foreign f => f -> Fay ()
print = ffi "console.log(%1)"
+
@@ -1,5 +1,12 @@
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+
module Index where
+import Language.Fay.FFI
+import Language.Fay.Prelude
+
import Dom
main :: Fay ()
@@ -14,31 +21,21 @@ onload = do
currentTime
button <- byId "current-time-button"
- addEvent button "click" currentTime
+ addEvent button "click" (const currentTime)
return ()
+data CTR = CTR { time :: String }
+instance Foreign CTR
+
currentTime :: Fay ()
-currentTime =
+currentTime = do
ajaxJson "/ajax/current-time" handleResponse
- where
- handleResponse json = do
- ctr <- jsonToCTR json
- el <- byId "current-time"
- setInnerHtml el (time ctr)
-data Json
-instance Foreign Json
+handleResponse :: CTR -> Fay ()
+handleResponse (CTR time) = do
+ el <- byId "current-time"
+ setInnerHtml el time
-data CurrentTimeResponse = CTR { time :: String }
-instance Foreign CurrentTimeResponse
-
-jsonToCTR :: Json -> Fay CurrentTimeResponse
-jsonToCTR json = do t <- attrS json "time"
- return $ CTR t
-
-ajaxJson :: String -> (Json -> Fay ()) -> Fay ()
+ajaxJson :: String -> (CTR -> Fay ()) -> Fay ()
ajaxJson = ffi "jQuery.ajax(%1, { success : %2 })"
-
-attrS :: Foreign f => f -> String -> Fay String
-attrS = ffi "%1[%2]"
View
@@ -26,7 +26,7 @@ currentTimeAjax :: AppHandler ()
currentTimeAjax = do
time <- liftIO getCurrentTime
modifyResponse . setContentType $ "text/json;charset=utf-8"
- writeLBS $ encode . toJSON $ object ["time" .= show time]
+ writeLBS $ encode . toJSON $ object ["instance" .= ("CTR" :: ByteString), "time" .= show time]
------------------------------------------------------------------------------

0 comments on commit 1adad1b

Please sign in to comment.