implementation module iTasks.Framework.ClientInterface import StdEnv, Data.Void, Data.Maybe, Text :: JSWorld = JSWorld :: JSPtr a = JSPtr :: JSWindow = JSWindow :: JSDocument = JSDocument :: JSFunction a = JSFunction jsNull :: (JSPtr a) jsNull = undef jsWindow :: (JSPtr JSWindow) jsWindow = undef jsEmptyObject :: !*JSWorld -> *(!JSPtr a, !*JSWorld) jsEmptyObject world = undef jsNewObject :: !(JSPtr (JSFunction f)) !*JSWorld -> *(!JSPtr a, !*JSWorld) jsNewObject constructor world = undef jsGetObjectAttr :: !String !(JSPtr a) !*JSWorld -> *(!b, !*JSWorld) jsGetObjectAttr attr obj world = undef jsGetObjectEl :: !Int !(JSPtr a) !*JSWorld -> *(!b, !*JSWorld) jsGetObjectEl index obj world = undef jsSetObjectAttr :: !String !b !(JSPtr a) !*JSWorld -> *JSWorld jsSetObjectAttr attr value obj world = undef jsSetObjectEl :: !Int !b !(JSPtr a) !*JSWorld -> *JSWorld jsSetObjectEl index value obj world = undef jsApply :: !(JSPtr (JSFunction f)) !(JSPtr a) !(JSPtr b) !*JSWorld -> *(!c, !*JSWorld) jsApply fun scope args world = undef jsThis :: !*JSWorld -> *(!JSPtr a, !*JSWorld) jsThis world = undef jsTypeof :: !a !*JSWorld -> *(!String, !*JSWorld) jsTypeof obj world = undef jsWrapFun :: !f !*JSWorld -> *(!JSPtr (JSFunction f), !*JSWorld) jsWrapFun fun world = undef toJSPtr :: !a !*JSWorld -> *(!JSPtr b, !*JSWorld) toJSPtr val world = undef //UTIL jsDocument :: !*JSWorld -> *(!JSPtr JSDocument, !*JSWorld) jsDocument world = jsGetObjectAttr "document" jsWindow world newJSArray :: !*JSWorld -> *(!JSPtr [a], !*JSWorld) newJSArray world # (constructor,world) = jsGetObjectAttr "Array" (jsWindow) world = jsNewObject constructor world jsArrayPush :: !a (!JSPtr [a]) !*JSWorld -> *(!JSPtr [a], !*JSWorld) jsArrayPush x arr world = callObjectMethod "push" [x] arr world jsArrayReverse :: (!JSPtr [a]) !*JSWorld -> *(!JSPtr [a], !*JSWorld) jsArrayReverse arr world = callObjectMethod "reverse" [] arr world toJSArray :: ![a] !*JSWorld -> *(!JSPtr [a], !*JSWorld) toJSArray xs world # (arr, world) = newJSArray world # world = foldl (op arr) world (zip2 [0..] xs) = (arr, world) where op arr world (i, arg) = jsSetObjectEl i arg arr world jsIsUndefined :: !a !*JSWorld -> *(!Bool, !*JSWorld) jsIsUndefined obj world # (type,world) = jsTypeof obj world = (type == "undefined",world) getDomElement :: !DomElementId !*JSWorld -> *(!JSPtr a, !*JSWorld) getDomElement elemId world # (document,world) = jsDocument world = callObjectMethod "getElementById" [elemId] document world getDomAttr :: !DomElementId !String !*JSWorld -> *(!a, !*JSWorld) getDomAttr elemId attr world # (elem,world) = getDomElement elemId world = jsGetObjectAttr attr elem world setDomAttr :: !DomElementId !String !b !*JSWorld -> *JSWorld setDomAttr elemId attr value world # (elem,world) = getDomElement elemId world = jsSetObjectAttr attr value elem world findObject :: !String !*JSWorld -> *(!JSPtr a, !*JSWorld) findObject query world # (obj,world) = jsGetObjectAttr attr jsWindow world //deref first attr separate to make the typechecker happy = case attrs of [] = (obj,world) = foldl op (obj,world) attrs where [attr:attrs] = split "." query op (obj,world) attr = jsGetObjectAttr attr obj world callObjectMethod :: !String ![b] !(JSPtr a) !*JSWorld -> *(!c, !*JSWorld) callObjectMethod method args obj world # (fun,world) = jsGetObjectAttr method obj world # (arr,world) = toJSArray args world = jsApply fun obj arr world addJSFromUrl :: !String !(Maybe (JSPtr (JSFunction a))) *JSWorld -> *JSWorld addJSFromUrl url mbCallback world # (document,world) = jsDocument world //Create script tag # (script,world) = callObjectMethod "createElement" ["script"] document world # world = jsSetObjectAttr "src" url script world # world = jsSetObjectAttr "type" "text/javascript" script world # world = case mbCallback of Nothing = world Just callback = jsSetObjectAttr "onload" callback script world //Inject into the document head # (head,world) = callObjectMethod "getElementsByTagName" ["head"] document world # (head,world) = jsGetObjectEl 0 head world # (_,world) = callObjectMethod "appendChild" [script] head world = world jsTrace :: a *JSWorld -> *JSWorld jsTrace val world # (console,world) = findObject "console" world # (_,world) = callObjectMethod "log" [val] console world = world