@kaiko.io/rescript-deser 7.0.0-alpha.1 → 7.0.0

package/lib/ocaml/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/ocaml/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"

package/lib/ocaml/index.res

@@ -0,0 +1,212 @@
+open QUnit
+
+module Appointment = {
+  type t = {
+    note: string,
+    date: Date.t,
+    extra: option<string>,
+  }
+  module Deserializer = Deser.MakeDeserializer({
+    type t = t
+    open Deser.Field
+
+    let fields = Object([("note", String), ("date", Date), ("extra", Optional(String))])
+  })
+}
+
+module_("Basic deserializer", _ => {
+  let valid: array<(_, Appointment.t)> = [
+    (
+      %raw(`{"note": "Bicentennial doctor's appointment", "date": "2100-01-01"}`),
+      {
+        note: "Bicentennial doctor's appointment",
+        date: Date.fromString("2100-01-01"),
+        extra: None,
+      },
+    ),
+    (
+      %raw(`{
+      "note": "Bicentennial doctor's appointment",
+      "date": "2100-01-01",
+      "extra": "Don't take your stop-aging pills the night before the appointment",
+    }`),
+      {
+        note: "Bicentennial doctor's appointment",
+        date: Date.fromString("2100-01-01"),
+        extra: Some("Don't take your stop-aging pills the night before the appointment"),
+      },
+    ),
+  ]
+
+  test("Correctly deserializes data", qunit => {
+    qunit->expect(valid->Array.length)
+    valid->Array.forEach(
+      ((data, expected)) => {
+        Console.log2("Running sample", data)
+        switch Appointment.Deserializer.fromJSON(data) {
+        | Ok(result) => qunit->deepEqual(result, expected, "result == expected")
+        | Error(msg) => Console.error(msg)
+        }
+      },
+    )
+  })
+
+  let invalid = [
+    (
+      "Missing non-optional field",
+      %raw(`{"extra": "Bicentennial doctor's appointment", "date": "2100-01-01"}`),
+    ),
+  ]
+
+  test("Correctly catches invalid data", qunit => {
+    qunit->expect(invalid->Array.length)
+    invalid->Array.forEach(
+      ((message, data)) => {
+        Console.log3("Running sample", message, data)
+        switch Appointment.Deserializer.fromJSON(data) {
+        | Ok(result) => Console.error2("Invalid being accepted: ", result)
+        | Error(msg) => {
+            Console.log2("Correctly detected:", msg)
+            qunit->ok(true, true)
+          }
+        }
+      },
+    )
+  })
+})
+
+module_("Recursive deserializer", _ => {
+  module TrivialTree = {
+    type rec t<'a> = {
+      data: 'a,
+      children: array<t<'a>>,
+    }
+
+    module DeserializerImpl = Deser.MakeDeserializer({
+      type payload
+      type rec t = {
+        data: payload,
+        children: array<t>,
+      }
+      open Deser.Field
+
+      let fields = Object([("data", Any), ("children", Array(Self))])
+    })
+
+    module Deserializer = {
+      include DeserializerImpl
+
+      let fromJSON = data => data->DeserializerImpl.fromJSON->Result.map(x => x->Obj.magic)
+    }
+  }
+
+  let valid: array<(_, TrivialTree.t<string>)> = [
+    (
+      %raw(`{"data": "A", "children": [{"data": "A1", "children": []}, {"data": "B", "children": [{"data": "C", "children": []}, {"data": "D", "children": []}]}]}`),
+      {
+        data: "A",
+        children: [
+          {data: "A1", children: []},
+          {data: "B", children: [{data: "C", children: []}, {data: "D", children: []}]},
+        ],
+      },
+    ),
+  ]
+
+  test("Trivial recursion detection: Ok", qunit => {
+    qunit->expect(1)
+    qunit->deepEqual(TrivialTree.Deserializer.checkFieldsSanity(), Ok(), "Ok")
+  })
+
+  test("Infinite list", qunit => {
+    module InfiniteList = Deser.MakeDeserializer({
+      open Deser.Field
+
+      type t
+      let fields = Object([("head", String), ("tail", Self)])
+    })
+
+    qunit->expect(1)
+    qunit->deepEqual(InfiniteList.checkFieldsSanity()->Result.isError, true, "Ok")
+  })
+
+  test("Finite list", qunit => {
+    module List = Deser.MakeDeserializer({
+      open Deser.Field
+
+      type t
+      let fields = Object([("head", String), ("tail", Optional(Self))])
+    })
+
+    qunit->expect(1)
+    qunit->deepEqual(List.checkFieldsSanity(), Ok(), "Ok")
+  })
+
+  test("Correctly deserializes recursive data", qunit => {
+    qunit->expect(valid->Array.length)
+    valid->Array.forEach(
+      ((data, expected)) => {
+        Console.log2("Running sample", data)
+        switch TrivialTree.Deserializer.fromJSON(data) {
+        | Ok(result) => qunit->deepEqual(result, expected, "result == expected")
+        | Error(msg) => Console.error(msg)
+        }
+      },
+    )
+  })
+
+  test("Recursion in sub-deserializer", qunit => {
+    module List = Deser.MakeDeserializer({
+      open Deser.Field
+
+      type t
+      let fields = Object([("head", String), ("tail", Optional(Self))])
+    })
+
+    module Ledger = Deser.MakeDeserializer({
+      open Deser.Field
+
+      type t
+      let fields = Object([("records", Deserializer(module(List))), ("next", Optional(Self))])
+    })
+
+    let data = %raw(`
+       {"records": {"head": "A", "tail": {"head": "B"}},
+        "next": {"records": {"head": "A", "tail": {"head": "B"}}}}
+    `)
+    let expected = {
+      "records": {"head": "A", "tail": {"head": "B", "tail": None}},
+      "next": {
+        "records": {"head": "A", "tail": {"head": "B", "tail": None}},
+        "next": None,
+      },
+    }
+
+    qunit->expect(1)
+    qunit->deepEqual(data->Ledger.fromJSON->Obj.magic, Ok(expected), "nice ledger")
+  })
+})
+
+module_("Type safety limits", _ => {
+  test("ill-defined deserializer can cheat the type system", qunit => {
+    module X = Deser.MakeDeserializer({
+      type t = string
+      let fields = Deser.Field.Array(Int)
+    })
+
+    let data = %raw("[1]")
+    qunit->throws(
+      _ => {
+        let illString = data->X.fromJSON->Result.getOr("")
+        try {
+          Console.info3(__MODULE__, "This will fail with a type error", illString->String.charAt(0))
+        } catch {
+        | e =>
+          Console.error(e)
+          throw(e)
+        }
+      },
+      "Expected: TypeError: illString.charAt is not a function",
+    )
+  })
+})

package/lib/rescript.lock

@@ -0,0 +1 @@
+1387245

package/package.json

@@ -1,6 +1,6 @@
 {
   "name": "@kaiko.io/rescript-deser",
-  "version": "7.0.0-alpha.1",
+  "version": "7.0.0",
   "keywords": [
     "json",
     "deserializer",
@@ -19,17 +19,15 @@
     "README.md"
   ],
   "peerDependencies": {
-    "@rescript/core": ">=1.6",
-    "rescript": ">=11.1.0"
+    "rescript": ">=12.0.0"
   },
   "devDependencies": {
     "@babel/code-frame": "7.18.6",
-    "@jihchi/vite-plugin-rescript": "^6.0",
+    "@jihchi/vite-plugin-rescript": ">=8.0.0-beta.2",
     "@playwright/test": "1.56.1",
-    "@rescript/core": "^1.6.0",
     "@rescript/tools": "0.6.4",
     "qunit": "^2.16.0",
-    "rescript": "^11.1.0",
+    "rescript": "^12.0.0",
     "vite": "^5.4.0"
   }
 }