From ea3770fe985c48565a203b78a914ef74dc166a46 Mon Sep 17 00:00:00 2001 From: Quil Date: Sun, 6 Feb 2022 11:59:52 +0100 Subject: [PATCH] Serialisation/parsing of custom structures in JSON (#60) This patch adds traits for types to describe how they can be serialised and reified when using a JSON encoding. The approach here favours control over reification to avoid issues with arbitrary code being able to construct capability-bearing types by simply stating their names; here the person describing the JSON types must provide a mapping for them that describes the lowering and the reification passes. In order to support custom serialisation, the package forks JSON into standard JSON (`json` object), and "extended" JSON (`extended-json`) object. The extended JSON object stores non-standard types as the dictionary `{"@type": "unique-tag", "value": ... }`, it then uses the mapping contained in the extended JSON type to both serialise and reify these types. Moving the extended JSON portion to a separate type avoids issues with JSON payloads that may use this convention in a different way, and also discourages a single object with all mappings. Example usage: ``` let My-domain = #json-serialisation bare | tag: "project" type: #project | tag: "package" type: #pkg; let Json = #extended-json with-serialisation: My-domain; assert (Json parse: (Json serialise: new project("title", new pkg("name", "filename")))) === new project("title", new pkg("name", "filename")); ``` --- source/vm/primitives/location.ts | 33 +++ .../source/collection/equality.crochet | 15 +- .../source/traits/conversion.crochet | 8 + stdlib/crochet.language.json/crochet.json | 9 +- stdlib/crochet.language.json/native/json.ts | 228 +++++++++++++++--- .../source/capabilities.crochet | 7 + .../source/custom-serialisation.crochet | 51 ++++ .../crochet.language.json/source/json.crochet | 160 ++++-------- .../source/serialisation.crochet | 93 +++++++ .../source/trait-instances.crochet | 41 ++++ .../source/types.crochet | 45 ++++ 11 files changed, 549 insertions(+), 141 deletions(-) create mode 100644 stdlib/crochet.language.json/source/capabilities.crochet create mode 100644 stdlib/crochet.language.json/source/custom-serialisation.crochet create mode 100644 stdlib/crochet.language.json/source/serialisation.crochet create mode 100644 stdlib/crochet.language.json/source/trait-instances.crochet create mode 100644 stdlib/crochet.language.json/source/types.crochet diff --git a/source/vm/primitives/location.ts b/source/vm/primitives/location.ts index 811b3004..2c3e6758 100644 --- a/source/vm/primitives/location.ts +++ b/source/vm/primitives/location.ts @@ -2,6 +2,7 @@ import { inspect } from "util"; import { CrochetActivation, NativeActivation } from ".."; import * as IR from "../../ir"; import { unreachable } from "../../utils/utils"; +import * as im from "immutable"; import { Activation, ActivationTag, @@ -192,6 +193,8 @@ export function simple_value(x: CrochetValue): string { const repr = x.payload instanceof CrochetValue ? simple_value(x.payload) + : im.isImmutable(x.payload) + ? immutable_repr(x.payload) : `native ${inspect(x.payload, false, 3)}`; return `(${repr})`; } @@ -216,6 +219,36 @@ export function simple_value(x: CrochetValue): string { } } +function immutable_repr(x: unknown) { + if (im.isList(x)) { + return `[\n${block( + 2, + x + .toArray() + .map((x) => simple_value(x as any)) + .join(", ") + )}\n]`; + } else if (im.isMap(x)) { + if (x.size === 0) { + return "[->]"; + } + const pairs = [...x.entries()].map( + ([k, v]) => `${simple_value(k as any)} -> ${simple_value(v as any)}` + ); + return `[\n${block(2, pairs.join(",\n"))}\n]`; + } else if (im.isSet(x)) { + return `[\n${block( + 2, + x + .toArray() + .map((x) => simple_value(x as any)) + .join(", ") + )}\n]`; + } else { + return ``; + } +} + export function simple_op(op: IR.Op, index: number | null): string { const entries = Object.entries(op) .filter( diff --git a/stdlib/crochet.core/source/collection/equality.crochet b/stdlib/crochet.core/source/collection/equality.crochet index efbd4ca2..0e08288c 100644 --- a/stdlib/crochet.core/source/collection/equality.crochet +++ b/stdlib/crochet.core/source/collection/equality.crochet @@ -25,7 +25,8 @@ implement equality for set; /// True if two sets have equal values. command set === (That is set) do - foreign set.equals(self.box, That.box); + (self count =:= That count) + and (self values all: (That contains: _)); test assert (#set from: [1, 2, 3]) === (#set from: [1, 2, 3]); assert (#set from: [3, 2, 1]) === (#set from: [3, 2, 1]); @@ -38,10 +39,20 @@ implement equality for map; /// True if two maps have equal values. command map === (That is map) do - foreign map.equals(self.box, That.box); + (self count =:= That count) + and (self entries all: { Pair in + condition + when That contains-key: Pair key => (That at: Pair key) === Pair value; + otherwise => false; + end + }); test assert #map empty === #map empty; assert (#map empty | at: 1 put: 2 | at: 3 put: 4) === (#map empty | at: 3 put: 4 | at: 1 put: 2); assert not ((#map empty | at: 1 put: 2 | at: 3 put: 4) === (#map empty | at: 1 put: 2)); assert not ((#map empty | at: 1 put: 2) === (#map empty | at: 3 put: 4)); + + let A = #map from: [a -> [1.0, 2.0], b -> #map from: [c -> 3.0]]; + let B = #map from: [a -> [1.0, 2.0], b -> #map from: [c -> 3.0]]; + assert A === B; end \ No newline at end of file diff --git a/stdlib/crochet.core/source/traits/conversion.crochet b/stdlib/crochet.core/source/traits/conversion.crochet index e89de23b..4c829255 100644 --- a/stdlib/crochet.core/source/traits/conversion.crochet +++ b/stdlib/crochet.core/source/traits/conversion.crochet @@ -69,6 +69,10 @@ test assert (#integer try-parse: "nope") is error; end +command #integer parse: (X is text) = + #integer try-parse: X + | value-or-panic: "invalid integer"; + /// Attempts to parse a piece of text as a floating point number. The /// grammar is similar to the JavaScript's floating point grammar. command #float-64bit try-parse: (X is text) -> result do @@ -85,6 +89,10 @@ test assert (#float-64bit try-parse: "nope") is error; end +command #float-64bit parse: (X is text) = + #float-64bit try-parse: X + | value-or-panic: "invalid float"; + /// Converts an integer to a piece of trusted text. command integer to-text = foreign integer.to-text(self); diff --git a/stdlib/crochet.language.json/crochet.json b/stdlib/crochet.language.json/crochet.json index 14db9fb6..2a141339 100644 --- a/stdlib/crochet.language.json/crochet.json +++ b/stdlib/crochet.language.json/crochet.json @@ -4,7 +4,14 @@ "stability": "experimental", "native_sources": ["native/json.js"], "dependencies": ["crochet.core"], - "sources": ["source/json.crochet"], + "sources": [ + "source/capabilities.crochet", + "source/json.crochet", + "source/types.crochet", + "source/custom-serialisation.crochet", + "source/trait-instances.crochet", + "source/serialisation.crochet" + ], "capabilities": { "requires": [], "provides": [] diff --git a/stdlib/crochet.language.json/native/json.ts b/stdlib/crochet.language.json/native/json.ts index 068d9e68..8f28018c 100644 --- a/stdlib/crochet.language.json/native/json.ts +++ b/stdlib/crochet.language.json/native/json.ts @@ -1,49 +1,221 @@ import type { ForeignInterface, CrochetValue } from "../../../build/crochet"; export default (ffi: ForeignInterface) => { - function to_json(x: unknown): unknown { - if (typeof x === "bigint") { - return Number(x); - } else if (Array.isArray(x)) { - return x.map(to_json); - } else if (x instanceof Map) { - const value = Object.create(null); - for (const [k, v] of x.entries()) { - value[k] = to_json(v); - } - return value; - } else { - return x; + abstract class Json { + abstract toJSON(): any; + } + + class JsonNull extends Json { + toJSON() { + return null; + } + } + + class JsonNumber extends Json { + constructor(readonly value: number) { + super(); + } + + toJSON() { + return this.value; + } + } + + class JsonText extends Json { + constructor(readonly value: string) { + super(); + } + + toJSON() { + return this.value; + } + } + + class JsonBoolean extends Json { + constructor(readonly value: boolean) { + super(); + } + + toJSON() { + return this.value; } } - function from_json(x: unknown): unknown { - if (Array.isArray(x)) { - return x.map((a) => from_json(a)); - } else if (typeof x === "object" && x != null) { - const result = new Map(); - for (const [k, v] of Object.entries(x)) { - result.set(k, from_json(v)); + class JsonList extends Json { + constructor(readonly values: Json[]) { + super(); + } + + toJSON() { + return this.values; + } + } + + class JsonRecord extends Json { + constructor(readonly entries: [string, Json][]) { + super(); + } + + toJSON() { + const result = Object.create(null); + for (const [k, v] of this.entries) { + result[k] = v; } return result; - } else { - return x; } } + class JsonTyped extends Json { + constructor(readonly tag: string, readonly value: Json) { + super(); + } + + toJSON() { + return { + "@type": this.tag, + value: this.value, + }; + } + } + + const _null = new JsonNull(); + + function make_reify(extended: boolean) { + function reify_json(key: string, value: unknown) { + if (value instanceof Json) { + return value; + } else if (value == null) { + return _null; + } else if (typeof value === "number") { + return new JsonNumber(value); + } else if (typeof value === "boolean") { + return new JsonBoolean(value); + } else if (typeof value === "string") { + return new JsonText(value); + } else if (Array.isArray(value)) { + return new JsonList(value); + } else if (extended && "@type" in (value as any)) { + const v = value as { "@type": any; value: Json }; + if (!(v["@type"] instanceof JsonText)) { + throw ffi.panic("invalid-type", "expected text"); + } + if (!("value" in v) || !(v.value instanceof Json)) { + throw ffi.panic("invalid-type", "expected a proper typed json"); + } + const type = (v["@type"] as JsonText).value; + return new JsonTyped(type, v.value); + } else { + return new JsonRecord(Object.entries(value as any)); + } + } + + return reify_json; + } + + ffi.defun("json.typed", (tag, value) => { + return ffi.box( + new JsonTyped(ffi.text_to_string(tag), ffi.unbox_typed(Json, value)) + ); + }); + + ffi.defun("json.null", () => { + return ffi.box(_null); + }); + + ffi.defun("json.boolean", (x) => { + return ffi.box(new JsonBoolean(ffi.to_js_boolean(x))); + }); + + ffi.defun("json.number", (x) => { + return ffi.box(new JsonNumber(ffi.float_to_number(x))); + }); + + ffi.defun("json.text", (x) => { + return ffi.box(new JsonText(ffi.text_to_string(x))); + }); + + ffi.defun("json.list", (x) => { + return ffi.box( + new JsonList(ffi.list_to_array(x).map((x) => ffi.unbox_typed(Json, x))) + ); + }); + + ffi.defun("json.record", (x) => { + return ffi.box( + new JsonRecord( + ffi.list_to_array(x).map((p) => { + const [k, v] = ffi.list_to_array(p); + return [ffi.text_to_string(k), ffi.unbox_typed(Json, v)]; + }) + ) + ); + }); + ffi.defun("json.untrusted", (text) => { return ffi.untrusted_text(ffi.text_to_string(text)); }); - ffi.defun("json.parse", (text, trusted) => { - return ffi.from_plain_native( - from_json(JSON.parse(ffi.text_to_string(text))), - ffi.to_js_boolean(trusted) + ffi.defun("json.parse", (text, extended0) => { + const extended = ffi.to_js_boolean(extended0); + const value = JSON.parse(ffi.text_to_string(text), make_reify(extended)); + return ffi.box(value); + }); + + ffi.defun("json.get-type", (x0) => { + const x = ffi.unbox_typed(Json, x0); + if (x instanceof JsonNull) { + return ffi.text("null"); + } else if (x instanceof JsonNumber) { + return ffi.text("number"); + } else if (x instanceof JsonText) { + return ffi.text("text"); + } else if (x instanceof JsonBoolean) { + return ffi.text("boolean"); + } else if (x instanceof JsonList) { + return ffi.text("list"); + } else if (x instanceof JsonRecord) { + return ffi.text("record"); + } else if (x instanceof JsonTyped) { + return ffi.text("typed"); + } else { + throw ffi.panic("invalid-type", "invalid json type"); + } + }); + + ffi.defun("json.get-number", (x) => { + return ffi.float_64(ffi.unbox_typed(JsonNumber, x).value); + }); + + ffi.defun("json.get-boolean", (x) => { + return ffi.boolean(ffi.unbox_typed(JsonBoolean, x).value); + }); + + ffi.defun("json.get-text", (x) => { + return ffi.text(ffi.unbox_typed(JsonText, x).value); + }); + + ffi.defun("json.get-list", (x) => { + return ffi.list(ffi.unbox_typed(JsonList, x).values.map((x) => ffi.box(x))); + }); + + ffi.defun("json.get-record-entries", (x) => { + return ffi.list( + ffi.unbox_typed(JsonRecord, x).entries.map(([k, v]) => { + return ffi.list([ffi.text(k), ffi.box(v)]); + }) ); }); + ffi.defun("json.get-typed-tag", (x) => { + return ffi.text(ffi.unbox_typed(JsonTyped, x).tag); + }); + + ffi.defun("json.get-typed-value", (x) => { + return ffi.box(ffi.unbox_typed(JsonTyped, x).value); + }); + ffi.defun("json.serialise", (value, trusted) => { - const json = to_json(ffi.to_plain_native(value)); + const json = ffi.unbox_typed(Json, value); const json_text = JSON.stringify(json); if (ffi.to_js_boolean(trusted)) { return ffi.text(json_text); @@ -53,7 +225,7 @@ export default (ffi: ForeignInterface) => { }); ffi.defun("json.pretty-print", (value, indent, trusted) => { - const json = to_json(ffi.to_plain_native(value)); + const json = ffi.unbox_typed(Json, value); const json_text = JSON.stringify( json, null, diff --git a/stdlib/crochet.language.json/source/capabilities.crochet b/stdlib/crochet.language.json/source/capabilities.crochet new file mode 100644 index 00000000..1c49e7b1 --- /dev/null +++ b/stdlib/crochet.language.json/source/capabilities.crochet @@ -0,0 +1,7 @@ +% crochet + +singleton internal; +capability internal; + +protect type internal with internal; +protect global internal with internal; \ No newline at end of file diff --git a/stdlib/crochet.language.json/source/custom-serialisation.crochet b/stdlib/crochet.language.json/source/custom-serialisation.crochet new file mode 100644 index 00000000..a1f7a61a --- /dev/null +++ b/stdlib/crochet.language.json/source/custom-serialisation.crochet @@ -0,0 +1,51 @@ +% crochet + +type json-serialisation( + type-to-tag is map, + tag-to-type is map, +); + +command #json-serialisation empty = + new json-serialisation(#map empty, #map empty); + +command json-serialisation tag: (Tag is text) type: (Type is static-type) +requires + unique-map :: (not (self.type-to-tag contains-key: Type)) + and (not (self.tag-to-type contains-key: Tag)) +do + new json-serialisation( + self.type-to-tag at: Type put: Tag, + self.tag-to-type at: Tag put: Type, + ); +end + +command #json-serialisation defaults = + #json-serialisation empty + | tag: "integer" type: #integer + | tag: "map" type: #map + | tag: "set" type: #set; + + +command json-serialisation lower: (Value is json-type) = + Value; + +command json-serialisation lower: nothing = + json-null; + +command json-serialisation lower: (Value is boolean) = + #json-type boolean: Value; + +command json-serialisation lower: (Value is float-64bit) = + #json-type number: Value; + +command json-serialisation lower: (Value is unsafe-arbitrary-text) = + #json-type text: Value; + +command json-serialisation lower: (Value is list) = + #json-type list: (Value map: (self lower: _)); + +command json-serialisation lower: (Value is record) = + #map from: Value + |> _ map: { X in self lower: X value } + |> #json-type record: _; + diff --git a/stdlib/crochet.language.json/source/json.crochet b/stdlib/crochet.language.json/source/json.crochet index 8716a167..89d31c79 100644 --- a/stdlib/crochet.language.json/source/json.crochet +++ b/stdlib/crochet.language.json/source/json.crochet @@ -2,111 +2,51 @@ /// The default entry-point for JSON parsing and writing. Guarantees safety /// and equivalence of semantics between Crochet's values and JSON. -abstract json; +singleton json; +type extended-json(serialisation is json-serialisation) is json; -// -- Making sure we choose the right semantics for serialising JSON -local enum serialisation-mode = - sm-untrusted, - sm-trusted, - sm-unsupported; +// -- Constructors +command #extended-json bare = + new extended-json(#json-serialisation empty); -/// Returns the mode of serialisation for a given value (recursively) -command #serialisation-mode for: float-64bit = - sm-trusted; +command #extended-json defaults = + new extended-json(#json-serialisation defaults); -command #serialisation-mode for: boolean = - sm-trusted; +command #extended-json with-serialisation: (Serialisation is json-serialisation) = + new extended-json(Serialisation); -command #serialisation-mode for: text = - sm-trusted; - -command #serialisation-mode for: untrusted-text = - sm-untrusted; - -command #serialisation-mode for: nothing = - sm-trusted; - -command #serialisation-mode for: (Xs is list) = - (Xs map: (#serialisation-mode for: _)) fold-from: sm-trusted with: (_ or _); - -command #serialisation-mode for: (X is record) do - #map from: X - | values - | map: (#serialisation-mode for: _) - | fold-from: sm-trusted with: (_ or _); -end - -command #serialisation-mode for: any = - sm-unsupported; - -test "Computing serialisation mode" do - assert (#serialisation-mode for: 1.0) === sm-trusted; - assert (#serialisation-mode for: "a") === sm-trusted; - assert (#serialisation-mode for: nothing) === sm-trusted; - assert (#serialisation-mode for: true) === sm-trusted; - - let Untrusted = foreign json.untrusted("a"); - assert (#serialisation-mode for: Untrusted) === sm-untrusted; - - assert (#serialisation-mode for: [1.0, "a", nothing, true]) === sm-trusted; - assert (#serialisation-mode for: [1.0, "a", [Untrusted], true]) === sm-untrusted; - - assert (#serialisation-mode for: [a -> 1.0, b -> "a"]) === sm-trusted; - assert (#serialisation-mode for: [a -> 1.0, b -> [Untrusted]]) === sm-untrusted; - - assert (#serialisation-mode for: 1) === sm-unsupported; - assert (#serialisation-mode for: [1.0, "a", #serialisation-mode]) === sm-unsupported; -end - -/// Combines serialisation modes -command sm-trusted or sm-trusted = sm-trusted; - -command sm-unsupported or serialisation-mode = sm-unsupported; -command serialisation-mode or sm-unsupported = sm-unsupported; - -command sm-untrusted or sm-untrusted = sm-untrusted; -command sm-untrusted or sm-trusted = sm-untrusted; -command sm-trusted or sm-untrusted = sm-untrusted; - -test "Serialisation modes" do - assert (sm-trusted or sm-trusted) === sm-trusted; - - for Mode in [sm-untrusted, sm-trusted] do - assert (sm-untrusted or Mode) === sm-untrusted; - assert (Mode or sm-untrusted) === sm-untrusted; - end - - for Mode in [sm-untrusted, sm-trusted, sm-unsupported] do - assert (sm-unsupported or Mode) === sm-unsupported; - assert (Mode or sm-unsupported) === sm-unsupported; - end -end // -- JSON operations + /// Parses a piece of JSON text and returns the equivalent Crochet values /// for it. -command #json parse: (Value is text) do - foreign json.parse(Value, true) +command json parse: (Value is unsafe-arbitrary-text) do + let Trusted = Value is text; + let Parsed = foreign json.parse(Value, false); + internal repo: #json-serialisation empty trusted: Trusted reify: Parsed; test - assert (#json parse: "1234") === 1234.0; - assert (#json parse: "\"abc\"") === "abc"; - assert (#json parse: "\[123, null, \[true, false\]\]") === [123.0, nothing, [true, false]]; - assert (#json parse: "{\"a\": \[1, 2\], \"b\": {\"c\": 3}}") === [ + assert (json parse: "1234") === 1234.0; + assert (json parse: "\"abc\"") === "abc"; + assert (json parse: "\[123, null, \[true, false\]\]") === [123.0, nothing, [true, false]]; + assert (json parse: "{\"a\": \[1, 2\], \"b\": {\"c\": 3}}") === (#map from: [ a -> [1.0, 2.0], - b -> [c -> 3.0] - ]; + b -> #map from: [c -> 3.0] + ]); + + assert (json parse: (foreign json.untrusted("\"abc\""))) is untrusted-text; + let Result = json parse: (foreign json.untrusted("\[\"abc\"\]")); + assert Result first is untrusted-text; end /// Parses a piece of JSON text and returns the equivalent Crochet values -/// for it. All of the text in the result will likewise be untrusted. -command #json parse: (Value is untrusted-text) do - foreign json.parse(Value, false); -test - assert (#json parse: (foreign json.untrusted("\"abc\""))) is untrusted-text; - let Result = #json parse: (foreign json.untrusted("\[\"abc\"\]")); - assert Result first is untrusted-text; +/// for it. Can also handle parsing of extended JSON values according to the +/// serialisation rules defined for the [type:extended-json] instance. +command extended-json parse: (Value is unsafe-arbitrary-text) do + let Trusted = Value is text; + let Parsed = foreign json.parse(Value, true); + internal repo: self.serialisation trusted: Trusted reify: Parsed; end /// Converts a simple Crochet value to a JSON piece of text. If the input @@ -115,37 +55,37 @@ end /// Does no formatting—which is reasonable for computers, but not if you want /// the output to be used by humans. See [command:_ pretty-print: _ indentation: _] /// for the formatting alternative. -command #json serialise: Value -> unsafe-arbitrary-text do - let Mode = #serialisation-mode for: Value; - condition - when Mode =:= sm-trusted => foreign json.serialise(Value, true); - when Mode =:= sm-untrusted => foreign json.serialise(Value, false); - end +command extended-json serialise: Value -> unsafe-arbitrary-text do + let Json = internal repo: self.serialisation lower: Value; + foreign json.serialise(Json.value, Json.trusted); test - assert (#json serialise: 1234.0) === "1234"; - assert (#json serialise: "abc") === "\"abc\""; - assert (#json serialise: [123.0, nothing, [true, false]]) === "\[123,null,\[true,false\]\]"; - assert (#json serialise: [a -> [1.0, 2.0], b -> [c -> 3.0]]) === "{\"a\":\[1,2\],\"b\":{\"c\":3}}"; + assert (json serialise: 1234.0) === "1234"; + assert (json serialise: "abc") === "\"abc\""; + assert (json serialise: [123.0, nothing, [true, false]]) === "\[123,null,\[true,false\]\]"; + assert (json serialise: [a -> [1.0, 2.0], b -> [c -> 3.0]]) === "{\"a\":\[1,2\],\"b\":{\"c\":3}}"; let Untrusted = foreign json.untrusted("abc"); - assert (#json serialise: [a -> [1.0, Untrusted]]) is untrusted-text; + assert (json serialise: [a -> [1.0, Untrusted]]) is untrusted-text; end +command json serialise: Value -> unsafe-arbitrary-text = + #extended-json bare serialise: Value; + /// Converts a simple Crochet value to a JSON piece of text, and formats the /// output in a more human-readable way. See [command:_ serialise: _] for the /// more efficient (but meant for computers!) alternative. /// /// Note that if the input contains untrusted text, then the output will also /// be an untrusted text. -command #json pretty-print: Value indentation: (Indent is integer) -> unsafe-arbitrary-text +command extended-json pretty-print: Value indentation: (Indent is integer) -> unsafe-arbitrary-text requires positive-indentation :: Indent >= 0 do - let Mode = #serialisation-mode for: Value; - condition - when Mode =:= sm-trusted => foreign json.pretty-print(Value, Indent, true); - when Mode =:= sm-untrusted => foreign json.pretty-print(Value, Indent, false); - end + let Json = internal repo: self.serialisation lower: Value; + foreign json.pretty-print(Json.value, Indent, Json.trusted); test - assert (#json pretty-print: [1.0, 2.0, 3.0] indentation: 2) === "\[\n 1,\n 2,\n 3\n\]"; + assert (json pretty-print: [1.0, 2.0, 3.0] indentation: 2) === "\[\n 1,\n 2,\n 3\n\]"; let Untrusted = foreign json.untrusted("abc"); - assert (#json pretty-print: [1.0, Untrusted] indentation: 2) is untrusted-text; -end \ No newline at end of file + assert (json pretty-print: [1.0, Untrusted] indentation: 2) is untrusted-text; +end + +command json pretty-print: Value indentation: (Indent is integer) -> unsafe-arbitrary-text = + #extended-json bare pretty-print: Value indentation: Indent; \ No newline at end of file diff --git a/stdlib/crochet.language.json/source/serialisation.crochet b/stdlib/crochet.language.json/source/serialisation.crochet new file mode 100644 index 00000000..d87d2d5b --- /dev/null +++ b/stdlib/crochet.language.json/source/serialisation.crochet @@ -0,0 +1,93 @@ +% crochet + +effect json-lowering with + mark-untrusted(); +end + +command internal repo: (R is json-serialisation) lower: Value0 do + let Trusted = #cell with-value: true; + let Value = R lower: Value0; + handle + let Json = internal repo: R do-lower: Value; + [value -> Json, trusted -> Trusted value]; + with + on json-lowering.mark-untrusted() do + Trusted <- false; + continue with nothing; + end + end +end + +command internal repo: (R is json-serialisation) do-lower: (X is json-typed-plain) = + foreign json.typed(X.tag, self repo: R do-lower: X.value); + +command internal repo: (R is json-serialisation) do-lower: (X is json-typed) do + let Tag = R.type-to-tag at: X.tag; + foreign json.typed(Tag, self repo: R do-lower: X.value); +end + +command internal repo: json-serialisation do-lower: json-null = + foreign json.null(); + +command internal repo: json-serialisation do-lower: (X is json-boolean) = + foreign json.boolean(X value); + +command internal repo: json-serialisation do-lower: (X is json-number) = + foreign json.number(X value); + +command internal repo: json-serialisation do-lower: (X is json-text) do + condition + when X value is untrusted-text => perform json-lowering.mark-untrusted(); + otherwise => nothing; + end + + foreign json.text(X value); +end + +command internal repo: (R is json-serialisation) do-lower: (X is json-list) = + foreign json.list(X values map: (self repo: R do-lower: _)); + +command internal repo: (R is json-serialisation) do-lower: (X is json-record) = + foreign json.record( + X value entries map: { Entry in + [Entry key, self repo: R do-lower: Entry value]; + } + ); + + +command internal repo: (R is json-serialisation) trusted: (Trusted is boolean) reify: (X is unknown) do + let Type = foreign json.get-type(X); + condition + when Type =:= "null" => + nothing; + + when Type =:= "number" => + foreign json.get-number(X); + + when Type =:= "boolean" => + foreign json.get-boolean(X); + + when (Type =:= "text") and Trusted => + foreign json.get-text(X); + + when (Type =:= "text") and (not Trusted) => + foreign json.untrusted(foreign json.get-text(X)); + + when Type =:= "list" => + (foreign json.get-list(X)) map: (self repo: R trusted: Trusted reify: _); + + when Type =:= "record" => + (foreign json.get-record-entries(X)) + |> _ map: { X in + #association key: X first value: (self repo: R trusted: Trusted reify: X second); + } + |> #map from: _; + + when Type =:= "typed" do + let Type-tag = R.tag-to-type at: (foreign json.get-typed-tag(X)); + (foreign json.get-typed-value(X)) + |> self repo: R trusted: Trusted reify: _ + |> R reify: _ tag: Type-tag; + end + end +end \ No newline at end of file diff --git a/stdlib/crochet.language.json/source/trait-instances.crochet b/stdlib/crochet.language.json/source/trait-instances.crochet new file mode 100644 index 00000000..7ee2ac84 --- /dev/null +++ b/stdlib/crochet.language.json/source/trait-instances.crochet @@ -0,0 +1,41 @@ +% crochet + +implement to-json for integer; +command json-serialisation lower: (Value is integer) = + #json-type tag: #integer value: (#json-type text: Value to-text); + +implement from-json for #integer; +command json-serialisation reify: (X is json-text) tag: #integer = + #integer parse: X value; + + +implement to-json for map; +command json-serialisation lower: (Value is map) = + #json-type tag: #map value: ( + #json-type list: ( + Value entries map: { Pair in + #json-type record: [key -> self lower: Pair key, value -> self lower: Pair value] + } + ) + ); + +implement from-json for map; +command json-serialisation reify: (X is json-list) tag: #map do + let Entries = X values map: { X in + let Entry = self reify: X; + #association key: Entry.key value: Entry.value; + }; + #map from: Entries; +end + + +implement to-json for set; +command json-serialisation lower: (Value is set) do + let Values = Value values map: (self lower: _); + #json-type tag: #set value: (#json-type list: Values); +end + +implement from-json for set; +command json-serialisation reify: (X is json-list) tag: #set = + X values map: (self reify: _) + |> #set from: _; diff --git a/stdlib/crochet.language.json/source/types.crochet b/stdlib/crochet.language.json/source/types.crochet new file mode 100644 index 00000000..cf4cc3ce --- /dev/null +++ b/stdlib/crochet.language.json/source/types.crochet @@ -0,0 +1,45 @@ +% crochet + +abstract json-type; +type json-typed-plain(tag is text, global value is json-type) is json-type; +type json-typed(tag is static-type, global value is json-type) is json-type; +type json-boolean(global value is boolean) is json-type; +type json-number(global value is float-64bit) is json-type; +type json-text(global value is unsafe-arbitrary-text) is json-type; +type json-list(global values is list) is json-type; +type json-record(global value is map) is json-type; +singleton json-null is json-type; + +trait to-json with + command json-serialisation lower: (Value is A) -> json-type; +end + +trait from-json with + command json-serialisation reify: (Value is json-type) tag: (Type is static-type) -> A; +end + + +// -- Constructors +command #json-type tag: (Tag is static-type) value: (Value is json-type) = + new json-typed(Tag, Value); + +command #json-type null = + json-null; + +command #json-type boolean: (X is boolean) = + new json-boolean(X); + +command #json-type number: (X is float-64bit) = + new json-number(X); + +command #json-type text: (X is unsafe-arbitrary-text) = + new json-text(X); + +command #json-type list: (Xs is list) = + new json-list(Xs); + +command #json-type record: (X is record) = + new json-record(#map from: X); + +command #json-type record: (X is map) = + new json-record(X);