Skip to content

Commit

Permalink
Merge branch 'master' of https://github.com/spockz/uhc-jscript
Browse files Browse the repository at this point in the history
  • Loading branch information
@norm2782
norm2782 committed Dec 31, 2011
2 parents 6e39e29 + a9be3e5 commit 3470947
Show file tree
Hide file tree
Showing 7 changed files with 242 additions and 16 deletions.
2 changes: 2 additions & 0 deletions uhc-jscript/src/Language/UHC/JScript/ECMA/Array.hs
View file
Expand Up @@ -9,6 +9,8 @@ import UHC.BoxArray

type JSArray x = BoxArray x

instance JS (JSArray a)

foreign import jscript "%1.length"
lengthJSArray :: JSArray x -> Int

Expand Down
79 changes: 79 additions & 0 deletions uhc-jscript/src/Language/UHC/JScript/JQuery/Ajax.hs
View file
@@ -0,0 +1,79 @@
module Language.UHC.JScript.JQuery.Ajax (AjaxOptions(..), JSAjaxOptions(..), AjaxCallback, AjaxRequestType(..), ajaxBackend, ajax, toJSOptions, mkJSAjaxCallback) where

import Language.UHC.JScript.ECMA.String
import Language.UHC.JScript.Types

import Language.UHC.JScript.Primitives

import Data.List

data JQXHRPtr
type JQXHR = JSPtr JQXHRPtr


-- type AjaxCallback r = JS r => r -> String -> JQXHR -> IO()
type AjaxCallback r = r -> String -> JQXHR -> IO()
type JSAjaxCallback r = JSFunPtr (AjaxCallback r)

data AjaxRequestType = GET | POST
deriving Show


data AjaxOptions a = AjaxOptions {
ao_url :: String,
ao_requestType :: AjaxRequestType,
ao_contentType :: String,
ao_dataType :: String
}


data JSAjaxOptions a = JSAjaxOptions {
url :: JSString,
requestType :: JSString,
contentType :: JSString,
dataType :: JSString
}

instance Show (AjaxOptions a) where
show jsopt= "AjaxOptions: " ++ intercalate " " [show $ ao_url jsopt]

instance Show (JSAjaxOptions a) where
show jsopt = "JSAjaxOptions: " ++ intercalate " " [show $ url jsopt]

toJSOptions :: AjaxOptions a -> JSAjaxOptions a
toJSOptions options = let url' = toJS (ao_url options)
requestType' = toJS (show $ ao_requestType options)
contentType' = toJS (ao_contentType options)
dataType' = toJS (ao_dataType options)
in JSAjaxOptions { url = url'
, requestType = requestType'
, contentType = contentType'
, dataType = dataType'
}


ajaxBackend :: JS r => (JSPtr a -> IO ()) -> AjaxOptions a -> AjaxCallback r -> AjaxCallback r -> IO ()
ajaxBackend cont options onSuccess onFailure =
do let jsOptions = toJSOptions options
onSuccess' <- mkJSAjaxCallback onSuccess
onFailure' <- mkJSAjaxCallback onFailure
o <- mkObj jsOptions
_ <- setAttr "type" (requestType jsOptions) o
_ <- setAttr "success" onSuccess' o
_ <- setAttr "error" onFailure' o
_ajaxQ (toJS "jcu_app") o

ajax :: JS r => AjaxOptions a -> AjaxCallback r -> AjaxCallback r -> IO ()
ajax = ajaxBackend _ajax



foreign import jscript "wrapper"
mkJSAjaxCallback :: AjaxCallback r -> IO (JSAjaxCallback r)


foreign import jscript "$.ajax(%1)"
_ajax :: JSPtr a -> IO ()

foreign import jscript "$.ajaxq(%*)"
_ajaxQ :: JSString -> JSPtr a -> IO ()
15 changes: 15 additions & 0 deletions uhc-jscript/src/Language/UHC/JScript/JQuery/AjaxQueue.hs
View file
@@ -0,0 +1,15 @@
module Language.UHC.JScript.JQuery.AjaxQueue (ajaxQ) where

import Language.UHC.JScript.Primitives
import Language.UHC.JScript.Types

import Language.UHC.JScript.ECMA.String
import Language.UHC.JScript.JQuery.Ajax

import Language.UHC.JScript.Assorted (alert, _alert)

ajaxQ :: JS r => String -> AjaxOptions a -> AjaxCallback r -> AjaxCallback r -> IO ()
ajaxQ queuename = ajaxBackend (_ajaxQ $ toJS queuename)

foreign import jscript "$.ajaxq(%*)"
_ajaxQ :: JSString -> JSPtr a -> IO ()
96 changes: 93 additions & 3 deletions uhc-jscript/src/Language/UHC/JScript/JQuery/JQuery.hs
View file
Expand Up @@ -4,6 +4,8 @@ import Language.UHC.JScript.ECMA.String
import Language.UHC.JScript.Primitives
import Language.UHC.JScript.Types

import Language.UHC.JScript.Assorted (alert)

data JQueryPtr
type JQuery = JSPtr JQueryPtr

Expand Down Expand Up @@ -50,6 +52,30 @@ foreign import jscript "jQuery.when(%*)"
foreign import jscript "jQuery.when(%*)"
when'' :: JSPtr a -> JSPtr a -> JSPtr a -> IO ()

-------------------------------------------------------------------------------
-- DOM

foreign import jscript "%1.each(%2)"
each :: JQuery -> JSFunPtr (Int -> JSPtr a -> IO ()) -> IO ()

foreign import jscript "jQuery.each(%*)"
each' :: b -> JSFunPtr (Int -> JSPtr a -> IO ()) -> IO ()


foreign import jscript "wrapper"
mkEachIterator :: (Int -> JSPtr a -> IO ()) -> IO (JSFunPtr (Int -> JSPtr a -> IO ()))

-------------------------------------------------------------------------------
-- DOM

findSelector :: JQuery -> String -> IO JQuery
findSelector jq = findSelector' jq . toJS

foreign import jscript "%1.find(%2)"
findSelector' :: JQuery -> JSString -> IO JQuery

foreign import jscript "%1.find(%2)"
findObject :: JQuery -> JQuery -> IO JQuery

-------------------------------------------------------------------------------
-- Manipulation
Expand All @@ -64,21 +90,26 @@ foreign import jscript "%1.html()"
setHTML :: JQuery -> String -> IO ()
setHTML j s = _setHTML j (toJS s)


foreign import jscript "%1.html(%2)"
_setHTML :: JQuery -> JSString -> IO ()

foreign import jscript "%1.hide()"
hide :: JQuery -> IO ()

addClass :: JQuery -> String -> IO ()
addClass j s = _addClass j (toJS s)

wrapInner :: JQuery -> String -> IO ()
wrapInner j = _wrapInner j . toJS

foreign import jscript "%1.wrapInner(%2)"
_wrapInner :: JQuery -> JSString -> IO ()

-- Or return JQuery for chaining??? Does chaining even make sense?
foreign import jscript "%1.addClass(%2)"
_addClass :: JQuery -> JSString -> IO ()



-------------------------------------------------------------------------------
-- Effects

Expand All @@ -105,3 +136,62 @@ jqshow j (Just n) (Just e) Nothing = jqshow2 j n (toJS e)
jqshow j (Just n) Nothing (Just c) = jqshow2' j n c
jqshow j (Just n) (Just e) (Just c) = jqshow3 j n (toJS e) c


-------------------------------------------------------------------------------
-- Events

data JUIPtr
type JUI = JSPtr JUIPtr

type JEventResult = IO Bool
type JEventHandler = JSFunPtr ( JQuery -> JEventResult )
type JUIEventHandler = JSFunPtr ( JQuery -> JUI -> JEventResult )
type JEventType = String

bind :: JQuery -> JEventType -> JEventHandler -> IO ()
bind jq event eh = do _bind jq (toJS event) eh

foreign import jscript "%1.bind(%*)"
_bind :: JQuery -> JSString -> JEventHandler -> IO ()


blur :: JQuery -> JEventHandler -> IO ()
blur = undefined


click :: JQuery -> JEventHandler -> IO ()
click = _click

foreign import jscript "%1.click(%2)"
_click :: JQuery -> JEventHandler -> IO ()


keypress :: JQuery -> JEventHandler -> IO ()
keypress = undefined


onDocumentReady :: JSFunPtr (IO ()) -> IO ()
onDocumentReady f = _ready f

foreign import jscript "$('document').ready(%1)"
_ready :: JSFunPtr (IO ()) -> IO ()

-------------------------------------------------------------------------------
-- DOM Manipulation

append :: JQuery -> JQuery -> IO ()
append = _append

foreign import jscript "%1.append(%*)"
_append :: JQuery -> JQuery -> IO ()


-------------------------------------------------------------------------------
-- Dynamic loading

loadSrcFile :: String -> IO ()
loadSrcFile src = do let src' = toJS src :: JSString
scriptTag <- jQuery "<script>"
scriptTag' <- setAttr "src" src' scriptTag
body <- jQuery "body"
append body scriptTag'
3 changes: 3 additions & 0 deletions uhc-jscript/src/Language/UHC/JScript/Primitives.hs
View file
Expand Up @@ -7,6 +7,9 @@ import UHC.Ptr
data JSPtr a
type JSFunPtr a = FunPtr a

instance JS (JSPtr a)
instance JS (JSString)

type JSString = PackedString
type AnonObj = JSPtr ()

Expand Down
3 changes: 3 additions & 0 deletions uhc-jscript/src/Language/UHC/JScript/Types.hs
View file
Expand Up @@ -4,6 +4,9 @@ module Language.UHC.JScript.Types where

import Control.Monad

class JS a where


class ToJS a b where
toJS :: a -> b

Expand Down
60 changes: 47 additions & 13 deletions uhc-jscript/src/Language/UHC/JScript/W3C/HTML5.hs
View file
Expand Up @@ -7,6 +7,7 @@ module Language.UHC.JScript.W3C.HTML5
, document
, documentWriteln, documentWrite
, documentGetElementById, documentGetElementsByName, documentGetElementsByTagName
, documentCreateElement

, Anchor
, anchorCharset
Expand All @@ -30,7 +31,9 @@ module Language.UHC.JScript.W3C.HTML5
, elementClientWidth
, elementClientHeight
, elementAttributes

, elementSetAttribute
, elementAppendChild

, Attr
, attrValue

Expand All @@ -51,10 +54,14 @@ module Language.UHC.JScript.W3C.HTML5
)
where

import Language.UHC.JScript.Types

import Language.UHC.JScript.Primitives
import Language.UHC.JScript.ECMA.Array
import Language.UHC.JScript.ECMA.String

data Document
data DocumentPtr
type Document = JSPtr DocumentPtr

foreign import jscript "document"
document :: IO Document
Expand Down Expand Up @@ -83,10 +90,20 @@ foreign import jscript "%1.getElementById(%*)"
foreign import jscript "%1.getElementsByName(%*)"
documentGetElementsByName :: Document -> JSString -> IO (NodeList Node)

documentGetElementsByTagName :: Document -> String -> IO (NodeList Node)
documentGetElementsByTagName d = _documentGetElementsByTagName d . stringToJSString

foreign import jscript "%1.getElementsByTagName(%*)"
documentGetElementsByTagName :: Document -> JSString -> IO (NodeList Node)
_documentGetElementsByTagName :: Document -> JSString -> IO (NodeList Node)

documentCreateElement :: String -> IO Node
documentCreateElement elem = _documentCreateElement (stringToJSString elem :: JSString)

foreign import jscript "document.createElement(%*)"
_documentCreateElement :: JSString -> IO Node

data Anchor
data AnchorPtr
type Anchor = JSPtr AnchorPtr

foreign import jscript "%1.charset"
anchorCharset :: Anchor -> JSString
Expand All @@ -112,16 +129,20 @@ foreign import jscript "%1.target"
foreign import jscript "%1.type"
anchorType :: Anchor -> JSString

data Form
data FormPtr
type Form = JSPtr FormPtr

foreign import jscript "%1.elements"
formElements :: Form -> JSArray Element

data Image
data ImagePtr
type Image = JSPtr ImagePtr

data Link
data LinkPtr
type Link = JSPtr LinkPtr

data Element
data ElementPtr
type Element = JSPtr ElementPtr

foreign import jscript "%1.innerHTML"
elementInnerHTML :: Node -> JSString
Expand All @@ -137,24 +158,36 @@ foreign import jscript "%1.clientHeight"

foreign import jscript "%1.attributes"
elementAttributes :: Node -> NamedNodeMap Node

data Node

elementSetAttribute :: Node -> String -> String -> IO ()
elementSetAttribute n k v = _elementSetAttribute n (stringToJSString k :: JSString) (stringToJSString v :: JSString)

foreign import jscript "%1.setAttribute(%*)"
_elementSetAttribute :: Node -> JSString -> JSString -> IO ()

foreign import jscript "%1.appendChild(%2)"
elementAppendChild :: Node -> Node -> IO ()

data NodePtr
type Node = JSPtr NodePtr

foreign import jscript "%1.nodeName"
nodeName :: Node -> JSString

foreign import jscript "%1.nodeType"
nodeType :: Node -> Int

data NodeList x
data NodeListPtr x
type NodeList x = JSPtr (NodeListPtr x)

foreign import jscript "%1.length"
nodeListLength :: NodeList Node -> Int

foreign import jscript "%1[%2]"
nodeListItem :: NodeList Node -> Int -> IO Node

data NamedNodeMap x
data NamedNodeMapPtr x
type NamedNodeMap x = JSPtr (NamedNodeMapPtr x)

foreign import jscript "%1.length"
namedNodeMapLength :: NamedNodeMap Node -> Int
Expand All @@ -171,7 +204,8 @@ foreign import jscript "%1.removeNamedItem(%*)"
foreign import jscript "%1.setNamedItem(%*)"
namedNodeMapSetNamedItem :: NamedNodeMap Node -> Node -> IO Node

data Attr
data AttrPtr
type Attr = JSPtr AttrPtr

foreign import jscript "%1.value"
attrValue :: Attr -> JSString

0 comments on commit 3470947

Please sign in to comment.