Verified Commit 4d8d6003 authored by Camil Staps's avatar Camil Staps 🚀

Make toJS a generic function so that records can be derived

parent bca55057
......@@ -49,7 +49,7 @@ svgns =: "http://www.w3.org/2000/svg"
, svgTrueCoordsY :: !Real
, svgGrabPointX :: !Real
, svgGrabPointY :: !Real
, svgDragTarget :: !Maybe (JSObj DropTarget)
, svgDragTarget :: !Maybe JSObj
}
derive gEq MousePos
......@@ -63,7 +63,7 @@ fromSVGEditor svglet = leafEditorToEditor
, valueFromState = valueFromState
}
where
initUI :: !(JSObj ()) !*JSWorld -> *JSWorld
initUI :: !JSObj !*JSWorld -> *JSWorld
initUI me world
// Set attributes
# world = (me .# "clickCount" .= 0) world
......@@ -139,7 +139,7 @@ newImgTables
, imgUniqIds = 0
}
onNewState :: !(JSVal a) !(SVGEditor s v) !s !*JSWorld -> *JSWorld | JSONEncode{|*|} s
onNewState :: !JSVal !(SVGEditor s v) !s !*JSWorld -> *JSWorld | JSONEncode{|*|} s
onNewState me svglet=:{initView,renderImage} s world
#! (cidJS,world) = me .# "attributes.taskId" .? world
#! (Just cid) = jsValToString cidJS
......@@ -197,7 +197,7 @@ where
_ = abort "Unexpected error in module SVGEditor (local function getImgRootSize of onNewState): size of root image is undetermined."
// update the DOM element with the new SVG content:
updSVG :: ![SVGElt] !(!Real,!Real) !String !(JSVal a) !*JSWorld -> (!JSObj svg,!*JSWorld)
updSVG :: ![SVGElt] !(!Real,!Real) !String !JSVal !*JSWorld -> (!JSObj,!*JSWorld)
updSVG elts (imXSp,imYSp) cid me world
#! imXSp = to2decString imXSp
#! imYSp = to2decString imYSp
......@@ -228,7 +228,7 @@ calcImgFontsSpans new_fonts font_spans world
#! (_, world) = (body `removeChild` svg) world
= (res, world)
where
calcFontSpan :: !(JSVal (JSObject a)) !*(!FontSpans,!*JSWorld) !FontDef -> *(!FontSpans,!*JSWorld)
calcFontSpan :: !JSObj !*(!FontSpans,!*JSWorld) !FontDef -> *(!FontSpans,!*JSWorld)
calcFontSpan elem (font_spans, world) fontdef
#! fontAttrs = [ ("font-family", fontdef.fontfamily)
, ("font-size", toString fontdef.fontysize)
......@@ -245,7 +245,7 @@ where
#! (fd, world) = calcFontDescent elem fontdef.fontysize world
= ('DM'.put fontdef fd font_spans, world)
calcFontDescent :: !(JSVal (JSObject a)) !Real !*JSWorld -> (!Real, !*JSWorld)
calcFontDescent :: !JSObj !Real !*JSWorld -> (!Real, !*JSWorld)
// same heuristic as used below (at function 'genSVGBasicImage'), must be replaced by proper determination of descent of current font
calcFontDescent elem fontysize world
= (fontysize * 0.25,world)
......@@ -264,7 +264,7 @@ calcImgTextsLengths texts text_spans world
#! (_, world) = (body `removeChild` svg) world
= (res, world)
where
calcTextLengths :: !(JSVal (JSObject a)) !FontDef !(Set String) !*(!TextSpans, !*JSWorld) -> *(!TextSpans, !*JSWorld)
calcTextLengths :: !JSObj !FontDef !(Set String) !*(!TextSpans, !*JSWorld) -> *(!TextSpans, !*JSWorld)
calcTextLengths elem fontdef strs (text_spans, world)
#! fontAttrs = [ ("font-family", fontdef.fontfamily)
, ("font-size", toString fontdef.fontysize)
......@@ -285,14 +285,14 @@ where
merge ws` (Just ws) = Just ('DM'.union ws` ws)
merge ws` nothing = Just ws`
calcTextLength :: !(JSVal (JSObject a)) !String !*(!Map String TextSpan, !*JSWorld) -> *(!Map String TextSpan, !*JSWorld)
calcTextLength :: !JSObj !String !*(!Map String TextSpan, !*JSWorld) -> *(!Map String TextSpan, !*JSWorld)
calcTextLength elem str (text_spans, world)
#! world = (elem .# "textContent" .= str) world
#! (ctl, world) = (elem `getComputedTextLength` ()) world
= ('DM'.put str (fromMaybe 0.0 (jsValToReal ctl)) text_spans, world)
// register the event handlers of the img:
registerEventhandlers :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) !(ImgEventhandlers v) !ImgTags !*JSWorld -> *JSWorld | JSONEncode{|*|} s
registerEventhandlers :: !JSVal !(SVGEditor s v) !String !JSObj !(ImgEventhandlers v) !ImgTags !*JSWorld -> *JSWorld | JSONEncode{|*|} s
registerEventhandlers me svglet cid svg es tags world
#! (domEl, world) = me .# "domEl" .? world
#! (svgRoot,world) = domEl .# "firstChild" .? world
......@@ -305,10 +305,10 @@ registerEventhandlers me svglet cid svg es tags world
// register all individual event handlers:
= 'DM'.foldrWithKey (registerEventhandler me svglet svg) world es
where
registerEventhandler :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !ImgTagNo ![ImgEventhandler v] !*JSWorld -> *JSWorld | JSONEncode{|*|} s
registerEventhandler :: !JSVal !(SVGEditor s v) !JSObj !ImgTagNo ![ImgEventhandler v] !*JSWorld -> *JSWorld | JSONEncode{|*|} s
registerEventhandler me svglet svg uniqId es world = foldr (register me svglet svg (mkUniqId cid uniqId)) world es
where
register :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(ImgEventhandler v) !*JSWorld -> *JSWorld | JSONEncode{|*|} s
register :: !JSVal !(SVGEditor s v) !JSObj !String !(ImgEventhandler v) !*JSWorld -> *JSWorld | JSONEncode{|*|} s
register me svglet svg elemId (ImgEventhandlerOnClickAttr {OnClickAttr | local,onclick}) world
= registerNClick me svglet svg elemId onclick local world
register me svglet svg elemId (ImgEventhandlerOnMouseDownAttr {OnMouseDownAttr | local,onmousedown}) world
......@@ -324,14 +324,14 @@ where
register me svglet svg elemId (ImgEventhandlerDraggableAttr {DraggableAttr | draggable}) world
= registerDraggable me svglet svg elemId draggable world
actuallyRegister :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !String !(v -> v) !Bool! *JSWorld -> *JSWorld | JSONEncode{|*|} s
actuallyRegister :: !JSVal !(SVGEditor s v) !JSObj !String !String !(v -> v) !Bool! *JSWorld -> *JSWorld | JSONEncode{|*|} s
actuallyRegister me svglet svg elemId evt sttf local world
#! (elem,world) = (svg .# "getElementById" .$ elemId) world
#! (cb, world) = jsWrapFun (doImageEvent me svglet svg elemId sttf local) world
#! (_, world) = (elem `addEventListener` (evt, cb, True)) world
= world
doImageEvent :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(v -> v) !Bool !{!JSVal arg} !*JSWorld -> *JSWorld | JSONEncode{|*|} s
doImageEvent :: !JSVal !(SVGEditor s v) !JSObj !String !(v -> v) !Bool !{!JSVal} !*JSWorld -> *JSWorld | JSONEncode{|*|} s
doImageEvent me svglet svg elemId sttf local _ world
// Get model & view value
#! (Just view, world) = jsGetCleanReference (me .# "view") world
......@@ -353,14 +353,14 @@ doImageEvent me svglet svg elemId sttf local _ world
// Re-render
= onNewState me svglet model world
registerNClick :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(Int v -> v) !Bool !*JSWorld -> *JSWorld | JSONEncode{|*|} s
registerNClick :: !JSVal !(SVGEditor s v) !JSObj !String !(Int v -> v) !Bool !*JSWorld -> *JSWorld | JSONEncode{|*|} s
registerNClick me svglet svg elemId sttf local world
#! (elem,world) = (svg .# "getElementById" .$ elemId) world
#! (cb, world) = jsWrapFun (mkNClickCB me svglet svg elemId sttf local) world
#! (_, world) = (elem `addEventListener` ("click", cb, False)) world
= world
mkNClickCB :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(Int v -> v) !Bool !{!JSVal arg} !*JSWorld-> *JSWorld | JSONEncode{|*|} s
mkNClickCB :: !JSVal !(SVGEditor s v) !JSObj !String !(Int v -> v) !Bool !{!JSVal} !*JSWorld-> *JSWorld | JSONEncode{|*|} s
mkNClickCB me svglet svg elemId sttf local args world
#! world = if (size args>0) ((args.[0] .# "stopPropagation" .$! ()) world) world
// If another click already registered a timeout, clear that timeout
......@@ -375,7 +375,7 @@ mkNClickCB me svglet svg elemId sttf local args world
#! world = (me .# "clickCount" .= fromMaybe 0 (jsValToInt nc) + 1) world
= world
doNClickEvent :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(Int v -> v) !Bool !{!JSVal arg} !*JSWorld-> *JSWorld | JSONEncode{|*|} s
doNClickEvent :: !JSVal !(SVGEditor s v) !JSObj !String !(Int v -> v) !Bool !{!JSVal} !*JSWorld-> *JSWorld | JSONEncode{|*|} s
doNClickEvent me svglet svg elemId sttf local args world
// Get click count
#! (nc,world) = me .# "clickCount" .? world
......@@ -384,14 +384,14 @@ doNClickEvent me svglet svg elemId sttf local args world
#! nc = fromMaybe 0 (jsValToInt nc)
= doImageEvent me svglet svg elemId (sttf nc) local args world
registerDraggable :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(SVGDragFun v) !*JSWorld -> *JSWorld
registerDraggable :: !JSVal !(SVGEditor s v) !JSObj !String !(SVGDragFun v) !*JSWorld -> *JSWorld
registerDraggable me svglet svg elemId f world
#! (elem, world) = (svg .# "getElementById" .$ elemId) world
#! (cbDown,world) = jsWrapFun (doMouseDragDown me svglet svg f elemId elem) world
#! (_, world) = (elem `addEventListener` ("mousedown", cbDown, True)) world
= world
doMouseDragDown :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !(SVGDragFun v) !String !(JSObj o) !{!JSVal arg} !*JSWorld -> *JSWorld
doMouseDragDown :: !JSVal !(SVGEditor s v) !JSObj !(SVGDragFun v) !String !JSObj !{!JSVal} !*JSWorld -> *JSWorld
doMouseDragDown me svglet svgRoot sttf elemId elem args world
#! (Just ds, world) = jsGetCleanReference (me .# "dragState") world
#! (targetElement,world) = (svgRoot .# "getElementById" .$ elemId) world
......@@ -418,7 +418,7 @@ doMouseDragDown me svglet svgRoot sttf elemId elem args world
#! world = (me .# "dragState" .= jsMakeCleanReference ds) world
= world
doMouseDragMove :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !{!JSObj arg} !*JSWorld -> *JSWorld
doMouseDragMove :: !JSVal !(SVGEditor s v) !JSObj !{!JSVal} !*JSWorld -> *JSWorld
doMouseDragMove me svglet svgRoot args world
#! (Just ds,world) = jsGetCleanReference (me .# "dragState") world
#! evt = args.[0]
......@@ -448,7 +448,7 @@ doMouseDragMove me svglet svgRoot args world
#! world = (me .# "dragState" .= jsMakeCleanReference ds) world
= world
doMouseDragUp :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !(Map String (Set ImageTag)) !{!JSVal arg} !*JSWorld -> *JSWorld
doMouseDragUp :: !JSVal !(SVGEditor s v) !JSObj !(Map String (Set ImageTag)) !{!JSVal} !*JSWorld -> *JSWorld
doMouseDragUp me svglet svgRoot idMap args world
#! evt = args.[0]
#! (Just ds,world) = jsGetCleanReference (me .# "dragState") world
......@@ -479,7 +479,7 @@ doMouseDragUp me svglet svgRoot idMap args world
#! world = (me .# "dragState" .= jsMakeCleanReference ds) world
= world
firstIdentifiableParentId :: !(JSObj a) !*JSWorld -> *(!String, !*JSWorld)
firstIdentifiableParentId :: !JSObj !*JSWorld -> *(!String, !*JSWorld)
firstIdentifiableParentId elem world
#! (idval,world) = elem .# "id" .? world
| jsIsNull idval
......@@ -492,7 +492,7 @@ firstIdentifiableParentId elem world
| otherwise
= (idval, world)
getNewTrueCoords :: !(JSVal a) !(JSObj event) !*JSWorld -> *(!Real, !Real, !*JSWorld)
getNewTrueCoords :: !JSVal !JSObj !*JSWorld -> *(!Real, !Real, !*JSWorld)
getNewTrueCoords me evt world
#! (domEl, world) = me .# "domEl" .? world
#! (svgRoot, world) = domEl .# "firstChild" .? world
......
......@@ -5,7 +5,7 @@ definition module iTasks.UI.Editor
*/
from iTasks.UI.Definition import :: UI, :: UIAttributes, :: UIChange, :: UIAttributeChange, :: TaskId
from iTasks.UI.JS.Interface import :: JSWorld, :: JSObj, :: JSVal, :: JSObject
from iTasks.UI.JS.Interface import :: JSWorld, :: JSVal
from iTasks.Internal.IWorld import :: IWorld
from iTasks.Internal.Generic.Defaults import generic gDefault
......@@ -151,7 +151,7 @@ isCompound :: !EditState -> Bool
//Add client-side initialization to the generation of an initial UI
withClientSideInit ::
!((JSObj ()) *JSWorld -> *JSWorld)
!(JSVal *JSWorld -> *JSWorld)
!(UIAttributes DataPath a *VSt -> *(!MaybeErrorString (!UI, !st), !*VSt))
!UIAttributes !DataPath !a !*VSt ->
*(!MaybeErrorString (!UI, !st), !*VSt)
......
......@@ -148,7 +148,7 @@ isCompound (AnnotatedState _ childSt) = isCompound childSt
isCompound (CompoundState _ _) = True
withClientSideInit ::
!((JSObj ()) *JSWorld -> *JSWorld)
!(JSVal *JSWorld -> *JSWorld)
!(UIAttributes DataPath a *VSt -> *(!MaybeErrorString (!UI, !st), !*VSt))
!UIAttributes !DataPath !a !*VSt -> *(!MaybeErrorString (!UI, !st), !*VSt)
withClientSideInit initUI genUI attr dp val vst=:{VSt|taskId} = case genUI attr dp val vst of
......
definition module iTasks.UI.JS.Interface
import StdGeneric
from StdMaybe import :: Maybe
from StdOverloaded import class toString
:: *JSWorld
:: JSVal a
:: JSObj a :== JSVal (JSObject a)
:: JSFun a :== JSVal (JSFunction a)
:: JSVal
:: JSFun :== JSVal
:: JSObj :== JSVal
:: JSObject a
:: JSFunction a
generic gToJS a :: !a -> JSVal
derive gToJS Int, Bool, String, Real, JSVal, Maybe, ()
derive gToJS PAIR, FIELD of {gfd_name}, RECORD
toJS x :== gToJS{|*|} x
class toJS a :: !a -> JSVal b
instance toJS Int, Bool, String, (JSVal b), (Maybe b) | toJS b
jsMakeCleanReference :: a -> JSVal
jsGetCleanReference :: !JSVal !*JSWorld -> *(!Maybe b, !*JSWorld)
jsMakeCleanReference :: a -> JSVal b
jsGetCleanReference :: !(JSVal a) !*JSWorld -> *(!Maybe b, !*JSWorld)
jsTypeOf :: !JSVal -> JSVal
jsIsUndefined :: !(JSVal a) -> Bool
jsIsNull :: !(JSVal a) -> Bool
jsIsUndefined :: !JSVal -> Bool
jsIsNull :: !JSVal -> Bool
jsValToInt :: !(JSVal a) -> Maybe Int
jsValToBool :: !(JSVal a) -> Maybe Bool
jsValToString :: !(JSVal a) -> Maybe String
jsValToReal :: !(JSVal a) -> Maybe Real
jsValToInt :: !JSVal -> Maybe Int
jsValToBool :: !JSVal -> Maybe Bool
jsValToString :: !JSVal -> Maybe String
jsValToReal :: !JSVal -> Maybe Real
jsValToInt` :: !Int !JSVal -> Int
jsValToBool` :: !Bool !JSVal -> Bool
jsValToString` :: !String !JSVal -> String
jsValToReal` :: !Real !JSVal -> Real
/**
* Access properties of a JavaScript value.
*/
class (.#) infixl 3 attr :: !(JSVal a) !attr -> JSVal b
class (.#) infixl 3 attr :: !JSVal !attr -> JSVal
instance .# String // object access; may contain dots
instance .# Int // array access
(.?) infixl 1 :: !(JSVal a) !*JSWorld -> *(!JSVal r, !*JSWorld)
(.=) infixl 1 :: !(JSObj a) !b !*JSWorld -> *JSWorld | toJS b
(.?) infixl 1 :: !JSVal !*JSWorld -> *(!JSVal, !*JSWorld)
(.=) infixl 1 :: !JSVal !b !*JSWorld -> *JSWorld | gToJS{|*|} b
class toJSArgs a :: !a -> [JSVal a]
instance toJSArgs Int, Bool, String, (JSVal b), (Maybe b) | toJS b, ()
instance toJSArgs (a,b) | toJS a & toJS b
instance toJSArgs (a,b,c) | toJS a & toJS b & toJS c
instance toJSArgs (a,b,c,d) | toJS a & toJS b & toJS c & toJS d
instance toJSArgs (a,b,c,d,e) | toJS a & toJS b & toJS c & toJS d & toJS e
instance toJSArgs (a,b,c,d,e,f) | toJS a & toJS b & toJS c & toJS d & toJS e & toJS f
class toJSArgs a :: !a -> [JSVal]
instance toJSArgs Int, Bool, String, JSVal, (Maybe b) | gToJS{|*|} b, ()
instance toJSArgs (a,b) | gToJS{|*|} a & gToJS{|*|} b
instance toJSArgs (a,b,c) | gToJS{|*|} a & gToJS{|*|} b & gToJS{|*|} c
instance toJSArgs (a,b,c,d) | gToJS{|*|} a & gToJS{|*|} b & gToJS{|*|} c & gToJS{|*|} d
instance toJSArgs (a,b,c,d,e) | gToJS{|*|} a & gToJS{|*|} b & gToJS{|*|} c & gToJS{|*|} d & gToJS{|*|} e
instance toJSArgs (a,b,c,d,e,f) | gToJS{|*|} a & gToJS{|*|} b & gToJS{|*|} c & gToJS{|*|} d & gToJS{|*|} e & gToJS{|*|} f
(.$) infixl 2 :: !(JSFun a) !b !*JSWorld -> *(!JSVal c, !*JSWorld) | toJSArgs b
(.$!) infixl 2 :: !(JSFun a) !b !*JSWorld -> *JSWorld | toJSArgs b
(.$) infixl 2 :: !JSFun !b !*JSWorld -> *(!JSVal, !*JSWorld) | toJSArgs b
(.$!) infixl 2 :: !JSFun !b !*JSWorld -> *JSWorld | toJSArgs b
jsNew :: !String !a !*JSWorld -> *(!JSVal b, !*JSWorld) | toJSArgs a
jsNew :: !String !a !*JSWorld -> *(!JSVal, !*JSWorld) | toJSArgs a
jsEmptyObject :: !*JSWorld -> *(!JSVal a, !*JSWorld)
jsEmptyObject :: !*JSWorld -> *(!JSVal, !*JSWorld)
jsGlobal :: !String -> JSVal a
jsGlobal :: !String -> JSVal
jsNull :== jsGlobal "null"
jsThis :== jsGlobal "this"
jsWindow :== jsGlobal "window"
jsDocument :== jsGlobal "document"
jsWrapFun :: !({!JSVal a} *JSWorld -> *JSWorld) !*JSWorld -> *(!JSFun f, !*JSWorld)
jsWrapFun :: !({!JSVal} *JSWorld -> *JSWorld) !*JSWorld -> *(!JSFun, !*JSWorld)
wrapInitUIFunction :: !((JSObj ()) *JSWorld -> *JSWorld) -> {!JSVal a} -> *JSWorld -> *JSWorld
wrapInitUIFunction :: !(JSVal *JSWorld -> *JSWorld) -> {!JSVal} -> *JSWorld -> *JSWorld
jsDeserializeGraph :: !String !*JSWorld -> *(!.a, !*JSWorld)
......@@ -78,6 +85,6 @@ addCSSFromUrl :: !String !*JSWorld -> *JSWorld
* @param The URL.
* @param An optional callback function for when the script has loaded.
*/
addJSFromUrl :: !String !(Maybe (JSFun a)) !*JSWorld -> *JSWorld
addJSFromUrl :: !String !(Maybe JSFun) !*JSWorld -> *JSWorld
jsTrace :: !a .b -> .b | toString a
implementation module iTasks.UI.JS.Interface
import StdEnv
import StdMaybe
import StdGeneric
import StdOverloadedList
import Data.Maybe
import Text
:: *JSWorld = JSWorld
:: JSVal a
:: JSVal
= JSInt !Int
| JSBool !Bool
| JSString !String
| JSRef !Int // a reference to shared_js_values
| JSCleanRef !Int // a reference to shared_clean_values
| JSVar !String
| JSNull
| JSUndefined
| JSTypeOf !JSVal
| E.b c: JSSel !(JSVal b) !(JSVal c) // b[c]
| E.b: JSSelPath !(JSVal b) !String // b.path1.path2...pathn
| JSObject !{!JSObjectElement}
:: JSObject a :== ()
:: JSFunction a :== ()
| JSSel !JSVal !JSVal // x[y]
| JSSelPath !JSVal !String // x.path1.path2...pathn
instance toString (JSVal a)
| JSRef !Int // a reference to shared_js_values
| JSCleanRef !Int // a reference to shared_clean_values
| JSTempPair !JSVal !JSVal
| JSTempField !String !JSVal
:: JSObjectElement =
{ key :: !String
, val :: !JSVal
}
// TODO optimise this by first computing the size
instance toString JSVal
where
toString v = case v of
JSInt i -> toString i
JSBool b -> if b "true" "false"
JSString s -> "'"+++s+++"'" // TODO escape
JSRef i -> "abc_interpreter.shared_js_values["+++toString i+++"]"
JSCleanRef i -> "abc_interpreter.apply_to_clean_value("+++toString i+++")"
JSVar v -> v
JSNull -> "null"
JSUndefined -> "undefined"
JSTypeOf v -> "typeof "+++toString v
JSObject elems -> foldl (+++) "{" [key+++":"+++toString val+++"," \\ {key,val} <-: elems] +++ "}"
JSSel obj attr -> toString obj+++"["+++toString attr+++"]"
JSSelPath obj path -> toString obj+++"."+++path
jsMakeCleanReference :: a -> JSVal b
JSRef i -> "abc_interpreter.shared_js_values["+++toString i+++"]"
JSCleanRef i -> "abc_interpreter.apply_to_clean_value("+++toString i+++")"
jsMakeCleanReference :: a -> JSVal
jsMakeCleanReference x = share x
jsGetCleanReference :: !(JSVal a) !*JSWorld -> *(!Maybe b, !*JSWorld)
jsGetCleanReference :: !JSVal !*JSWorld -> *(!Maybe b, !*JSWorld)
jsGetCleanReference v w = case eval_js_with_return_value (toString v) of
JSCleanRef i -> (Just (fetch i), w)
_ -> (Nothing, w)
......@@ -52,13 +71,16 @@ where
pop_b 1
}
jsIsUndefined :: !(JSVal a) -> Bool
jsTypeOf :: !JSVal -> JSVal
jsTypeOf v = JSTypeOf v
jsIsUndefined :: !JSVal -> Bool
jsIsUndefined v = v=:JSUndefined
jsIsNull :: !(JSVal a) -> Bool
jsIsNull :: !JSVal -> Bool
jsIsNull v = v=:JSNull
jsValToInt :: !(JSVal a) -> Maybe Int
jsValToInt :: !JSVal -> Maybe Int
jsValToInt v = case v of
JSInt i -> Just i
JSString s -> case toInt s of
......@@ -66,7 +88,7 @@ jsValToInt v = case v of
i -> Just i
_ -> Nothing
jsValToBool :: !(JSVal a) -> Maybe Bool
jsValToBool :: !JSVal -> Maybe Bool
jsValToBool v = case v of
JSBool b -> Just b
JSInt i -> Just (i<>0)
......@@ -76,7 +98,7 @@ jsValToBool v = case v of
_ -> Nothing
_ -> Nothing
jsValToString :: !(JSVal a) -> Maybe String
jsValToString :: !JSVal -> Maybe String
jsValToString v = case v of
JSString s -> Just s
JSInt i -> Just (toString i)
......@@ -84,88 +106,107 @@ jsValToString v = case v of
_ -> Nothing
// TODO add proper support for Reals
jsValToReal :: !(JSVal a) -> Maybe Real
jsValToReal :: !JSVal -> Maybe Real
jsValToReal v = case v of
JSInt i -> Just (toReal i)
JSString s -> Just (toReal s)
_ -> Nothing
instance toJS Int where toJS i = JSInt i
instance toJS Bool where toJS b = JSBool b
instance toJS String where toJS s = JSString s
instance toJS (JSVal b) where toJS val = cast val
jsValToInt` :: !Int !JSVal -> Int
jsValToInt` i v = fromMaybe i (jsValToInt v)
jsValToBool` :: !Bool !JSVal -> Bool
jsValToBool` b v = fromMaybe b (jsValToBool v)
jsValToString` :: !String !JSVal -> String
jsValToString` s v = fromMaybe s (jsValToString v)
jsValToReal` :: !Real !JSVal -> Real
jsValToReal` r v = fromMaybe r (jsValToReal v)
gToJS{|Int|} i = JSInt i
gToJS{|Bool|} b = JSBool b
gToJS{|String|} s = JSString s
gToJS{|Real|} r = JSInt (toInt r) // TODO
gToJS{|JSVal|} v = v
gToJS{|Maybe|} fx v = case v of
Nothing -> JSNull
Just x -> fx x
gToJS{|()|} _ = abort "gToJS{|()|} should not be called!"
instance toJS (Maybe b) | toJS b
gToJS{|PAIR|} fx fy (PAIR x y) = JSTempPair (fx x) (fy y)
gToJS{|FIELD of {gfd_name}|} fx (FIELD x) = JSTempField gfd_name (fx x)
gToJS{|RECORD|} fx (RECORD x) = JSObject {e \\ e <|- collect_elems (fx x)}
where
toJS val = case val of
Just v -> toJS v
Nothing -> JSNull
collect_elems :: !JSVal -> [!JSObjectElement!]
collect_elems (JSTempField k v) = [!{key=k,val=v}!]
collect_elems (JSTempPair a b) = collect_elems a ++| collect_elems b
instance .# String where .# obj path = JSSelPath obj path
instance .# Int where .# arr i = JSSel arr (JSInt i)
(.?) infixl 1 :: !(JSVal a) !*JSWorld -> *(!JSVal r, !*JSWorld)
(.?) infixl 1 :: !JSVal !*JSWorld -> *(!JSVal, !*JSWorld)
(.?) sel w = (eval_js_with_return_value (toString sel), w)
(.=) infixl 1 :: !(JSObj a) !b !*JSWorld -> *JSWorld | toJS b
(.=) infixl 1 :: !JSVal !b !*JSWorld -> *JSWorld | gToJS{|*|} b
(.=) sel v w = case eval_js (toString sel+++"="+++toString (toJS v)) of
True -> w
instance toJSArgs Int where toJSArgs i = [toJS i]
instance toJSArgs Bool where toJSArgs b = [toJS b]
instance toJSArgs String where toJSArgs s = [toJS s]
instance toJSArgs (JSVal b) where toJSArgs v = [cast v]
instance toJSArgs (Maybe b) | toJS b
instance toJSArgs JSVal where toJSArgs v = [cast v]
instance toJSArgs (Maybe b) | gToJS{|*|} b
where
toJSArgs v = case v of
Just v -> [toJS v]
Nothing -> [JSNull]
instance toJSArgs () where toJSArgs _ = []
instance toJSArgs (a,b) | toJS a & toJS b
instance toJSArgs (a,b) | gToJS{|*|} a & gToJS{|*|} b
where toJSArgs (a,b) = [toJS a, toJS b]
instance toJSArgs (a,b,c) | toJS a & toJS b & toJS c
instance toJSArgs (a,b,c) | gToJS{|*|} a & gToJS{|*|} b & gToJS{|*|} c
where toJSArgs (a,b,c) = [toJS a, toJS b, toJS c]
instance toJSArgs (a,b,c,d) | toJS a & toJS b & toJS c & toJS d
instance toJSArgs (a,b,c,d) | gToJS{|*|} a & gToJS{|*|} b & gToJS{|*|} c & gToJS{|*|} d
where toJSArgs (a,b,c,d) = [toJS a, toJS b, toJS c, toJS d]
instance toJSArgs (a,b,c,d,e) | toJS a & toJS b & toJS c & toJS d & toJS e
instance toJSArgs (a,b,c,d,e) | gToJS{|*|} a & gToJS{|*|} b & gToJS{|*|} c & gToJS{|*|} d & gToJS{|*|} e
where toJSArgs (a,b,c,d,e) = [toJS a, toJS b, toJS c, toJS d, toJS e]
instance toJSArgs (a,b,c,d,e,f) | toJS a & toJS b & toJS c & toJS d & toJS e & toJS f