@kaiko.io/rescript-deser 1.0.0

package/.dir-locals.el

@@ -0,0 +1,6 @@
+;;; Directory Local Variables
+;;; For more information see (info "(emacs) Directory Variables")
+
+( (rescript-mode . ((projectile-project-compilation-cmd . "make compile-rescript")
+                     (indent-tabs-mode . nil)))
+  (nil . ((projectile-project-compilation-cmd . "make compile-rescript"))))

package/.gitlab-ci.yml

@@ -0,0 +1,52 @@
+stages:
+  - compile
+
+.x-compile: &with-compilation-script
+  image: node
+  script:
+    - make compile
+
+.x-when-mr: &when-merge-request
+  interruptible: true
+  only:
+    - merge_requests
+
+.x-when-stable: &when-in-stable
+  only:
+    - main
+
+.x-when-stable-or-mr: &when-stable-or-merging
+  interruptible: true
+  only:
+    - main
+    - merge_requests
+
+lint:
+  <<: *when-stable-or-merging
+  stage: compile
+  image: node
+  tags:
+    - docker
+  script:
+    - |
+      make format
+      touched=$(git status --porcelain | wc -l) || touched=0
+      if [ $touched -gt 0 ]; then
+          git status
+          exit 1
+      fi
+
+check that we can compile the whole thing before merging:
+  <<: *with-compilation-script
+  <<: *when-merge-request
+  stage: compile
+  tags:
+    - docker
+
+compile:
+  <<: *with-compilation-script
+  <<: *when-in-stable
+  interruptible: true
+  stage: compile
+  tags:
+    - docker

package/Makefile

@@ -0,0 +1,17 @@
+PATH := ./node_modules/.bin/:$(PATH)
+
+yarn.lock: bsconfig.json package.json
+	yarn install
+
+compile: yarn.lock
+	[ -n "$(INSIDE_EMACS)" ] && (rescript build -with-deps | sed "s@  $(shell pwd)/@@") || rescript build -with-deps
+
+format: yarn.lock
+	rescript format -all
+
+.PHONY: compile format
+
+RESCRIPT_FILES := $(shell find src -type f -name '*.res')
+
+compile-rescript: $(RESCRIPT_FILES) yarn.lock
+	[ -n "$(INSIDE_EMACS)" ] && (rescript build -with-deps | sed "s@  $(shell pwd)/@@") || rescript build -with-deps

package/README.md

@@ -0,0 +1,75 @@
+# bs-deser
+
+Simple JSON deserializer for ReScript.
+
+## Description
+
+This module allows you to create deserialize structures from JSON into an
+internal type-safe type in ReScript.  You don't (shouldn't) have to trust the
+data you're getting from an API will always fit the expected shape and types.
+So you might need to create a "parser" so that you can be sure the data is
+type-correct.
+
+## Usage
+
+You need to create a description of your data using ``JSON.Field.t``.
+
+```rescript
+module MyData = {
+    @deriving(jsConverter)
+    type tag = [#a | #b | #c]
+
+    type t = {
+        id: string,
+        tags: array<tag>
+    }
+}
+
+module MyDataDeserializer = JSON.Deserializer({
+    type t = MyData.t
+    open JSON.Field
+
+    let fields = Object([
+        ("id", String),
+        ("tags", Array(variadicString(MyData.tagFromJs)))
+    ])
+})
+```
+
+This creates a function `MyDataDeserializer.fromJSON` with 
+
+## Current limitations with recursive data
+
+Currently we cannot deal with recursive data types.  A type like
+
+```rescript
+type rec Node<'t> = Leave('t) | (Branch(array<Node<'t>>)
+```
+
+Cannot be automatically deserialized.
+
+
+## License
+
+The MIT License
+
+Copyright © 2022 Kaiko Systems GmbH and Collaborators
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the “Software”), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+

package/bsconfig.json

@@ -0,0 +1,19 @@
+{
+  "name": "rescript-deser",
+  "sources": [
+    {
+      "dir": "src/",
+      "subdirs": true
+    }
+  ],
+  "suffix": ".js",
+  "reason": {
+    "react-jsx": 3
+  },
+  "bs-dependencies": [
+    "@kaiko.io/rescript-prelude"
+  ],
+  "package-specs": {
+    "module": "es6"
+  }
+}

package/package.json

@@ -0,0 +1,15 @@
+{
+  "name": "@kaiko.io/rescript-deser",
+  "version": "1.0.0",
+  "description": "Simple JSON deserializer for ReScript",
+  "repository": "https://gitlab.com/kaiko-systems/bs-deser.git",
+  "author": "Kaiko Systems <info@kaikosystems.com>",
+  "license": "MIT",
+  "private": false,
+  "dependencies": {
+    "@kaiko.io/rescript-prelude": "^3.0.1"
+  },
+  "devDependencies": {
+    "rescript": "^10.0.1"
+  }
+}

package/src/JSON.res

@@ -0,0 +1,292 @@
+open Prelude
+
+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> => t = "%identity"
+  external mapping: Dict.t<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 BuiltDeserializer = {
+  type t
+  let name: string
+  let fromJSON: Js.Json.t => result<t, string>
+}
+
+module Field = {
+  type rec t =
+    | Any
+    | 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 Js.Date.fromFloat.
+    | 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(BuiltDeserializer))
+
+    /// 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(BuiltDeserializer))
+    | 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)
+
+  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 =>
+        raise(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 => raise(TypeError(`This String("${i}") not a valid value here. Hint: ${hint}`))
+      }
+    }),
+  )
+
+  let rec toString = (type_: t) =>
+    switch type_ {
+    | Any => "Any"
+    | String => "String"
+    | Int => "Integer"
+    | Float => "Float"
+    | Boolean => "Boolean"
+    | Datetime
+    | Date => "Date"
+    | Collection(m) => {
+        module M = unpack(m: BuiltDeserializer)
+        "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: BuiltDeserializer)
+        M.name
+      }
+
+    | DefaultWhenInvalid(t, _) => `Protected ${t->toString}`
+    }
+
+  let _taggedToString = (tagged: Js.Json.tagged_t) => {
+    switch tagged {
+    | Js.Json.JSONFalse => "Boolean(false)"
+    | Js.Json.JSONTrue => "Boolean(true)"
+    | Js.Json.JSONNull => "Null"
+    | Js.Json.JSONString(text) => `String("${text}")`
+    | Js.Json.JSONNumber(number) => `Number(${number->Float.toString})`
+    | Js.Json.JSONObject(obj) => `Object(${obj->Js.Json.stringifyAny->default("...")})`
+    | Js.Json.JSONArray(array) => `Array(${array->Js.Json.stringifyAny->default("...")})`
+    }
+  }
+
+  let rec extractValue = (values: Dict.t<Js.Json.t>, field: string, shape: t): FieldValue.t => {
+    switch values->Dict.get(field) {
+    | Some(value) => value->fromUntagged(shape)
+    | None =>
+      switch shape {
+      | DefaultWhenInvalid(_, _) => Js.Json.null->fromUntagged(shape)
+      | Optional(_) => Js.Json.null->fromUntagged(shape)
+      | OptionalWithDefault(_, default) => default
+      | _ => raise(TypeError(`Missing non-optional field '${field}'`))
+      }
+    }
+  }
+  and fromUntagged = (untagged: Js.Json.t, shape: t): FieldValue.t => {
+    switch (shape, untagged->Js.Json.classify) {
+    | (Any, _) => untagged->FieldValue.any
+    | (String, Js.Json.JSONString(text)) => FieldValue.string(text)
+    | (Int, Js.Json.JSONNumber(number)) => FieldValue.int(number->Float.toInt)
+    | (Float, Js.Json.JSONNumber(number)) => FieldValue.float(number)
+    | (Boolean, Js.Json.JSONTrue) => FieldValue.boolean(true)
+    | (Boolean, Js.Json.JSONFalse) => FieldValue.boolean(false)
+    | (Tuple(bases), Js.Json.JSONArray(items)) => {
+        let lenbases = bases->Array.length
+        let lenitems = items->Array.length
+        if lenbases == lenitems {
+          let values = Array.zipBy(items, bases, fromUntagged)
+          values->FieldValue.array
+        } else {
+          raise(
+            TypeError(`Expecting ${lenbases->Int.toString} items, got ${lenitems->Int.toString}`),
+          )
+        }
+      }
+
+    | (Datetime, Js.Json.JSONString(s))
+    | (Date, Js.Json.JSONString(s)) => {
+        let r = Js.Date.fromString(s)
+        if r->Js.Date.getDate->Js.Float.isNaN {
+          raise(TypeError(`Invalid date ${s}`))
+        }
+        r->FieldValue.any
+      }
+
+    | (Datetime, Js.Json.JSONNumber(f))
+    | (Date, Js.Json.JSONNumber(f)) => {
+        let r = Js.Date.fromFloat(f)
+        if r->Js.Date.getDate->Js.Float.isNaN {
+          raise(TypeError(`Invalid date ${f->Js.Float.toString}`))
+        }
+        r->FieldValue.any
+      }
+
+    | (Array(shape), Js.Json.JSONArray(items)) =>
+      FieldValue.array(items->Array.map(item => item->fromUntagged(shape)))
+    | (Mapping(f), Js.Json.JSONObject(values)) =>
+      values->Dict.mapValues(v => v->fromUntagged(f))->FieldValue.mapping
+    | (Object(fields), Js.Json.JSONObject(values)) =>
+      FieldValue.object(
+        fields
+        ->Array.map(((field, shape)) => {
+          let value = switch extractValue(values, field, shape) {
+          | value => value
+          | exception TypeError(msg) => raise(TypeError(`Field "${field}": ${msg}`))
+          }
+          (field, value)
+        })
+        ->Dict.fromArray,
+      )
+
+    | (OptionalWithDefault(_, value), Js.Json.JSONNull) => value
+    | (OptionalWithDefault(shape, _), _) => untagged->fromUntagged(shape)
+    | (Optional(_), Js.Json.JSONNull) => FieldValue.null
+    | (Optional(shape), _) => untagged->fromUntagged(shape)
+    | (Morphism(shape, f), _) => untagged->fromUntagged(shape)->f->FieldValue.any
+
+    | (Collection(m), Js.Json.JSONArray(items)) => {
+        module M = unpack(m: BuiltDeserializer)
+        items
+        ->Array.map(M.fromJSON)
+        ->Array.map(Result.warn)
+        ->Array.keepSome
+        ->Array.map(FieldValue.any)
+        ->FieldValue.array
+      }
+
+    | (Deserializer(m), _) => {
+        module M = unpack(m: BuiltDeserializer)
+        switch untagged->M.fromJSON {
+        | Ok(res) => res->FieldValue.any
+        | Error(msg) => raise(TypeError(msg))
+        }
+      }
+
+    | (DefaultWhenInvalid(t, default), _) =>
+      switch untagged->fromUntagged(t) {
+      | res => res
+      | exception TypeError(msg) => {
+          Js.Console.warn2("Detected and ignore (with default): ", msg)
+          default
+        }
+      }
+
+    | (expected, actual) =>
+      raise(TypeError(`Expected ${expected->toString}, but got ${actual->_taggedToString} instead`))
+    }
+  }
+}
+
+module type Serializable = {
+  type t
+  let fields: Field.t
+}
+
+module Deserializer = (S: Serializable) => {
+  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")
+
+  /// Parse a `Js.Json.t` into `result<t, string>`
+  let fromJSON = (json: Js.Json.t): result<t, _> => {
+    switch json->Field.fromUntagged(fields) {
+    | res => Ok(res->_toNativeType)
+    | exception TypeError(e) => Error(e)
+    }
+  }
+}
+
+module Test = {
+  type appointment = {
+    note: string,
+    date: Js.Date.t,
+  }
+  module Appointment = Deserializer({
+    type t = appointment
+    open Field
+
+    let fields = Object([("note", String), ("date", Date)])
+  })
+
+  type foo = array<appointment>
+  module Foo = Deserializer({
+    type t = foo
+    open Field
+
+    let fields = DefaultWhenInvalid(Array(Deserializer(module(Appointment))), []->FieldValue.array)
+  })
+}