Verified Commit c138a5c5 authored by Camil Staps's avatar Camil Staps 🚀

Strip down iTasks.UI.JS.Interface; initial working version of the wasm interface

parent c7c36e69
module WasmTest
import StdEnv
import Data.Error
from Data.Func import $
import iTasks.Engine
import iTasks.Internal.Client.Serialization
import iTasks.UI.Definition
import iTasks.UI.Editor
import iTasks.UI.JS.Interface
import iTasks.UI.Prompt
import iTasks.WF.Tasks.Interaction
// TODO: remove
import Text.GenJSON
Start w = doTasks task w
//import iTasks.Internal.SDS
//import iTasks.SDS.Sources.System
//
//task = viewSharedInformation "Current date and time" [] currentDateTime
task = updateInformation "test"
[ UpdateUsing (\m -> m) (\_ v -> v) $ leafEditorToEditor
{ LeafEditor
| genUI = withClientSideInit initUI genUI
, onEdit = \_ (_,st) _ vst -> (Ok (NoChange, st), vst)
, onRefresh = \_ new old vst
| new == old -> (Ok (NoChange, new), vst)
| otherwise -> undef // TODO: serialize
, valueFromState = Just
}
]
37
where
initUI :: !(JSObj ()) !*JSWorld -> *JSWorld
initUI comp w
# (jsInitDOMEl,w) = jsWrapFun (initDOMEl comp) w
# w = (comp .# "initDOMEl" .= jsInitDOMEl) w
= w
where
initDOMEl :: !(JSObj ()) !*JSWorld -> (!JSVal a, !*JSWorld)
initDOMEl comp w
# w = (comp .# "domEl.value" .= toJS 37) w
= (jsNull,w)
genUI :: !UIAttributes !DataPath !(EditMode s) !*VSt -> *(!MaybeErrorString (!UI, !s), !*VSt)
genUI attr dp mode vst = case editModeValue mode of
Nothing
-> (Error "cannot be in enter mode", vst)
Just val
# (s,vst) = serialize_in_vst val vst
-> (Ok (ui UITextField, val), vst)
......@@ -20,7 +20,6 @@ from Control.Monad import `b`, class Monad(bind)
import qualified iTasks.Internal.SDS as DSDS
import Data.List
from iTasks.Extensions.SVG.SVGEditor import fromSVGEditor, :: SVGEditor {..}
import iTasks.UI.JS.Encoding
from Data.IntMap.Strict import :: IntMap
import qualified Data.IntMap.Strict as DIS
import Data.Maybe
......@@ -35,9 +34,6 @@ derive gDefault Set
derive JSONEncode Set
derive JSONDecode Set
derive JSEncode ActionState, TClickAction, ClickMeta, TonicImageState, BlueprintRef, TonicFunc, TExpr, TPriority, TLit, TAssoc
derive JSDecode ActionState, TClickAction, ClickMeta, TonicImageState, BlueprintRef, TonicFunc, TExpr, TPriority, TLit, TAssoc
tonic :: Task ()
tonic = tonicDashboard []
......
......@@ -23,7 +23,7 @@ import Text, Text.GenJSON, System.Time
import Data.Maybe, Data.Error
import qualified Data.Map as DM
from iTasks.Extensions.Form.Pikaday import pikadayDateField
//from iTasks.Extensions.Form.Pikaday import pikadayDateField // TODO restore
from iTasks.Internal.Util import tmToDateTime
//* (Local) date and time
......@@ -69,7 +69,9 @@ JSONDecode{|Date|} _ c = (Nothing, c)
gText{|Date|} _ val = [maybe "" toString val]
gEditor{|Date|} = pikadayDateField
// TODO restore
//gEditor{|Date|} = pikadayDateField
derive gEditor Date
gDefault{|Date|} = {Date|day = 1, mon = 1, year = 2017}
derive gEq Date
......
definition module iTasks.Extensions.SVG.SVGEditor
import Graphics.Scalable.Internal.Image`
from iTasks.UI.Editor import :: Editor
import iTasks.UI.JS.Encoding
from iTasks import :: Editor, generic gEq,
generic JSONEncode, generic JSONDecode, :: JSONNode
// An SVGEditor let's you specify an editor as an interactive SVG image (Graphics.Scalable.Image)
:: SVGEditor m v =
......@@ -11,5 +11,4 @@ import iTasks.UI.JS.Encoding
, updModel :: m v -> m // When the view is updated (using the image), the change needs to be merged back into the view
}
fromSVGEditor :: (SVGEditor s v) -> Editor s
| gEq{|*|}, JSONEncode{|*|}, JSONDecode{|*|}, JSEncode{|*|}, JSDecode{|*|} s
fromSVGEditor :: (SVGEditor s v) -> Editor s | gEq{|*|}, JSONEncode{|*|}, JSONDecode{|*|} s
implementation module iTasks.Extensions.SVG.SVGEditor
import Graphics.Scalable.Internal.Image`
import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.JS.Encoding
import iTasks.UI.Definition, iTasks.UI.Editor
import StdEnv
......@@ -23,17 +23,17 @@ CLICK_DELAY :== 225
svgns =: "http://www.w3.org/2000/svg"
//Predefined object methods
(`addEventListener`) obj args :== obj .# "addEventListener" .$ args
(`setAttribute`) obj args :== obj .# "setAttribute" .$ args
(`setAttributeNS`) obj args :== obj .# "setAttributeNS" .$ args
(`createElementNS`) obj args :== obj .# "createElementNS" .$ args
(`appendChild`) obj args :== obj .# "appendChild" .$ args
(`removeChild`) obj args :== obj .# "removeChild" .$ args
(`getComputedTextLength`) obj args :== obj .# "getComputedTextLength" .$ args
(`createSVGPoint`) obj args :== obj .# "createSVGPoint" .$ args
(`getScreenCTM`) obj args :== obj .# "getScreenCTM" .$ args
(`inverse`) obj args :== obj .# "inverse" .$ args
(`matrixTransform`) obj args :== obj .# "matrixTransform" .$ args
//(`addEventListener`) obj args :== obj .# "addEventListener" .$ args
//(`setAttribute`) obj args :== obj .# "setAttribute" .$ args
//(`setAttributeNS`) obj args :== obj .# "setAttributeNS" .$ args
//(`createElementNS`) obj args :== obj .# "createElementNS" .$ args
//(`appendChild`) obj args :== obj .# "appendChild" .$ args
//(`removeChild`) obj args :== obj .# "removeChild" .$ args
//(`getComputedTextLength`) obj args :== obj .# "getComputedTextLength" .$ args
//(`createSVGPoint`) obj args :== obj .# "createSVGPoint" .$ args
//(`getScreenCTM`) obj args :== obj .# "getScreenCTM" .$ args
//(`inverse`) obj args :== obj .# "inverse" .$ args
//(`matrixTransform`) obj args :== obj .# "matrixTransform" .$ args
:: ImageSpanReal :== (!Real, !Real)
......@@ -51,9 +51,8 @@ svgns =: "http://www.w3.org/2000/svg"
derive gEq MousePos
fromSVGEditor :: (SVGEditor s v) -> Editor s
| gEq{|*|}, JSONEncode{|*|}, JSONDecode{|*|}, JSEncode{|*|}, JSDecode{|*|} s
fromSVGEditor svglet = leafEditorToEditor
fromSVGEditor :: (SVGEditor s v) -> Editor s | gEq{|*|}, JSONEncode{|*|}, JSONDecode{|*|} s
fromSVGEditor svglet = undef /* FIXME: restore leafEditorToEditor
{ LeafEditor
| genUI = withClientSideInit initUI genUI
, onEdit = onEdit
......@@ -816,3 +815,4 @@ keepTransformAttrsTogether attr attrs
isTransformAttr :: !SVGAttr -> Bool
isTransformAttr (TransformAttr _) = True
isTransformAttr _ = False
*/
......@@ -2,5 +2,8 @@ definition module iTasks.Internal.Client.Serialization
from Data.Error import :: MaybeError, :: MaybeErrorString
from iTasks.Internal.IWorld import :: IWorld
from iTasks.UI.Editor import :: VSt
serialize_for_client :: f !*IWorld -> *(!MaybeErrorString String, !*IWorld)
serialize_in_vst :: f !*VSt -> *(!String, !*VSt)
......@@ -10,6 +10,7 @@ import ABC.Interpreter
import iTasks.Engine
import iTasks.Internal.IWorld
import iTasks.UI.Editor
serialize_for_client :: f !*IWorld -> *(!MaybeErrorString String, !*IWorld)
serialize_for_client f iworld=:{world,options}
......@@ -20,3 +21,10 @@ serialize_for_client f iworld=:{world,options}
Nothing -> Error "Failed to serialize graph"
Just g -> Ok g
= (graph, iworld)
serialize_in_vst :: f !*VSt -> *(!String, !*VSt)
serialize_in_vst f vst=:{iworld}
# (s,iworld) = serialize_for_client f iworld
= case s of
Error e -> abort (e+++"\n")
Ok s -> (s, {vst & iworld=iworld})
......@@ -19,7 +19,6 @@ from iTasks.SDS.Combinators.Common import sdsFocus, >*|, mapReadWrite, mapR
from StdFunc import const, o
import qualified Data.CircularStack as DCS
from Data.CircularStack import :: CircularStack
from iTasks.Internal.Tonic.AbsSyn import :: ExprId (..)
derive gEq TIMeta, TIType
......
......@@ -7,6 +7,7 @@ import Data.Func
import Data.List
import Data.Maybe
import Data.Either
import Data.Functor
import qualified Data.Map as DM
from Data.Map import instance Functor (Map a)
from Data.Set import :: Set
......@@ -33,7 +34,6 @@ import iTasks.Internal.Tonic.Types
import iTasks.Internal.Tonic.Pretty
import iTasks.UI.Definition
from iTasks.Extensions.SVG.SVGEditor import fromSVGEditor, :: SVGEditor {..}
import iTasks.UI.JS.Encoding
import Text
import StdMisc
......
......@@ -13,7 +13,6 @@ from Data.IntMap.Strict import :: IntMap
import iTasks.Internal.Tonic.Blueprints
import iTasks.Extensions.Admin.TonicAdmin
import iTasks.Extensions.SVG.SVGEditor
import iTasks.UI.JS.Encoding
import iTasks.Extensions.DateTime
import iTasks.Internal.Tonic.AbsSyn
import iTasks.Internal.Tonic.Types
......
......@@ -6,7 +6,6 @@ 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.Encoding import generic JSDecode
from iTasks.Internal.IWorld import :: IWorld
from iTasks.Internal.Generic.Defaults import generic gDefault
......@@ -55,12 +54,12 @@ from Control.GenBimap import generic bimap, :: Bimap
, valueFromState :: !st -> Maybe a
}
leafEditorToEditor :: !(LeafEditor edit st a) -> Editor a | JSDecode{|*|} edit & JSONEncode{|*|}, JSONDecode{|*|} st
leafEditorToEditor :: !(LeafEditor edit st a) -> Editor a | JSONEncode{|*|}, JSONDecode{|*|} st
//Version without overloading, for use in generic case
//The first two argument should be JSONEncode{|*|} and JSONDecode{|*|} which cannot be used by overloading within generic functions
leafEditorToEditor_ :: !(Bool st -> [JSONNode]) !(Bool [JSONNode] -> (!Maybe st, ![JSONNode])) !(LeafEditor edit st a)
-> Editor a | JSDecode{|*|} edit
-> Editor a
/*
* Definition of a compound editor using an additional typed state, next to the children's states.
......
implementation module iTasks.UI.Editor
import StdBool, StdMisc, StdList, StdTuple
import StdEnv
import Data.Maybe, Data.Functor, Data.Tuple, Data.Func, Data.Error
import iTasks.Internal.IWorld
import iTasks.Internal.Client.Serialization
import iTasks.UI.Definition, iTasks.WF.Definition, iTasks.UI.JS.Encoding
import iTasks.UI.Definition, iTasks.WF.Definition, iTasks.UI.JS.Interface
import qualified Data.Map as DM
import Text, Text.GenJSON
import Data.GenEq
......@@ -13,20 +13,20 @@ derive JSONEncode EditState, LeafState, EditMode
derive JSONDecode EditState, LeafState, EditMode
derive gEq EditState, LeafState
leafEditorToEditor :: !(LeafEditor edit st a) -> Editor a | JSDecode{|*|} edit & JSONEncode{|*|}, JSONDecode{|*|} st
leafEditorToEditor :: !(LeafEditor edit st a) -> Editor a | JSONEncode{|*|}, JSONDecode{|*|} st
leafEditorToEditor leafEditor = leafEditorToEditor_ JSONEncode{|*|} JSONDecode{|*|} leafEditor
leafEditorToEditor_ :: !(Bool st -> [JSONNode]) !(Bool [JSONNode] -> (!Maybe st, ![JSONNode])) !(LeafEditor edit st a)
-> Editor a | JSDecode{|*|} edit
-> Editor a
leafEditorToEditor_ jsonEncode jsonDecode leafEditor =
{Editor| genUI = genUI, onEdit = onEdit, onRefresh = onRefresh, valueFromState = valueFromState}
where
genUI attr dp val vst = mapRes False $ leafEditor.LeafEditor.genUI attr dp val vst
onEdit dp (tp, jsone) (LeafState {state}) vst = case fromJSON` state of
Just st = case decodeOnServer jsone of
Just st = undef /*case decodeOnServer jsone of // FIXME: decodeOnServer
Just e = mapRes True $ leafEditor.LeafEditor.onEdit dp (tp, e) st vst
_ = (Error ("Invalid edit event for leaf editor: " +++ toString jsone), vst)
_ = (Error ("Invalid edit event for leaf editor: " +++ toString jsone), vst) */
_ = (Error "Corrupt internal state in leaf editor", vst)
onEdit _ _ _ vst = (Error "Corrupt editor state in leaf editor", vst)
......@@ -152,7 +152,7 @@ withClientSideInit ::
!(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
(Ok (UI type attr items,mask),vst=:{VSt|iworld}) -> case serialize_for_client initUI iworld of
(Ok (UI type attr items,mask),vst=:{VSt|iworld}) -> case serialize_for_client initUI` iworld of
(Ok initUI,iworld)
# extraAttr = 'DM'.fromList
[("taskId", JSONString taskId)
......@@ -163,3 +163,6 @@ withClientSideInit initUI genUI attr dp val vst=:{VSt|taskId} = case genUI attr
(Error e,iworld)
-> (Error e, {VSt|vst & iworld = iworld})
e -> e
where
initUI` :: Int *JSWorld -> *JSWorld
initUI` ref_to_js_elem world = initUI (referenceToJS ref_to_js_elem) world
......@@ -5,7 +5,6 @@ definition module iTasks.UI.Editor.Controls
*/
from iTasks.UI.Editor import :: Editor
from iTasks.UI.Definition import :: UIAttributes, :: UIType
from iTasks.UI.JS.Encoding import generic JSDecode
from Data.Maybe import :: Maybe
from Data.Map import :: Map
from Text.HTML import :: HtmlTag
......@@ -126,7 +125,7 @@ withConstantChoices :: !choices !(Editor (!choices, ![Int])) -> Editor [Int]
fieldComponent
:: !UIType !(Maybe a) !(UIAttributes a -> Bool) -> Editor a
| JSONDecode{|*|}, JSONEncode{|*|}, gEq{|*|} a & JSDecode{|*|} a
| JSONDecode{|*|}, JSONEncode{|*|}, gEq{|*|} a
//Convenient types for describing the values of grids and trees
:: ChoiceText =
......
......@@ -122,7 +122,7 @@ where
//Field like components for which simply knowing the UI type is sufficient
fieldComponent
:: !UIType !(Maybe a) !(UIAttributes a -> Bool) -> Editor a
| JSONDecode{|*|}, JSONEncode{|*|}, gEq{|*|} a & JSDecode{|*|} a
| JSONDecode{|*|}, JSONEncode{|*|}, gEq{|*|} a
fieldComponent type mbEditModeInitValue isValid = disableOnView $ editorWithJSONEncode (leafEditorToEditor o leafEditor)
where
leafEditor toJSON =
......
definition module iTasks.UI.JS.Encoding
/**
* This module provides encoding/decoding functions for communicating values efficiently
* between an itasks server application and its client (webbrowser).
* It uses an encoding of Clean values as JSON that can be decoded natively in javascript
*/
import iTasks.UI.JS.Interface
import StdGeneric
from Text.GenJSON import :: JSONNode (..)
from StdList import !!
from StdMaybe import :: Maybe
from StdInt import bitand, <<
from StdClass import class IncDec(inc)
//Sending values server -> client
encodeOnServer :: !a -> JSONNode | JSEncode{|*|} a //Don't specialize JSEncode, it will break decoding
decodeOnClient :: !(JSVal a) !*JSWorld -> *(!a, !*JSWorld)
//Sending values client -> server
encodeOnClient :: !a *JSWorld -> (!JSVal a, !*JSWorld)
decodeOnServer :: !JSONNode -> (Maybe a) | JSDecode{|*|} a //Don't specialize JSDecode, it will break on the fixed encoding
generic JSEncode t :: !t -> [JSONNode]
derive JSEncode Int, Real, Char, Bool, String, UNIT, [],
(), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,), {}, {!}, (->),
EITHER, OBJECT, Maybe, JSONNode
JSEncode{|CONS of {gcd_name,gcd_index,gcd_strict_arguments}|} fx (CONS x)
= [JSONArray [JSONInt gcd_index, JSONString gcd_name :
[if (gcd_strict_arguments bitand (1 << i) == 0)
arg
(case arg of JSONArray [arr] -> arr; arr -> arr)
\\ arg <- fx x & i <- [0..]]]]
JSEncode{|RECORD of {grd_name}|} fx (RECORD x) = [JSONArray [JSONInt 0, JSONString ("_" +++ grd_name) : fx x]]
JSEncode{|FIELD of {gfd_cons,gfd_index}|} fx (FIELD x)
| gfd_cons.grd_strict_fields bitand (1 << gfd_index) == 0
= fx x
= case fx x of
[JSONArray [arr]] -> [arr]
arr -> arr
JSEncode{|PAIR|} fx fy (PAIR x y) = fx x ++ fy y
where
(++) infixr 5::![.a] !u:[.a] -> u:[.a]
(++) [hd:tl] list = [hd:tl ++ list]
(++) nil list = list
generic JSDecode t :: ![JSONNode] -> (!Maybe t,![JSONNode])
derive JSDecode Int, Real, Char, Bool, String, UNIT, EITHER, CONS of {gcd_name}, OBJECT, [], (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,), {}, {!}, Maybe, JSONNode
JSDecode{|PAIR|} fx fy l = d1 fy (fx l) l
where
d1 :: !([JSONNode] -> (!Maybe b, ![JSONNode])) !(!Maybe a, ![JSONNode]) ![JSONNode]
-> (!Maybe (PAIR a b), ![JSONNode])
d1 fy (Just x,xs) l = d2 x (fy xs) l
d1 _ (Nothing, _) l = (Nothing, l)
d2 :: !a !(!Maybe b, ![JSONNode]) ![JSONNode] -> (!Maybe (PAIR a b), ![JSONNode])
d2 x (Just y, ys) l = (Just (PAIR x y), ys)
d2 x (Nothing, _) l = (Nothing, l)
JSDecode{|RECORD|} fx l=:[obj=:JSONObject fields : xs] = d (fx [obj]) xs l
where
d :: !(Maybe a, b) ![JSONNode] ![JSONNode] -> (!Maybe (RECORD a), ![JSONNode])
d (Just x, _) xs l = (Just (RECORD x),xs)
d (Nothing, _) xs l = (Nothing, l)
JSDecode{|RECORD|} fx l=:[obj=:JSONArray fields : xs] = d (fx [obj]) xs l
where
d :: !(Maybe a, b) ![JSONNode] ![JSONNode] -> (!Maybe (RECORD a), ![JSONNode])
d (Just x, _) xs l = (Just (RECORD x),xs)
d (Nothing, _) xs l = (Nothing, l)
JSDecode{|RECORD|} fx l = (Nothing,l)
JSDecode{|FIELD of {gfd_name}|} fx l =:[JSONObject fields]
#! field = findField gfd_name fields
= case fx field of
(Just x, _) = (Just (FIELD x), l)
(_, _) = (Nothing, l)
where
findField :: !String ![(!String, !JSONNode)] -> [JSONNode]
findField match [(l,x):xs]
| l == match = [x]
| otherwise = findField match xs
findField match [] = []
JSDecode{|FIELD of {gfd_index}|} fx l =:[JSONArray fields]
#! field = fields !! gfd_index
= case fx [field] of
(Just x, _) = (Just (FIELD x), l)
(_, _) = (Nothing, l)
JSDecode{|FIELD|} fx l = (Nothing, l)
implementation module iTasks.UI.JS.Encoding
import iTasks.UI.JS.Interface
import Text.GenJSON
import Text.Encodings.Base64
import StdMisc, StdArray, StdTuple, StdList
import dynamic_string
/*
When we encode values on the server we directly encode to the representation used by the Sapl run-time such that
additional decoding on the client is not longer necessary.
*/
/*
* Format of sapl representation:
ADTs:
[<index of cons>,<name of cons>, <args ...>]
Records (same as ADT, record type with an underscore prepended is used as cons name):
[0, '_' + <name of type>, <args ...>]
Primitives:
[<boxed primitive>]
Thunks:
[<function ref>,[<args ...>]]
*/
encodeOnServer :: !a -> JSONNode | JSEncode{|*|} a
encodeOnServer x = case JSEncode{|*|} x of
[node] = node
_ = JSONError
decodeOnClient :: !(JSVal a) !*JSWorld -> *(!a, !*JSWorld)
decodeOnClient val world = undef //Implemented in iTasks/Sapl FFI
generic JSEncode t :: !t -> [JSONNode]
JSEncode{|Int|} x = [JSONArray [JSONInt x]]
JSEncode{|Real|} x = [JSONArray [JSONReal x]]
JSEncode{|Char|} x = [JSONArray [JSONString {x}]]
JSEncode{|Bool|} x = [JSONArray [JSONBool x]]
JSEncode{|String|} x = [JSONArray [JSONString x]]
JSEncode{|UNIT|} (UNIT) = []
JSEncode{|PAIR|} fx fy (PAIR x y) = fx x ++ fy y
where
(++) infixr 5::![.a] !u:[.a] -> u:[.a]
(++) [hd:tl] list = [hd:tl ++ list]
(++) nil list = list
JSEncode{|EITHER|} fx fy (LEFT x) = fx x
JSEncode{|EITHER|} fx fy (RIGHT y) = fy y
JSEncode{|OBJECT|} fx (OBJECT x) = fx x
JSEncode{|CONS of {gcd_name,gcd_index,gcd_strict_arguments}|} fx (CONS x)
= [JSONArray [JSONInt gcd_index, JSONString gcd_name :
[if (gcd_strict_arguments bitand (1 << i) == 0)
arg
(case arg of JSONArray [arr] -> arr; arr -> arr)
\\ arg <- fx x & i <- [0..]]]]
JSEncode{|RECORD of {grd_name}|} fx (RECORD x) = [JSONArray [JSONInt 0, JSONString ("_" +++ grd_name) : fx x]]
JSEncode{|FIELD of {gfd_cons,gfd_index}|} fx (FIELD x)
| gfd_cons.grd_strict_fields bitand (1 << gfd_index) == 0
= fx x
= case fx x of
[JSONArray [arr]] -> [arr]
arr -> arr
JSEncode{|{}|} fx x = [JSONArray (flatten [fx e \\ e <-: x])]
JSEncode{|{!}|} fx x = [JSONArray (flatten [fx e \\ e <-: x])]
JSEncode{|(->)|} fx fy x = [JSONString "error"]
JSEncode{|JSONNode|} node = [node]
derive JSEncode [],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,), Maybe
encodeOnClient :: !a *JSWorld -> (!JSVal a, !*JSWorld)
encodeOnClient val world = undef //Implemented in iTasks/Sapl FFI
decodeOnServer :: !JSONNode -> (Maybe a) | JSDecode{|*|} a
decodeOnServer node = fst (JSDecode{|*|} [node])
//Currently, this is just a copy of JSONDecode without the special treatment of maybe values
//but the encoding could be further optimized for its use in editlets
generic JSDecode t :: ![JSONNode] -> (!Maybe t, ![JSONNode])
JSDecode{|Int|} [JSONInt i:xs] = (Just i, xs)
JSDecode{|Int|} l = (Nothing, l)
JSDecode{|Real|} [JSONReal r:xs] = (Just r, xs)
JSDecode{|Real|} [JSONInt i:xs] = (Just (toReal i), xs)
JSDecode{|Real|} l = (Nothing, l)
JSDecode{|Char|} l=:[JSONString s:xs]
| size s == 1 = (Just s.[0],xs)
= (Nothing, l)
JSDecode{|Char|} l = (Nothing, l)
JSDecode{|Bool|} [JSONBool b:xs] = (Just b,xs)
JSDecode{|Bool|} l = (Nothing, l)
JSDecode{|String|} [JSONString s:xs] = (Just s, xs)
JSDecode{|String|} l = (Nothing, l)
JSDecode{|UNIT|} l = (Just UNIT, l)
JSDecode{|PAIR|} fx fy l = d1 fy (fx l) l
where
d1 :: !([JSONNode] -> (!Maybe b, ![JSONNode])) !(!Maybe a, ![JSONNode]) ![JSONNode]
-> (!Maybe (PAIR a b), ![JSONNode])
d1 fy (Just x,xs) l = d2 x (fy xs) l
d1 _ (Nothing, _) l = (Nothing, l)
d2 :: !a !(!Maybe b, ![JSONNode]) ![JSONNode] -> (!Maybe (PAIR a b), ![JSONNode])
d2 x (Just y, ys) l = (Just (PAIR x y), ys)
d2 x (Nothing, _) l = (Nothing, l)
JSDecode{|EITHER|} fx fy l = case fx l of
(Just x, xs) = (Just (LEFT x),xs)
(Nothing, xs) = case fy l of
(Just y, ys) = (Just (RIGHT y),ys)
(Nothing, ys) = (Nothing, l)
JSDecode{|OBJECT|} fx l = case fx l of
(Just x, xs) = (Just (OBJECT x),xs)
_ = (Nothing, l)
JSDecode{|CONS of {gcd_name}|} fx l=:[JSONArray [JSONString name:fields] :xs]
| name == gcd_name = case fx fields of
(Just x, _) = (Just (CONS x), xs)
_ = (Nothing, l)
| otherwise = (Nothing, l)
JSDecode{|CONS|} fx l = (Nothing, l)
JSDecode{|RECORD|} fx l=:[obj=:JSONObject fields : xs] = d (fx [obj]) xs l
where
d :: !(!Maybe a, b) ![JSONNode] ![JSONNode] -> (!Maybe (RECORD a), ![JSONNode])
d (Just x, _) xs l = (Just (RECORD x),xs)
d (Nothing, _) xs l = (Nothing, l)
JSDecode{|RECORD|} fx l=:[obj=:JSONArray fields : xs] = d (fx [obj]) xs l
where
d :: !(!Maybe a, b) ![JSONNode] ![JSONNode] -> (!Maybe (RECORD a), ![JSONNode])
d (Just x, _) xs l = (Just (RECORD x),xs)
d (Nothing, _) xs l = (Nothing, l)
JSDecode{|RECORD|} fx l = (Nothing,l)
JSDecode{|FIELD of {gfd_name}|} fx l =:[JSONObject fields]
#! field = findField gfd_name fields
= case fx field of
(Just x, _) = (Just (FIELD x), l)