@kaiko.io/rescript-deser 6.0.1 → 7.0.0-alpha.2

package/README.md

@@ -50,7 +50,7 @@ The resultant module has type:
 module type Deserializer = {
   type t
   let name: string
-  let fromJSON: Js.Json.t => result<t, string>
+  let fromJSON: RescriptCore.JSON.t => result<t, string>
 }
 ```
 
@@ -80,10 +80,10 @@ module type Serializable = {
   JS representation of the object that comes from the JSON data.
 
 - `Date`, parses either a string representation of a date (datetime) or a
-  floating point representation of date (datetime) into `Js.Date.t`; we make
+  floating point representation of date (datetime) into `Date.t`; we make
   sure the result is valid and won't return NaN afterwards.
 
-  This basically calls, `Js.Date.fromString` or `Js.Date.fromFloat`; and tests
+  This basically calls, `Date.fromString` or `Date.fromTime`; and tests
   the resulting value.
 
   `Datetime` is an alias for `Date`.
@@ -104,8 +104,7 @@ module type Serializable = {
   `Optional`, `OptionalWithDefault`.
 
 - `Mapping(Field.t)`, parses a JSON object with unknown keys (of type string)
-  and a given type of value.  Valid values have the internal type
-  `Prelude.Dict.t`.
+  and a given type of value.  Valid values have the internal type `dict<_>`.
 
 - `Deserializer(module(Deserializer))`, parses an JSON object with the function
   `fromJSON` of another deserializer.  This allows the composition of
@@ -136,6 +135,18 @@ type rec Node<'t> = Leave('t) | (Branch(array<Node<'t>>)
 Cannot be automatically deserialized.
 
 
+# Type safety disclaimer
+
+`Deser` cannot guarantee type safety for ill-defined deserializers, the following deserializer will accept JSON payloads of the wrong type that can cause runtime type errors:
+
+```rescript
+module X = Deser.MakeDeserializer({
+  type t = string
+  let fields = Deser.Field.Array(Int)
+})
+```
+
+
 ## License
 
 The MIT License

package/lib/bs/.compiler.log

@@ -1,2 +1,2 @@
-#Start(1748800211525)
-#Done(1748800211525)
+#Start(1766178477130)
+#Done(1766178477131)

package/lib/bs/build.ninja

@@ -1,27 +0,0 @@
-rescript = 1
-g_finger := /home/manu/src/kaiko/rescript-deser/node_modules/@rescript/core/lib/ocaml/install.stamp
-rule astj
-  command = /home/manu/src/kaiko/rescript-deser/node_modules/rescript/linux/bsc.exe  -warn-error +8+11+26+33+56 -bs-v 11.1.4 -uncurried  -absname -bs-ast -o $out $i
-o tests/index.ast : astj ../../tests/index.res
-rule deps_dev
-  command = /home/manu/src/kaiko/rescript-deser/node_modules/rescript/linux/bsb_helper.exe -g -hash 9a7a4be86983dcab705bb67a1ec483c7 $in
-  restat = 1
-o tests/index.d : deps_dev tests/index.ast
-rule mij_dev
-  command = /home/manu/src/kaiko/rescript-deser/node_modules/rescript/linux/bsc.exe -I tests -I src/ -I /home/manu/src/kaiko/rescript-deser/node_modules/@rescript/core/lib/ocaml    -warn-error +8+11+26+33+56 -uncurried -bs-package-name @kaiko.io/rescript-deser -bs-package-output commonjs:lib/js/$in_d:.js -bs-package-output esmodule:lib/es6/$in_d:.js -bs-v $g_finger $i
-  dyndep = 1
-  restat = 1
-o tests/index.cmj tests/index.cmi ../es6/tests/index.js ../js/tests/index.js : mij_dev tests/index.ast
-o tests/QUnit.ast : astj ../../tests/QUnit.res
-o tests/QUnit.d : deps_dev tests/QUnit.ast
-o tests/QUnit.cmj tests/QUnit.cmi ../es6/tests/QUnit.js ../js/tests/QUnit.js : mij_dev tests/QUnit.ast
-o src/Deser.ast : astj ../../src/Deser.res
-rule deps
-  command = /home/manu/src/kaiko/rescript-deser/node_modules/rescript/linux/bsb_helper.exe -hash 9a7a4be86983dcab705bb67a1ec483c7 $in
-  restat = 1
-o src/Deser.d : deps src/Deser.ast
-rule mij
-  command = /home/manu/src/kaiko/rescript-deser/node_modules/rescript/linux/bsc.exe -I src/ -I /home/manu/src/kaiko/rescript-deser/node_modules/@rescript/core/lib/ocaml   -warn-error +8+11+26+33+56 -uncurried -bs-package-name @kaiko.io/rescript-deser -bs-package-output commonjs:lib/js/$in_d:.js -bs-package-output esmodule:lib/es6/$in_d:.js -bs-v $g_finger $i
-  dyndep = 1
-  restat = 1
-o src/Deser.cmj src/Deser.cmi ../es6/src/Deser.js ../js/src/Deser.js : mij src/Deser.ast

package/lib/bs/compiler-info.json

@@ -0,0 +1,8 @@
+{
+  "version": "12.0.1",
+  "bsc_path": "/home/manu/src/kaiko/rescript-deser/node_modules/@rescript/linux-x64/bin/bsc.exe",
+  "bsc_hash": "a2b93197b8c05fc70981fe131a9ed75f8462a9f615f71055f306c9deb058d3cf",
+  "rescript_config_hash": "6e13fe97e162573c9ab73327567294583b34d549775f8391e1d5c8ccc0c5d580",
+  "runtime_path": "/home/manu/src/kaiko/rescript-deser/node_modules/@rescript/runtime",
+  "generated_at": "1766178477132"
+}

package/lib/bs/src/Deser.res

@@ -0,0 +1,341 @@
+module FieldValue = {
+  type t
+  external string: string => t = "%identity"
+  external int: int => t = "%identity"
+  external float: float => t = "%identity"
+  external boolean: bool => t = "%identity"
+  external array: array<t> => t = "%identity"
+  external object: dict<t> => t = "%identity"
+  external mapping: dict<t> => t = "%identity"
+  external any: 'a => t = "%identity"
+  @val external null: t = "undefined"
+
+  external asString: t => string = "%identity"
+  external asInt: t => int = "%identity"
+  external asFloat: t => float = "%identity"
+  external asBoolean: t => bool = "%identity"
+  external asArray: t => array<'a> = "%identity"
+  external asObject: t => 'a = "%identity"
+}
+
+exception TypeError(string)
+
+@doc("The module type of a built deserializer which is suitable to add as a subparser.")
+module type Deserializer = {
+  type t
+  let name: string
+  let fromJSON: JSON.t => result<t, string>
+  let checkFieldsSanity: unit => result<unit, string>
+}
+
+module Field = {
+  type rec t =
+    | Any
+    | String
+    | Literal(string)
+    | Int
+    | Float
+    | Boolean
+    | Array(t)
+    // These SHOULD strings in ISO format, but we only validate the string
+    // can be represented in Js.Date without spewing NaN all over the place;
+    // Js.Date.fromString("xxx") returns an object that is mostly unusable.
+    ///
+    // We also allow floats and then use Date.fromTime
+    | Date
+    | Datetime // alias of Date
+    | Tuple(array<t>)
+    | Object(array<(string, t)>)
+    | Optional(t)
+    | OptionalWithDefault(t, FieldValue.t)
+    // An arbitrary mapping from names to other arbitrary fields.  The
+    // difference with Object, is that you don't know the names of the
+    // expected entries.
+    | Mapping(t)
+    | Deserializer(module(Deserializer))
+    // A specialized Array of deserialized items that ignores unparsable
+    // items and returns the valid collection.  This saves the user from
+    // writing 'Array(DefaultWhenInvalid(Optional(Deserializer(module(M)))))'
+    // and then post-process the list of items with 'Array.keepSome'
+    | Collection(module(Deserializer))
+    | DefaultWhenInvalid(t, FieldValue.t)
+    // FIXME: this is used to add additional restrictions like variadictInt or
+    // variadicString; but I find it too type-unsafe.  I might consider having
+    // a Constraints for this in the future.
+    | Morphism(t, FieldValue.t => FieldValue.t)
+    | Self
+
+  let usingString = (f: string => 'a) => value => value->FieldValue.asString->f->FieldValue.any
+  let usingInt = (f: int => 'a) => value => value->FieldValue.asInt->f->FieldValue.any
+  let usingFloat = (f: float => 'a) => value => value->FieldValue.asFloat->f->FieldValue.any
+  let usingBoolean = (f: bool => 'a) => value => value->FieldValue.asBoolean->f->FieldValue.any
+  let usingArray = (f: array<'a> => 'b) => value => value->FieldValue.asArray->f->FieldValue.any
+  let usingObject = (f: 'a => 'b) => value => value->FieldValue.asObject->f->FieldValue.any
+
+  let variadicInt = (hint: string, fromJs: int => option<'variadicType>) => Morphism(
+    Int,
+    usingInt(i => {
+      switch i->fromJs {
+      | Some(internalValue) => internalValue
+      | None =>
+        throw(TypeError(`This Int(${i->Int.toString}) not a valid value here. Hint: ${hint}`))
+      }
+    }),
+  )
+  let variadicString = (hint: string, fromJs: string => option<'variadicType>) => Morphism(
+    String,
+    usingString(i => {
+      switch i->fromJs {
+      | Some(internalValue) => internalValue
+      | None => throw(TypeError(`This String("${i}") not a valid value here. Hint: ${hint}`))
+      }
+    }),
+  )
+
+  let rec toString = (type_: t) =>
+    switch type_ {
+    | Any => "Any"
+    | String => "String"
+    | Literal(lit) => `Literal: ${lit}`
+    | Int => "Integer"
+    | Float => "Float"
+    | Boolean => "Boolean"
+    | Datetime
+    | Date => "Date"
+    | Self => "Self (recursive)"
+    | Collection(m) => {
+        module M = unpack(m: Deserializer)
+        "Collection of " ++ M.name
+      }
+
+    | Array(t) => "Array of " ++ t->toString
+    | Tuple(bases) => `Tuple of (${bases->Array.map(toString)->Array.join(", ")})`
+    | Object(fields) => {
+        let desc = fields->Array.map(((field, t)) => `${field}: ${t->toString}`)->Array.join(", ")
+        `Object of {${desc}}`
+      }
+
+    | OptionalWithDefault(t, _)
+    | Optional(t) =>
+      "Null of " ++ t->toString
+    | Mapping(t) => `Mapping of ${t->toString}`
+    | Morphism(t, _) => t->toString ++ " to apply a morphism"
+    | Deserializer(m) => {
+        module M = unpack(m: Deserializer)
+        M.name
+      }
+
+    | DefaultWhenInvalid(t, _) => `Protected ${t->toString}`
+    }
+
+  let _taggedToString = (tagged: JSON.t) => {
+    switch tagged {
+    | Boolean(false) => "Boolean(false)"
+    | Boolean(true) => "Boolean(true)"
+    | Null => "Null"
+    | String(text) => `String("${text}")`
+    | Number(number) => `Number(${number->Float.toString})`
+    | Object(obj) => `Object(${obj->JSON.stringifyAny->Option.getOr("...")})`
+    | Array(array) => `Array(${array->JSON.stringifyAny->Option.getOr("...")})`
+    }
+  }
+
+  let rec extractValue = (values: dict<JSON.t>, field: string, shape: t, self: t): FieldValue.t => {
+    switch values->Dict.get(field) {
+    | Some(value) => value->fromUntagged(shape, self)
+    | None =>
+      switch shape {
+      | DefaultWhenInvalid(_, _) => JSON.Null->fromUntagged(shape, self)
+      | Optional(_) => JSON.Null->fromUntagged(shape, self)
+      | OptionalWithDefault(_, default) => default
+      | _ => throw(TypeError(`Missing non-optional field '${field}'`))
+      }
+    }
+  }
+  and fromUntagged: (JSON.t, t, t) => FieldValue.t = (untagged, shape, self) => {
+    switch (shape, untagged) {
+    | (Any, _) => untagged->FieldValue.any
+
+    | (Literal(expected), String(text)) if text == expected => FieldValue.string(text)
+    | (Literal(expected), String(text)) =>
+      throw(TypeError(`Expecting literal ${expected}, got ${text}`))
+
+    | (String, String(text)) => FieldValue.string(text)
+
+    | (Int, Number(number)) => FieldValue.int(number->Float.toInt)
+
+    | (Float, Number(number)) => FieldValue.float(number)
+
+    | (Boolean, Boolean(v)) => FieldValue.boolean(v)
+
+    | (Tuple(bases), Array(items)) => {
+        let lenbases = bases->Array.length
+        let lenitems = items->Array.length
+        if lenbases == lenitems {
+          let values = Belt.Array.zipBy(items, bases, (i, b) => fromUntagged(i, b, self))
+          values->FieldValue.array
+        } else {
+          throw(
+            TypeError(`Expecting ${lenbases->Int.toString} items, got ${lenitems->Int.toString}`),
+          )
+        }
+      }
+
+    | (Datetime | Date, String(s)) =>
+      let r = Date.fromString(s)
+      if r->Date.getDate->Int.toFloat->Float.isNaN {
+        throw(TypeError(`Invalid date ${s}`))
+      }
+      r->FieldValue.any
+
+    | (Datetime | Date, Number(f)) =>
+      let r = Date.fromTime(f)
+      if r->Date.getDate->Int.toFloat->Float.isNaN {
+        throw(TypeError(`Invalid date ${f->Float.toString}`))
+      }
+      r->FieldValue.any
+
+    | (Array(shape), Array(items)) =>
+      FieldValue.array(items->Array.map(item => item->fromUntagged(shape, self)))
+
+    | (Mapping(f), Object(values)) =>
+      values->Dict.mapValues(v => v->fromUntagged(f, self))->FieldValue.mapping
+
+    | (Object(fields), Object(values)) =>
+      fields
+      ->Array.map(((field, shape)) => {
+        let value = switch extractValue(values, field, shape, self) {
+        | value => value
+        | exception TypeError(msg) => throw(TypeError(`Field "${field}": ${msg}`))
+        }
+        (field, value)
+      })
+      ->Dict.fromArray
+      ->FieldValue.object
+
+    | (OptionalWithDefault(_, value), Null) => value
+    | (OptionalWithDefault(shape, _), _) => untagged->fromUntagged(shape, self)
+    | (Optional(_), Null) => FieldValue.null
+    | (Optional(shape), _) => untagged->fromUntagged(shape, self)
+    | (Morphism(shape, f), _) => untagged->fromUntagged(shape, self)->f->FieldValue.any
+
+    | (Collection(m), Array(items)) => {
+        module M = unpack(m: Deserializer)
+        items
+        ->Array.map(M.fromJSON)
+        ->Array.filterMap(x =>
+          switch x {
+          | Ok(v) => Some(v)
+          | Error(msg) =>
+            Console.warn3(__MODULE__, "Could not deserialize value in the collection", msg)
+            None
+          }
+        )
+        ->Array.map(FieldValue.any)
+        ->FieldValue.array
+      }
+
+    | (Deserializer(m), _) => {
+        module M = unpack(m: Deserializer)
+        switch untagged->M.fromJSON {
+        | Ok(res) => res->FieldValue.any
+        | Error(msg) => throw(TypeError(msg))
+        }
+      }
+
+    | (DefaultWhenInvalid(t, default), _) =>
+      switch untagged->fromUntagged(t, self) {
+      | res => res
+      | exception TypeError(msg) => {
+          Console.warn2("Detected and ignore (with default): ", msg)
+          default
+        }
+      }
+    | (Self, _) => untagged->fromUntagged(self, self)
+    | (expected, actual) =>
+      throw(TypeError(`Expected ${expected->toString}, but got ${actual->_taggedToString} instead`))
+    }
+  }
+
+  let rec checkFieldsSanity = (name: string, fields: t, optional: bool): result<unit, string> =>
+    switch (fields, optional) {
+    | (Self, false) => Error(`${name}: Trivial infinite recursion 'let fields = Self'`)
+    | (Self, true) => Ok()
+
+    | (Any, _) => Ok()
+    | (String, _) | (Float, _) | (Int, _) | (Literal(_), _) => Ok()
+    | (Boolean, _) | (Date, _) | (Datetime, _) => Ok()
+    | (Morphism(_, _), _) => Ok()
+
+    | (Collection(mod), _)
+    | (Deserializer(mod), _) => {
+        module M = unpack(mod: Deserializer)
+        switch M.checkFieldsSanity() {
+        | Ok() => Ok()
+        | Error(msg) => Error(`${name}/ ${msg}`)
+        }
+      }
+
+    | (DefaultWhenInvalid(fields, _), _)
+    | (OptionalWithDefault(fields, _), _)
+    | (Optional(fields), _) =>
+      checkFieldsSanity(name, fields, true)
+
+    | (Object(fields), optional) =>
+      fields
+      ->Array.map(((fieldName, field)) =>
+        () => checkFieldsSanity(`${name}::${fieldName}`, field, optional)
+      )
+      ->Array.reduce(Ok([]), (res, nextitem) =>
+        res->Result.flatMap(arr => nextitem()->Result.map(i => arr->Array.concat([i])))
+      )
+      ->Result.map(_ => ())
+
+    // Mappings and arrays can be empty, so their payloads are
+    // automatically optional.
+    | (Mapping(field), _) | (Array(field), _) => checkFieldsSanity(name, field, true)
+
+    | (Tuple(fields), optional) =>
+      fields
+      ->Array.mapWithIndex((field, index) =>
+        () => checkFieldsSanity(`${name}[${index->Int.toString}]`, field, optional)
+      )
+      ->Array.reduce(Ok([]), (res, nextitem) =>
+        res->Result.flatMap(arr => nextitem()->Result.map(i => arr->Array.concat([i])))
+      )
+      ->Result.map(_ => ())
+    }
+}
+
+module type Serializable = {
+  type t
+  let fields: Field.t
+}
+
+module MakeDeserializer = (S: Serializable): (Deserializer with type t = S.t) => {
+  type t = S.t
+  let fields = S.fields
+  %%private(let (loc, _f) = __LOC_OF__(module(S: Serializable)))
+  let name = `Deserializer ${__MODULE__}, ${loc}`
+
+  %%private(external _toNativeType: FieldValue.t => t = "%identity")
+
+  @doc("Checks for trivial infinite-recursion in the fields of the module.
+
+  Notice this algorithm is just an heuristic, and it might happen that are
+  cases of infinite-recursion not detected and cases where detection is a
+  false positive.
+
+  You should use this only while debugging/developing to verify your data.
+
+  ")
+  let checkFieldsSanity = () => Field.checkFieldsSanity(name, fields, false)
+
+  @doc("Parse a `'a` into `result<t, string>`")
+  let fromJSON: JSON.t => result<t, _> = json => {
+    switch json->Field.fromUntagged(fields, fields) {
+    | res => Ok(res->_toNativeType)
+    | exception TypeError(e) => Error(e)
+    }
+  }
+}

package/lib/bs/tests/QUnit.res

@@ -0,0 +1,72 @@
+type description = string
+type message = string
+
+type result<'a> = {
+  result: bool,
+  actual: 'a,
+  expected: 'a,
+  message: string,
+}
+
+type assertion
+type block = assertion => unit
+type matcher<'a> = 'a => bool
+
+// Library stuff
+
+@scope("QUnit") external start: unit => unit = "start"
+@scope("QUnit") external done: (unit => unit) => unit = "done"
+
+@send external expect: (assertion, int) => unit = "expect"
+@send external pushResult: (assertion, result<'a>) => unit = "notOk"
+@send external step: (assertion, description) => unit = "step"
+@send external verifySteps: (assertion, array<description>) => unit = "verifySteps"
+
+// Values
+
+@send external equal: (assertion, 'a, 'a, description) => unit = "equal"
+@send external notEqual: (assertion, 'a, 'a, description) => unit = "notEqual"
+
+@send external isFalse: (assertion, 'a, description) => unit = "false"
+@send external isTrue: (assertion, 'a, description) => unit = "true"
+
+@send external deepEqual: (assertion, 'a, 'a, description) => unit = "deepEqual"
+@send external notDeepEqual: (assertion, 'a, 'a, description) => unit = "notDeepEqual"
+
+@send external strictEqual: (assertion, 'a, 'a, description) => unit = "strictEqual"
+@send external notStrictEqual: (assertion, 'a, 'a, description) => unit = "notStrictEqual"
+
+@send external ok: (assertion, 'a, 'a) => unit = "ok"
+@send external notOk: (assertion, 'a, 'a) => unit = "notOk"
+
+@send external propEqual: (assertion, 'a, 'a) => unit = "propEqual"
+@send external notPropEqual: (assertion, 'a, 'a) => unit = "notPropEqual"
+
+// Promises
+
+type done = unit => unit
+
+@send external async: assertion => done = "async"
+@send external asyncMany: (assertion, int) => done = "async"
+@send external rejects: (assertion, promise<'a>, message) => unit = "rejects"
+@send external rejectsM: (assertion, promise<'a>, message) => unit = "rejects"
+@send
+external rejectMatches: (assertion, promise<'a>, matcher<'a>, message) => unit = "rejects"
+@send
+external rejectMatchesM: (assertion, promise<'a>, matcher<'a>, message) => unit = "rejects"
+@send external timeout: (assertion, int) => unit = "timeout"
+
+// Exceptions
+
+@send external throws: (assertion, block, message) => unit = "throws"
+@send
+external throwMatches: (assertion, block, matcher<'a>, message) => unit = "throws"
+
+type hooks
+@send external before: (hooks, block) => unit = "before"
+@send external beforeEach: (hooks, block) => unit = "beforeEach"
+@send external afterEach: (hooks, block) => unit = "afterEach"
+@send external after: (hooks, block) => unit = "after"
+
+@module("qunit") @val external module_: (description, hooks => unit) => unit = "module"
+@module("qunit") @val external test: (description, block) => unit = "test"