From e7c28e402051ae94e257f6996c6f6fdd17bde1f7 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 9 Nov 2021 13:07:33 +0900 Subject: [PATCH 01/56] Initial commit for ReScript support --- README.md | 2 +- docs/rescript.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 docs/rescript.md diff --git a/README.md b/README.md index bc484ac9..77c15467 100644 --- a/README.md +++ b/README.md @@ -45,7 +45,7 @@ An in-browser version may be available in future. For users: - [Common options](docs/common_options.md) among all the targets - [ts2ocaml for js_of_ocaml](docs/js_of_ocaml.md) -- ts2ocaml for ReScript [(ongoing)](https://github.com/ocsigen/ts2ocaml/pull/32) +- [ts2ocaml for ReScript](docs/rescript.md) For developers and contributors: - [Overview for developers](docs/development.md) diff --git a/docs/rescript.md b/docs/rescript.md new file mode 100644 index 00000000..6d3f6659 --- /dev/null +++ b/docs/rescript.md @@ -0,0 +1 @@ +WIP \ No newline at end of file From bcfa7ce61d22b4840357b125502654bf6983ceaf Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 9 Nov 2021 19:45:08 +0900 Subject: [PATCH 02/56] Scaffolding, add minimal stdlib --- dist_rescript/.gitignore | 8 ++ dist_rescript/bsconfig.json | 18 ++++ dist_rescript/package-lock.json | 13 +++ dist_rescript/package.json | 17 ++++ dist_rescript/src/Ts2ocaml_min.res | 117 +++++++++++++++++++++++++ src/Common.fs | 2 +- src/Targets/ReScript/Common.fs | 8 ++ src/Targets/ReScript/ReScriptHelper.fs | 99 +++++++++++++++++++++ src/Targets/ReScript/Target.fs | 1 + src/Targets/ReScript/Writer.fs | 1 + src/ts2ocaml.fsproj | 4 + 11 files changed, 287 insertions(+), 1 deletion(-) create mode 100644 dist_rescript/.gitignore create mode 100644 dist_rescript/bsconfig.json create mode 100644 dist_rescript/package-lock.json create mode 100644 dist_rescript/package.json create mode 100644 dist_rescript/src/Ts2ocaml_min.res create mode 100644 src/Targets/ReScript/Common.fs create mode 100644 src/Targets/ReScript/ReScriptHelper.fs create mode 100644 src/Targets/ReScript/Target.fs create mode 100644 src/Targets/ReScript/Writer.fs diff --git a/dist_rescript/.gitignore b/dist_rescript/.gitignore new file mode 100644 index 00000000..3662f0f6 --- /dev/null +++ b/dist_rescript/.gitignore @@ -0,0 +1,8 @@ +.DS_Store +/node_modules/ +/lib/ +.bsb.lock +.merlin + +*.bs.js +Demo.res \ No newline at end of file diff --git a/dist_rescript/bsconfig.json b/dist_rescript/bsconfig.json new file mode 100644 index 00000000..50c249ca --- /dev/null +++ b/dist_rescript/bsconfig.json @@ -0,0 +1,18 @@ +{ + "name": "ts2ocaml-rescript-stdlib", + "version": "0.0.0", + "sources": { + "dir" : "src", + "subdirs" : true + }, + "package-specs": { + "module": "commonjs", + "in-source": true + }, + "suffix": ".bs.js", + "bs-dependencies": [ + ], + "warnings": { + "error" : "+101" + } +} diff --git a/dist_rescript/package-lock.json b/dist_rescript/package-lock.json new file mode 100644 index 00000000..a6ede281 --- /dev/null +++ b/dist_rescript/package-lock.json @@ -0,0 +1,13 @@ +{ + "name": "ts2ocaml-rescript-stdlib", + "version": "0.0.0", + "lockfileVersion": 1, + "requires": true, + "dependencies": { + "rescript": { + "version": "9.1.4", + "resolved": "https://registry.npmjs.org/rescript/-/rescript-9.1.4.tgz", + "integrity": "sha512-aXANK4IqecJzdnDpJUsU6pxMViCR5ogAxzuqS0mOr8TloMnzAjJFu63fjD6LCkWrKAhlMkFFzQvVQYaAaVkFXw==" + } + } +} diff --git a/dist_rescript/package.json b/dist_rescript/package.json new file mode 100644 index 00000000..8282c803 --- /dev/null +++ b/dist_rescript/package.json @@ -0,0 +1,17 @@ +{ + "name": "ts2ocaml-rescript-stdlib", + "version": "0.0.0", + "scripts": { + "build": "rescript", + "clean": "rescript clean -with-deps", + "start": "rescript build -w" + }, + "keywords": [ + "rescript" + ], + "author": "", + "license": "Apache-2.0", + "dependencies": { + "rescript": "*" + } +} diff --git a/dist_rescript/src/Ts2ocaml_min.res b/dist_rescript/src/Ts2ocaml_min.res new file mode 100644 index 00000000..14982290 --- /dev/null +++ b/dist_rescript/src/Ts2ocaml_min.res @@ -0,0 +1,117 @@ +@@warning("-27") + +type never + +module Never = { + type t = never + let absurd = (never: never) => Obj.magic(never) +} + +@unboxed type rec any = Any('a): any +let any = x => Any(x) + +module Any = { + type t = any + let unsafeCast = (x: any) => Obj.magic(x) +} + +type unknown + +module Unknown = { + type t = unknown + let unsafeCast = (x: unknown) => Obj.magic(x) +} + +type and_<'a, 'b> + +module And = { + type t<'a, 'b> = and_<'a, 'b> + let car = (x: t<'a, 'b>) : 'a => Obj.magic(x) + let cdr = (x: t<'a, 'b>) : 'b => Obj.magic(x) +} + +module Intersection = { + type t2<'t0, 't1> = and_<'t1, 't0> + type t3<'t0, 't1, 't2> = and_, 't0> + type t4<'t0, 't1, 't2, 't3> = and_, 't0> + type t5<'t0, 't1, 't2, 't3, 't4> = and_, 't0> + type t6<'t0, 't1, 't2, 't3, 't4, 't5> = and_, 't0> + type t7<'t0, 't1, 't2, 't3, 't4, 't5, 't6> = and_, 't0> + type t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7> = and_, 't0> + + let get0 = (x: t2<'t0, 't1>) : 't0 => And.cdr(x) + let get1 = (x: t3<'t0, 't1, 't2>) : 't1 => And.car(x)->get0 + let get2 = (x: t4<'t0, 't1, 't2, 't3>) : 't2 => And.car(x)->get1 + let get3 = (x: t5<'t0, 't1, 't2, 't3, 't4>) : 't3 => And.car(x)->get2 + let get4 = (x: t6<'t0, 't1, 't2, 't3, 't4, 't5>) : 't4 => And.car(x)->get3 + let get5 = (x: t7<'t0, 't1, 't2, 't3, 't4, 't5, 't6>) : 't5 => And.car(x)->get4 + let get6 = (x: t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7>) : 't6 => And.car(x)->get5 + let get7 = (x: t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7>) : 't7 => Obj.magic(x) +} + +type or<'a, 'b> + +module Or = { + type t<'a, 'b> = or<'a, 'b> + let inl = (a: 'a) : t<'a, 'b> => Obj.magic(a) + let inr = (b: 'b) : t<'a, 'b> => Obj.magic(b) + + let test = (x: t<'a, 'b>, isLeft: any => bool, isRight: any => bool) : [ #Left('a) | #Right('b) | #Other(any) ] => { + let x = any(x) + if isLeft(x) { #Left(Any.unsafeCast(x)) } + else if isRight(x) { #Right(Any.unsafeCast(x)) } + else { #Other(x) } + } +} + +module Union = { + type t2<'t0, 't1> = or<'t1, 't0> + type t3<'t0, 't1, 't2> = or, 't0> + type t4<'t0, 't1, 't2, 't3> = or, 't0> + type t5<'t0, 't1, 't2, 't3, 't4> = or, 't0> + type t6<'t0, 't1, 't2, 't3, 't4, 't5> = or, 't0> + type t7<'t0, 't1, 't2, 't3, 't4, 't5, 't6> = or, 't0> + type t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7> = or, 't0> + + let inject0 = (x: 't0) : t2<'t0, 't1> => Or.inr(x) + let inject1 = (x: 't1) : t3<'t0, 't1, 't2> => inject0(x)->Or.inl + let inject2 = (x: 't2) : t4<'t0, 't1, 't2, 't3> => inject1(x)->Or.inl + let inject3 = (x: 't3) : t5<'t0, 't1, 't2, 't3, 't4> => inject2(x)->Or.inl + let inject4 = (x: 't4) : t6<'t0, 't1, 't2, 't3, 't4, 't5> => inject3(x)->Or.inl + let inject5 = (x: 't5) : t7<'t0, 't1, 't2, 't3, 't4, 't5, 't6> => inject4(x)->Or.inl + let inject6 = (x: 't6) : t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7> => inject5(x)->Or.inl + let inject7 = (x: 't7) : t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7> => Obj.magic(x) +} + +type symbol = Js.Types.symbol +type bigint + +@unboxed type intf<-'tags, 'a> = { value: 'a } + +module JsInterop = { + let apply0 = (. it: 'Function) => %raw(`it()`) + let apply1 = (. it: 'Function, arg0) => %raw(`it(arg0)`) + let apply2 = (. it: 'Function, arg0, arg1) => %raw(`it(arg0, arg1)`) + let apply3 = (. it: 'Function, arg0, arg1, arg2) => %raw(`it(arg0, arg1, arg2)`) + let apply4 = (. it: 'Function, arg0, arg1, arg2, arg3) => %raw(`it(arg0, arg1, arg2, arg3)`) + let apply5 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4) => %raw(`it(arg0, arg1, arg2, arg3, arg4)`) + let apply6 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5)`) + let apply7 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) + let applyN = (. it: 'Function, args: array) => %raw(`it(...args)`) + + let applyNewable0 = (. it: 'Function) => %raw(`new it()`) + let applyNewable1 = (. it: 'Function, arg0) => %raw(`new it(arg0)`) + let applyNewable2 = (. it: 'Function, arg0, arg1) => %raw(`new it(arg0, arg1)`) + let applyNewable3 = (. it: 'Function, arg0, arg1, arg2) => %raw(`new it(arg0, arg1, arg2)`) + let applyNewable4 = (. it: 'Function, arg0, arg1, arg2, arg3) => %raw(`new it(arg0, arg1, arg2, arg3)`) + let applyNewable5 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4) => %raw(`new it(arg0, arg1, arg2, arg3, arg4)`) + let applyNewable6 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5)`) + let applyNewable7 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) + let applyNewableN = (. it: 'NewableFunction, args: array) => %raw(`new it(...args)`) + + module PolyVariant = { + let name = (. it: 'PolyVariant) => %raw(`it.NAME`) + let value = (. it: 'PolyVariant) => %raw(`it.VAL`) + let make = (. name: string, value: 'a) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`) + } +} diff --git a/src/Common.fs b/src/Common.fs index 886a2c06..8a0ee606 100644 --- a/src/Common.fs +++ b/src/Common.fs @@ -82,4 +82,4 @@ module GlobalOptions = .addFlag("nowarn", (fun (o: GlobalOptions) -> o.nowarn), descr="Do not show warnings") type IContext<'Options when 'Options :> IOptions> = Ts2Ml.Common.IContext<'Options> -type OverloadRenamer = Ts2Ml.Common.OverloadRenamer \ No newline at end of file +type OverloadRenamer = Ts2Ml.Common.OverloadRenamer diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs new file mode 100644 index 00000000..9405c794 --- /dev/null +++ b/src/Targets/ReScript/Common.fs @@ -0,0 +1,8 @@ +module Targets.ReScript.Common + +type Options = + inherit GlobalOptions + inherit Typer.TyperOptions + // code generator options + abstract numberAsInt: bool with get, set + abstract safeArity: FeatureFlag with get, set \ No newline at end of file diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs new file mode 100644 index 00000000..22743461 --- /dev/null +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -0,0 +1,99 @@ +module Targets.ReScript.ReScriptHelper + +open System +open Syntax +open Targets.ReScript.Common +open DataTypes +open DataTypes.Text + +let comment text = + if text = empty then empty + else + let inner = + if isMultiLine text then newline + indent text + newline + else between " " " " text + between "/*" "*/" inner +let commentStr text = tprintf "/* %s */" text + +[] +module Type = + // primitive types + let void_ = str "unit" + let string = str "string" + let boolean = str "bool" + let number (opt: Options) = + if opt.numberAsInt then str "int" + else str "float" + let array = str "array" + let readonlyArray = str "array" + + // JS types + // ES5 + let object = str "Js.Types.obj_val" + let function_ = str "Js.Types.function_val" + let symbol = str "Js.Types.symbol" + let regexp = str "Js.Re.t" + // ES2020 + let bigint = str "bigint" + + // TS types + let never = str "never" + let any = str "any" + let unknown = str "unknown" + let null_ = str "Js.null" + let undefined = str "Js.undefined" + let null_undefined = str "Js.nullable" + + let var s = tprintf "'%s" s + + let tuple = function + | [] -> failwith "empty tuple" + | _ :: [] -> failwith "1-ary tuple" + | xs -> concat (str ", ") xs |> between "(" ")" + + /// `(t1, t2) => tr` + let curriedArrow args ret = + let lhs = + match args with + | [] -> failwith "0-ary function" + | [x] -> x + | xs -> concat (str ", ") xs |> between "(" ")" + lhs +@ " => " + ret + + /// `(.t1, t2) => tr` + let uncurriedArrow args ret = + let lhs = + match args with + | [] -> failwith "0-ary function" + | xs -> concat (str ", ") xs |> between "(." ")" + lhs +@ " => " + ret + + let app t args = + if List.isEmpty args then failwith "type application with empty arguments" + else t + between "<" ">" (concat (str ", ") args) + + let appOpt t args = + if List.isEmpty args then t + else app t args + + let and_ a b = app (str "and_") [a; b] + let or_ a b = app (str "or_") [a; b] + + let union types = + let l = List.length types + if l < 1 then failwith "union type with only zero or one type" + else + let rec go i = function + | h :: t when i > 8 -> or_ (go (i-1) t) h + | xs -> app (tprintf "Union.t%i" i) xs + go l types + + let intersection types = + let l = List.length types + if l < 1 then failwith "union type with only zero or one type" + else + let rec go i = function + | h :: t when i > 8 -> and_ (go (i-1) t) h + | xs -> app (tprintf "Intersection.t%i" i) xs + go l types + diff --git a/src/Targets/ReScript/Target.fs b/src/Targets/ReScript/Target.fs new file mode 100644 index 00000000..f81effac --- /dev/null +++ b/src/Targets/ReScript/Target.fs @@ -0,0 +1 @@ +module Targets.ReScript.Target \ No newline at end of file diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs new file mode 100644 index 00000000..deaab70f --- /dev/null +++ b/src/Targets/ReScript/Writer.fs @@ -0,0 +1 @@ +module Targets.ReScript.Writer \ No newline at end of file diff --git a/src/ts2ocaml.fsproj b/src/ts2ocaml.fsproj index 4bb7f2ab..5d99e282 100644 --- a/src/ts2ocaml.fsproj +++ b/src/ts2ocaml.fsproj @@ -13,6 +13,10 @@ + + + + From 157dcfdb6a380cd93dfec77627e95a269b0bcd9c Mon Sep 17 00:00:00 2001 From: cannorin Date: Fri, 21 Jan 2022 17:15:09 +0900 Subject: [PATCH 03/56] Merge main --- src/Targets/ReScript/Common.fs | 2 ++ src/Targets/ReScript/ReScriptHelper.fs | 1 + 2 files changed, 3 insertions(+) diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 9405c794..24286840 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -1,5 +1,7 @@ module Targets.ReScript.Common +open Ts2Ml + type Options = inherit GlobalOptions inherit Typer.TyperOptions diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 22743461..30487856 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -1,6 +1,7 @@ module Targets.ReScript.ReScriptHelper open System +open Ts2Ml open Syntax open Targets.ReScript.Common open DataTypes From 5c699fc942825a4678eb6d8cedbd771e91e3b4a7 Mon Sep 17 00:00:00 2001 From: cannorin Date: Fri, 21 Jan 2022 18:25:23 +0900 Subject: [PATCH 04/56] Allow arbitrary type for name of poly variant --- dist_rescript/src/Ts2ocaml_min.res | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/dist_rescript/src/Ts2ocaml_min.res b/dist_rescript/src/Ts2ocaml_min.res index 14982290..e1ec4611 100644 --- a/dist_rescript/src/Ts2ocaml_min.res +++ b/dist_rescript/src/Ts2ocaml_min.res @@ -99,19 +99,19 @@ module JsInterop = { let apply7 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) let applyN = (. it: 'Function, args: array) => %raw(`it(...args)`) - let applyNewable0 = (. it: 'Function) => %raw(`new it()`) - let applyNewable1 = (. it: 'Function, arg0) => %raw(`new it(arg0)`) - let applyNewable2 = (. it: 'Function, arg0, arg1) => %raw(`new it(arg0, arg1)`) - let applyNewable3 = (. it: 'Function, arg0, arg1, arg2) => %raw(`new it(arg0, arg1, arg2)`) - let applyNewable4 = (. it: 'Function, arg0, arg1, arg2, arg3) => %raw(`new it(arg0, arg1, arg2, arg3)`) - let applyNewable5 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4) => %raw(`new it(arg0, arg1, arg2, arg3, arg4)`) - let applyNewable6 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5)`) - let applyNewable7 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) - let applyNewableN = (. it: 'NewableFunction, args: array) => %raw(`new it(...args)`) + let applyNewable0 = (. it: 'Newable) => %raw(`new it()`) + let applyNewable1 = (. it: 'Newable, arg0) => %raw(`new it(arg0)`) + let applyNewable2 = (. it: 'Newable, arg0, arg1) => %raw(`new it(arg0, arg1)`) + let applyNewable3 = (. it: 'Newable, arg0, arg1, arg2) => %raw(`new it(arg0, arg1, arg2)`) + let applyNewable4 = (. it: 'Newable, arg0, arg1, arg2, arg3) => %raw(`new it(arg0, arg1, arg2, arg3)`) + let applyNewable5 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4) => %raw(`new it(arg0, arg1, arg2, arg3, arg4)`) + let applyNewable6 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5)`) + let applyNewable7 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) + let applyNewableN = (. it: 'Newable, args: array) => %raw(`new it(...args)`) module PolyVariant = { - let name = (. it: 'PolyVariant) => %raw(`it.NAME`) - let value = (. it: 'PolyVariant) => %raw(`it.VAL`) - let make = (. name: string, value: 'a) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`) + let name = (. it: 'PolyVariant) : 'name => %raw(`it.NAME`) + let value = (. it: 'PolyVariant) : 'value => %raw(`it.VAL`) + let make = (. name: 'name, value: 'value) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`) } } From 43d4ec68e77dcc362ccc273633ab8acfc940f5a4 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 15 Feb 2022 18:53:25 +0900 Subject: [PATCH 05/56] Rewrite stdlib --- dist_rescript/src/Ts.res | 1 + dist_rescript/src/Ts2ocaml_min.res | 117 ------------------- dist_rescript/src/Ts__min.res | 155 +++++++++++++++++++++++++ src/Targets/ReScript/ReScriptHelper.fs | 89 +++++++------- 4 files changed, 200 insertions(+), 162 deletions(-) create mode 100644 dist_rescript/src/Ts.res delete mode 100644 dist_rescript/src/Ts2ocaml_min.res create mode 100644 dist_rescript/src/Ts__min.res diff --git a/dist_rescript/src/Ts.res b/dist_rescript/src/Ts.res new file mode 100644 index 00000000..95172239 --- /dev/null +++ b/dist_rescript/src/Ts.res @@ -0,0 +1 @@ +include Ts__min \ No newline at end of file diff --git a/dist_rescript/src/Ts2ocaml_min.res b/dist_rescript/src/Ts2ocaml_min.res deleted file mode 100644 index e1ec4611..00000000 --- a/dist_rescript/src/Ts2ocaml_min.res +++ /dev/null @@ -1,117 +0,0 @@ -@@warning("-27") - -type never - -module Never = { - type t = never - let absurd = (never: never) => Obj.magic(never) -} - -@unboxed type rec any = Any('a): any -let any = x => Any(x) - -module Any = { - type t = any - let unsafeCast = (x: any) => Obj.magic(x) -} - -type unknown - -module Unknown = { - type t = unknown - let unsafeCast = (x: unknown) => Obj.magic(x) -} - -type and_<'a, 'b> - -module And = { - type t<'a, 'b> = and_<'a, 'b> - let car = (x: t<'a, 'b>) : 'a => Obj.magic(x) - let cdr = (x: t<'a, 'b>) : 'b => Obj.magic(x) -} - -module Intersection = { - type t2<'t0, 't1> = and_<'t1, 't0> - type t3<'t0, 't1, 't2> = and_, 't0> - type t4<'t0, 't1, 't2, 't3> = and_, 't0> - type t5<'t0, 't1, 't2, 't3, 't4> = and_, 't0> - type t6<'t0, 't1, 't2, 't3, 't4, 't5> = and_, 't0> - type t7<'t0, 't1, 't2, 't3, 't4, 't5, 't6> = and_, 't0> - type t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7> = and_, 't0> - - let get0 = (x: t2<'t0, 't1>) : 't0 => And.cdr(x) - let get1 = (x: t3<'t0, 't1, 't2>) : 't1 => And.car(x)->get0 - let get2 = (x: t4<'t0, 't1, 't2, 't3>) : 't2 => And.car(x)->get1 - let get3 = (x: t5<'t0, 't1, 't2, 't3, 't4>) : 't3 => And.car(x)->get2 - let get4 = (x: t6<'t0, 't1, 't2, 't3, 't4, 't5>) : 't4 => And.car(x)->get3 - let get5 = (x: t7<'t0, 't1, 't2, 't3, 't4, 't5, 't6>) : 't5 => And.car(x)->get4 - let get6 = (x: t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7>) : 't6 => And.car(x)->get5 - let get7 = (x: t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7>) : 't7 => Obj.magic(x) -} - -type or<'a, 'b> - -module Or = { - type t<'a, 'b> = or<'a, 'b> - let inl = (a: 'a) : t<'a, 'b> => Obj.magic(a) - let inr = (b: 'b) : t<'a, 'b> => Obj.magic(b) - - let test = (x: t<'a, 'b>, isLeft: any => bool, isRight: any => bool) : [ #Left('a) | #Right('b) | #Other(any) ] => { - let x = any(x) - if isLeft(x) { #Left(Any.unsafeCast(x)) } - else if isRight(x) { #Right(Any.unsafeCast(x)) } - else { #Other(x) } - } -} - -module Union = { - type t2<'t0, 't1> = or<'t1, 't0> - type t3<'t0, 't1, 't2> = or, 't0> - type t4<'t0, 't1, 't2, 't3> = or, 't0> - type t5<'t0, 't1, 't2, 't3, 't4> = or, 't0> - type t6<'t0, 't1, 't2, 't3, 't4, 't5> = or, 't0> - type t7<'t0, 't1, 't2, 't3, 't4, 't5, 't6> = or, 't0> - type t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7> = or, 't0> - - let inject0 = (x: 't0) : t2<'t0, 't1> => Or.inr(x) - let inject1 = (x: 't1) : t3<'t0, 't1, 't2> => inject0(x)->Or.inl - let inject2 = (x: 't2) : t4<'t0, 't1, 't2, 't3> => inject1(x)->Or.inl - let inject3 = (x: 't3) : t5<'t0, 't1, 't2, 't3, 't4> => inject2(x)->Or.inl - let inject4 = (x: 't4) : t6<'t0, 't1, 't2, 't3, 't4, 't5> => inject3(x)->Or.inl - let inject5 = (x: 't5) : t7<'t0, 't1, 't2, 't3, 't4, 't5, 't6> => inject4(x)->Or.inl - let inject6 = (x: 't6) : t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7> => inject5(x)->Or.inl - let inject7 = (x: 't7) : t8<'t0, 't1, 't2, 't3, 't4, 't5, 't6, 't7> => Obj.magic(x) -} - -type symbol = Js.Types.symbol -type bigint - -@unboxed type intf<-'tags, 'a> = { value: 'a } - -module JsInterop = { - let apply0 = (. it: 'Function) => %raw(`it()`) - let apply1 = (. it: 'Function, arg0) => %raw(`it(arg0)`) - let apply2 = (. it: 'Function, arg0, arg1) => %raw(`it(arg0, arg1)`) - let apply3 = (. it: 'Function, arg0, arg1, arg2) => %raw(`it(arg0, arg1, arg2)`) - let apply4 = (. it: 'Function, arg0, arg1, arg2, arg3) => %raw(`it(arg0, arg1, arg2, arg3)`) - let apply5 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4) => %raw(`it(arg0, arg1, arg2, arg3, arg4)`) - let apply6 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5)`) - let apply7 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) - let applyN = (. it: 'Function, args: array) => %raw(`it(...args)`) - - let applyNewable0 = (. it: 'Newable) => %raw(`new it()`) - let applyNewable1 = (. it: 'Newable, arg0) => %raw(`new it(arg0)`) - let applyNewable2 = (. it: 'Newable, arg0, arg1) => %raw(`new it(arg0, arg1)`) - let applyNewable3 = (. it: 'Newable, arg0, arg1, arg2) => %raw(`new it(arg0, arg1, arg2)`) - let applyNewable4 = (. it: 'Newable, arg0, arg1, arg2, arg3) => %raw(`new it(arg0, arg1, arg2, arg3)`) - let applyNewable5 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4) => %raw(`new it(arg0, arg1, arg2, arg3, arg4)`) - let applyNewable6 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5)`) - let applyNewable7 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) - let applyNewableN = (. it: 'Newable, args: array) => %raw(`new it(...args)`) - - module PolyVariant = { - let name = (. it: 'PolyVariant) : 'name => %raw(`it.NAME`) - let value = (. it: 'PolyVariant) : 'value => %raw(`it.VAL`) - let make = (. name: 'name, value: 'value) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`) - } -} diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/Ts__min.res new file mode 100644 index 00000000..8842bdfa --- /dev/null +++ b/dist_rescript/src/Ts__min.res @@ -0,0 +1,155 @@ +@@warning("-27") + +type never + +module Never = { + type t = never + exception Never + let absurd : t => 'a = x => raise(Never) +} + +type any +let any : 'a => any = Obj.magic + +module Any = { + type t = any + let unsafeCast : t => 'a = x => Obj.magic(x) +} + +type unknown + +module Unknown = { + type t = unknown + let unsafeCast = (x: t) => Obj.magic(x) +} + +type untyped_object = Js.Types.obj_val +type untyped_function = Js.Types.function_val +type symbol = Js.Types.symbol +type regexp = Js.Re.t +type bigint + +type null<+'a> = Js.null<'a> +type undefined<+'a> = Js.undefined<'a> +type nullable<+'a> = Js.nullable<'a> + +module Union = { + type t<+'cases> + + let return1 : 't1 => t<[> #U1('t1)]> = x => Obj.magic(x) + let return2 : 't2 => t<[> #U2('t2)]> = x => Obj.magic(x) + let return3 : 't3 => t<[> #U3('t3)]> = x => Obj.magic(x) + let return4 : 't4 => t<[> #U4('t4)]> = x => Obj.magic(x) + let return5 : 't5 => t<[> #U5('t5)]> = x => Obj.magic(x) + let return6 : 't6 => t<[> #U6('t6)]> = x => Obj.magic(x) + let return7 : 't7 => t<[> #U7('t7)]> = x => Obj.magic(x) + let return8 : 't8 => t<[> #U8('t8)]> = x => Obj.magic(x) + + let getUnsafe1 : t<[> #U1('t1)]> => 't1 = x => Obj.magic(x) + let getUnsafe2 : t<[> #U2('t2)]> => 't2 = x => Obj.magic(x) + let getUnsafe3 : t<[> #U3('t3)]> => 't3 = x => Obj.magic(x) + let getUnsafe4 : t<[> #U4('t4)]> => 't4 = x => Obj.magic(x) + let getUnsafe5 : t<[> #U5('t5)]> => 't5 = x => Obj.magic(x) + let getUnsafe6 : t<[> #U6('t6)]> => 't6 = x => Obj.magic(x) + let getUnsafe7 : t<[> #U7('t7)]> => 't7 = x => Obj.magic(x) + let getUnsafe8 : t<[> #U8('t8)]> => 't8 = x => Obj.magic(x) +} +type union2<'t1, 't2> = Union.t<[ #U1('t1) | #U2('t2) ]> +type union3<'t1, 't2, 't3> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) ]> +type union4<'t1, 't2, 't3, 't4> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) ]> +type union5<'t1, 't2, 't3, 't4, 't5> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) ]> +type union6<'t1, 't2, 't3, 't4, 't5, 't6> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) ]> +type union7<'t1, 't2, 't3, 't4, 't5, 't6, 't7> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) | #U7('t7) ]> +type union8<'t1, 't2, 't3, 't4, 't5, 't6, 't7, 't8> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) | #U7('t7) | #U8('t8) ]> + +module Intersection = { + type t<-'cases> + + let get1 : t<[> #I1('t1)]> => 't1 = x => Obj.magic(x) + let get2 : t<[> #I2('t2)]> => 't2 = x => Obj.magic(x) + let get3 : t<[> #I3('t3)]> => 't3 = x => Obj.magic(x) + let get4 : t<[> #I4('t4)]> => 't4 = x => Obj.magic(x) + let get5 : t<[> #I5('t5)]> => 't5 = x => Obj.magic(x) + let get6 : t<[> #I6('t6)]> => 't6 = x => Obj.magic(x) + let get7 : t<[> #I7('t7)]> => 't7 = x => Obj.magic(x) + let get8 : t<[> #I8('t8)]> => 't8 = x => Obj.magic(x) +} +type intersection2<'t1, 't2> = Intersection.t<[ #I1('t1) | #I2('t2) ]> +type intersection3<'t1, 't2, 't3> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) ]> +type intersection4<'t1, 't2, 't3, 't4> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) ]> +type intersection5<'t1, 't2, 't3, 't4, 't5> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) ]> +type intersection6<'t1, 't2, 't3, 't4, 't5, 't6> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) ]> +type intersection7<'t1, 't2, 't3, 't4, 't5, 't6, 't7> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) | #I7('t7) ]> +type intersection8<'t1, 't2, 't3, 't4, 't5, 't6, 't7, 't8> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) | #I7('t7) | #I8('t8) ]> + +module Interface = { + @unboxed type t<-'tags, 'base> = { value: 'base } + + let value = (x: t<_, _>) => x.value +} +type intf<-'tags, 'base> = Interface.t<'tags, 'base> + +module Primitive = { + type cases<'other> = [ #Null | #Undefined | #String(string) | #Number(float) | #Boolean(bool) | #Symbol(symbol) | #BigInt(bigint) | #Other('other) ] + type t<+'cases> + + let return: ([< cases<'other>] as 'cases) => t<'cases> = x => + %raw(`(function (x) { + switch (x) { + case 'null' | 'Null': return null; + case 'undefined' | 'Undefined': return; + default: return x.VAL; + } + })(x)`) + + let fromNull: null<'a> => t<[> #Null | #Other('a) ]> = Obj.magic + let toNull: t<[< #Null | #Other('a) ]> => null<'a> = Obj.magic + + let fromUndefined: undefined<'a> => t<[> #Undefined | #Other('a) ]> = Obj.magic + let toUndefined: t<[< #Undefined | #Other('a) ]> => undefined<'a> = Obj.magic + + let fromNullable: nullable<'a> => t<[> #Null | #Undefined | #Other('a) ]> = Obj.magic + let toNullable: t<[< #Null | #Undefined | #Other('a) ]> => nullable<'a> = Obj.magic + + let classify: t<[< cases<'other>] as 'cases> => 'cases = x => + switch (Js.typeof(x)) { + | "string" => Obj.magic(#String(Obj.magic(x))) + | "number" => Obj.magic(#Number(Obj.magic(x))) + | "boolean" => Obj.magic(#Boolean(Obj.magic(x))) + | "symbol" => Obj.magic(#Symbol(Obj.magic(x))) + | "bigint" => Obj.magic(#BigInt(Obj.magic(x))) + | "undefined" => Obj.magic(#Undefined) + | _ => + if (Js.testAny(x)) { Obj.magic(#Null) } + else { Obj.magic(#Other(x)) } + } +} +type prim<+'cases> = Primitive.t<'cases> + +module Interop = { + let apply0 = (. it: 'Function) => %raw(`it()`) + let apply1 = (. it: 'Function, arg0) => %raw(`it(arg0)`) + let apply2 = (. it: 'Function, arg0, arg1) => %raw(`it(arg0, arg1)`) + let apply3 = (. it: 'Function, arg0, arg1, arg2) => %raw(`it(arg0, arg1, arg2)`) + let apply4 = (. it: 'Function, arg0, arg1, arg2, arg3) => %raw(`it(arg0, arg1, arg2, arg3)`) + let apply5 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4) => %raw(`it(arg0, arg1, arg2, arg3, arg4)`) + let apply6 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5)`) + let apply7 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) + let applyN = (. it: 'Function, args: array) => %raw(`it(...args)`) + + let applyNewable0 = (. it: 'Newable) => %raw(`new it()`) + let applyNewable1 = (. it: 'Newable, arg0) => %raw(`new it(arg0)`) + let applyNewable2 = (. it: 'Newable, arg0, arg1) => %raw(`new it(arg0, arg1)`) + let applyNewable3 = (. it: 'Newable, arg0, arg1, arg2) => %raw(`new it(arg0, arg1, arg2)`) + let applyNewable4 = (. it: 'Newable, arg0, arg1, arg2, arg3) => %raw(`new it(arg0, arg1, arg2, arg3)`) + let applyNewable5 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4) => %raw(`new it(arg0, arg1, arg2, arg3, arg4)`) + let applyNewable6 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5)`) + let applyNewable7 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) + let applyNewableN = (. it: 'Newable, args: array) => %raw(`new it(...args)`) + + module PolyVariant = { + let name = (. it: 'PolyVariant) : 'name => %raw(`it.NAME`) + let value = (. it: 'PolyVariant) : 'value => %raw(`it.VAL`) + let make = (. name: 'name, value: 'value) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`) + } +} \ No newline at end of file diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 30487856..a9af7517 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -18,33 +18,7 @@ let commentStr text = tprintf "/* %s */" text [] module Type = - // primitive types - let void_ = str "unit" - let string = str "string" - let boolean = str "bool" - let number (opt: Options) = - if opt.numberAsInt then str "int" - else str "float" - let array = str "array" - let readonlyArray = str "array" - - // JS types - // ES5 - let object = str "Js.Types.obj_val" - let function_ = str "Js.Types.function_val" - let symbol = str "Js.Types.symbol" - let regexp = str "Js.Re.t" - // ES2020 - let bigint = str "bigint" - - // TS types - let never = str "never" - let any = str "any" - let unknown = str "unknown" - let null_ = str "Js.null" - let undefined = str "Js.undefined" - let null_undefined = str "Js.nullable" - + // basic type expressions let var s = tprintf "'%s" s let tuple = function @@ -77,24 +51,49 @@ module Type = if List.isEmpty args then t else app t args - let and_ a b = app (str "and_") [a; b] - let or_ a b = app (str "or_") [a; b] + // primitive types + let void_ = str "unit" + let string = str "string" + let boolean = str "bool" + let number (opt: Options) = + if opt.numberAsInt then str "int" + else str "float" + let array = str "array" + let readonlyArray = str "array" + + // JS types + // ES5 + let object = str "untyped_object" + let function_ = str "untyped_function" + let symbol = str "symbol" + let regexp = str "regexp" + // ES2020 + let bigint = str "bigint" + + // TS types + let never = str "never" + let any = str "any" + let unknown = str "unknown" + let null_or t = app (str "null") [t] + let undefined_or t = app (str "undefined") [t] + let null_or_undefined_or t = app (str "nullable") [t] + let null_ = null_or never + let undefined = undefined_or never - let union types = - let l = List.length types - if l < 1 then failwith "union type with only zero or one type" - else - let rec go i = function - | h :: t when i > 8 -> or_ (go (i-1) t) h - | xs -> app (tprintf "Union.t%i" i) xs - go l types + // our types + let intf tags baseTy = app (str "intf") [tags; baseTy] + let prim cases = app (str "prim") [cases] - let intersection types = - let l = List.length types - if l < 1 then failwith "union type with only zero or one type" - else - let rec go i = function - | h :: t when i > 8 -> and_ (go (i-1) t) h - | xs -> app (tprintf "Intersection.t%i" i) xs - go l types + let rec union = function + | [] -> failwith "union type with zero elements" + | x :: [] -> x + | x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: rest -> + app (str "union8") [x1; x2; x3; x4; x5; x6; x7; union (x8 :: rest)] + | xs -> app (tprintf "union%i" (List.length xs)) xs + let rec intersection = function + | [] -> failwith "intersection type with zero elements" + | x :: [] -> x + | x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: rest -> + app (str "intersection8") [x1; x2; x3; x4; x5; x6; x7; intersection (x8 :: rest)] + | xs -> app (tprintf "intersection%i" (List.length xs)) xs From 17773fe73b77096041f91fea8436d0eef2f80690 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 15 Feb 2022 20:35:29 +0900 Subject: [PATCH 06/56] More helpers --- src/Targets/ReScript/ReScriptHelper.fs | 122 ++++++++++++++++++++++++- 1 file changed, 121 insertions(+), 1 deletion(-) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index a9af7517..d35790a4 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -16,8 +16,102 @@ let comment text = between "/*" "*/" inner let commentStr text = tprintf "/* %s */" text +module Attr = + let as_ value = between "@as(" ")" value + + module External = + /// https://rescript-lang.org/docs/manual/latest/import-from-export-to-js#import-from-javascript + let module_ nameOpt = + match nameOpt with + | Some name -> tprintf "@module(\"%s\")" name + | None -> str "@module" + + /// https://rescript-lang.org/docs/manual/latest/bind-to-global-js-values#global-modules + let val_ = str "@val" + + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#object-method + let send = str "@send" + + let scope = function + | [] -> failwith "empty scope" + | [s] -> tprintf "@scope(\"%s\")" s + | ss -> + ss |> List.map (tprintf "\"%s\"") + |> concat (str ", ") |> between "@scope((" "))" + + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-object#bind-to-a-js-object-thats-a-class + let new_ = str "@new" + + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-object#bind-using-special-getter-and-setter-attributes + let get_ = str "@get" + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-object#bind-using-special-getter-and-setter-attributes + let set_ = str "@set" + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-object#bind-using-special-getter-and-setter-attributes + let get_index = str "@get_index" + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-object#bind-using-special-getter-and-setter-attributes + let set_index = str "@set_index" + + module ExternalModifier = + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#variadic-function-arguments + let variadic = str "@variadic" + + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#constrain-arguments-better + let return_nullable = str "@return(nullable)" + + module Doc = + /// https://rescript-lang.org/docs/manual/latest/attribute#usage + let deprecated = function + | None -> str "@deprecated" + | Some msg -> tprintf "@deprecated(\"%s\")" (String.escape msg) + + let floating msg = + tprintf "@@ocaml.text(\"%s\")" (String.escape msg) + + let doc msg = + tprintf "@ocaml.doc(\"%s\")" (String.escape msg) + + module Arrow = + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#extra-solution + let uncurry = str "@uncurry" + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#modeling-this-based-callbacks + let this = str "@this" + + module PolyVariant = + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#constrain-arguments-better + let int = str "@int" + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#constrain-arguments-better + let string = str "@string" + /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#trick-2-polymorphic-variant--unwrap + let unwrap = str "@unwrap" + + module TypeDef = + /// https://rescript-lang.org/docs/manual/latest/unboxed + let unboxed = str "@unboxed" + [] module Type = + /// non-primitive types defined in the standard library + let predefinedTypes = + let typedArray name = name, sprintf "Js.TypedArray2.%s.t" name + Map.ofList [ + "RegExp", "Js.Re.t" + "Date", "Js.Date.t" + "Promise", "Js.Promise.t" (* arity 1 *) + "Array", "Js.Array.t" (* arity 1*) + "ArrayLike", "Js.TypedArray2.array_like" (* arity 1 *) + "ArrayBuffer", "Js.TypedArray2.array_buffer" + typedArray "DataView" + typedArray "Int8Array" + typedArray "Uint8Array" + typedArray "Uint8ClampedArray" + typedArray "Int16Array" + typedArray "Uint16Array" + typedArray "Int32Array" + typedArray "Uint32Array" + typedArray "Float32Array" + typedArray "Float64Array" + ] + // basic type expressions let var s = tprintf "'%s" s @@ -40,7 +134,7 @@ module Type = let lhs = match args with | [] -> failwith "0-ary function" - | xs -> concat (str ", ") xs |> between "(." ")" + | xs -> concat (str ", ") xs |> between "(. " ")" lhs +@ " => " + ret let app t args = @@ -97,3 +191,29 @@ module Type = | x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: rest -> app (str "intersection8") [x1; x2; x3; x4; x5; x6; x7; intersection (x8 :: rest)] | xs -> app (tprintf "intersection%i" (List.length xs)) xs + +[] +module Term = + let tuple = function + | [] -> failwith "empty tuple" + | _ :: [] -> failwith "1-ary tuple" + | xs -> concat (str ", ") xs |> between "(" ")" + + let appCurried t us = t + (us |> concat (str ", ") |> between "(" ")") + let appUncurried t us = t + (us |> concat (str ", ") |> between "(. " ")") + + let literal (l: Literal) = + match l with + | LBool true -> str "true" | LBool false -> str "false" + | LInt i -> string i |> str + | LFloat f -> tprintf "%f" f + | LString s -> tprintf "\"%s\"" (String.escape s) + + let raw js = between "%raw(`" "`)" js + +let let_ name typ body = + tprintf "let %s: " name + typ +@ " = " + body + +let external (attrs: text list) name (typ: text) target = + concat (str " ") attrs + + tprintf " external %s: " name + typ + tprintf " = \"%s\"" target \ No newline at end of file From 9cab6e67b90ea5e0cd030dbdce217dac4fb65805 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 21 Feb 2022 19:46:06 +0900 Subject: [PATCH 07/56] Add type emitter --- dist_rescript/src/Ts__min.res | 115 +++++++-- src/Targets/ReScript/Common.fs | 3 +- src/Targets/ReScript/ReScriptHelper.fs | 119 +++++++++ src/Targets/ReScript/Writer.fs | 328 ++++++++++++++++++++++++- 4 files changed, 541 insertions(+), 24 deletions(-) diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/Ts__min.res index 8842bdfa..8b2d6563 100644 --- a/dist_rescript/src/Ts__min.res +++ b/dist_rescript/src/Ts__min.res @@ -28,6 +28,8 @@ type untyped_function = Js.Types.function_val type symbol = Js.Types.symbol type regexp = Js.Re.t type bigint +type \"true" = private bool +type \"false" = private bool type null<+'a> = Js.null<'a> type undefined<+'a> = Js.undefined<'a> @@ -127,29 +129,98 @@ module Primitive = { type prim<+'cases> = Primitive.t<'cases> module Interop = { - let apply0 = (. it: 'Function) => %raw(`it()`) - let apply1 = (. it: 'Function, arg0) => %raw(`it(arg0)`) - let apply2 = (. it: 'Function, arg0, arg1) => %raw(`it(arg0, arg1)`) - let apply3 = (. it: 'Function, arg0, arg1, arg2) => %raw(`it(arg0, arg1, arg2)`) - let apply4 = (. it: 'Function, arg0, arg1, arg2, arg3) => %raw(`it(arg0, arg1, arg2, arg3)`) - let apply5 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4) => %raw(`it(arg0, arg1, arg2, arg3, arg4)`) - let apply6 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5)`) - let apply7 = (. it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) - let applyN = (. it: 'Function, args: array) => %raw(`it(...args)`) - - let applyNewable0 = (. it: 'Newable) => %raw(`new it()`) - let applyNewable1 = (. it: 'Newable, arg0) => %raw(`new it(arg0)`) - let applyNewable2 = (. it: 'Newable, arg0, arg1) => %raw(`new it(arg0, arg1)`) - let applyNewable3 = (. it: 'Newable, arg0, arg1, arg2) => %raw(`new it(arg0, arg1, arg2)`) - let applyNewable4 = (. it: 'Newable, arg0, arg1, arg2, arg3) => %raw(`new it(arg0, arg1, arg2, arg3)`) - let applyNewable5 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4) => %raw(`new it(arg0, arg1, arg2, arg3, arg4)`) - let applyNewable6 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5)`) - let applyNewable7 = (. it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) - let applyNewableN = (. it: 'Newable, args: array) => %raw(`new it(...args)`) + let apply0 = (it: 'Function) => %raw(`it()`) + let apply1 = (it: 'Function, arg0) => %raw(`it(arg0)`) + let apply2 = (it: 'Function, arg0, arg1) => %raw(`it(arg0, arg1)`) + let apply3 = (it: 'Function, arg0, arg1, arg2) => %raw(`it(arg0, arg1, arg2)`) + let apply4 = (it: 'Function, arg0, arg1, arg2, arg3) => %raw(`it(arg0, arg1, arg2, arg3)`) + let apply5 = (it: 'Function, arg0, arg1, arg2, arg3, arg4) => %raw(`it(arg0, arg1, arg2, arg3, arg4)`) + let apply6 = (it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5)`) + let apply7 = (it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) + let applyN = (it: 'Function, args: 'args) => %raw(`it(...args)`) + + let applyNewable0 = (it: 'Newable) => %raw(`new it()`) + let applyNewable1 = (it: 'Newable, arg0) => %raw(`new it(arg0)`) + let applyNewable2 = (it: 'Newable, arg0, arg1) => %raw(`new it(arg0, arg1)`) + let applyNewable3 = (it: 'Newable, arg0, arg1, arg2) => %raw(`new it(arg0, arg1, arg2)`) + let applyNewable4 = (it: 'Newable, arg0, arg1, arg2, arg3) => %raw(`new it(arg0, arg1, arg2, arg3)`) + let applyNewable5 = (it: 'Newable, arg0, arg1, arg2, arg3, arg4) => %raw(`new it(arg0, arg1, arg2, arg3, arg4)`) + let applyNewable6 = (it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5)`) + let applyNewable7 = (it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) + let applyNewableN = (it: 'Newable, args: 'args) => %raw(`new it(...args)`) module PolyVariant = { - let name = (. it: 'PolyVariant) : 'name => %raw(`it.NAME`) - let value = (. it: 'PolyVariant) : 'value => %raw(`it.VAL`) - let make = (. name: 'name, value: 'value) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`) + let name = (it: 'PolyVariant) : 'name => %raw(`it.NAME`) + let value = (it: 'PolyVariant) : 'value => %raw(`it.VAL`) + let make = (name: 'name, value: 'value) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`) } +} + +module Newable = { + type t0<'t> + type t1<'arg1, 't> + + @ocaml.doc(`\`'args\` must be a tuple type.`) + type tn<'args, 't> + + let apply0 = (f0: t0<'t>) : 't => %raw(`new f0()`) + let apply1 = (f1: t1<'arg1, 't>, arg1: 'arg1) : 't => %raw(`new f1(arg1)`) + let applyN = (fn: tn<'args, 't>, args: 'args) : 't => %raw(`new fn(...args)`) +} + +module Variadic = { + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + type t0<'variadic, 't> + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + type t1<'arg1, 'variadic, 't> + + @ocaml.doc(`\`'args\` must be a tuple type. \`'variadic\` is expected to be array or some other iterable type.`) + type tn<'args, 'variadic, 't> + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + let create0 : ('variadic => 't) => t0<'variadic, 't> = f => %raw(`(function(...args) { return f(args); })`) + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + let create1 : (('arg1, 'variadic) => 't) => t1<'arg1, 'variadic, 't> = f => %raw(`(function(arg1, ...args) { return f(arg1, args); })`) + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + let create2 : (('arg1, 'arg2, 'variadic) => 't) => tn<('arg1, 'arg2), 'variadic, 't> = f => %raw(`(function(arg1, arg2, ...args) { return f(arg1, arg2, args); })`) + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + let create3 : (('arg1, 'arg2, 'arg3, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, ...args) { return f(arg1, arg2, arg3, args); })`) + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + let create4 : (('arg1, 'arg2, 'arg3, 'arg4, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, ...args) { return f(arg1, arg2, arg3, arg4, args); })`) + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + let create5 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, ...args) { return f(arg1, arg2, arg3, arg4, arg5, args); })`) + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + let create6 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, arg6, ...args) { return f(arg1, arg2, arg3, arg4, arg5, arg6, args); })`) + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + let create7 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'arg7, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'arg7), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, arg6, arg7, ...args) { return f(arg1, arg2, arg3, arg4, arg5, arg6, arg7, args); })`) + + @ocaml.doc(`\`'args\` must be a tuple type. \`'variadic\` is expected to be array or some other iterable type.`) + let createN : (('args, 'variadic) => 't, int) => tn<'args, 'variadic, 't> = (f, n) => %raw(`(function(...args) { return f(args.slice(0, n), args.slice(n)); })`) + + let apply0 = (f0: t0<'variadic, 't>, variadic: 'variadic) : 't => %raw(`f0(...variadic)`) + let apply1 = (f1: t1<'arg1, 'variadic, 't>, arg1: 'arg1, variadic: 'variadic) : 't => %raw(`f1(arg1, ...variadic)`) + let applyN = (fn: tn<'args, 'variadic, 't>, args: 'args, variadic: 'variadic) : 't => %raw(`fn(...args, ...variadic)`) +} + +module NewableVariadic = { + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + type t0<'variadic, 't> + + @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) + type t1<'arg1, 'variadic, 't> + + @ocaml.doc(`\`'args\` must be a tuple type. \`'variadic\` is expected to be array or some other iterable type.`) + type tn<'args, 'variadic, 't> + + let apply0 = (f0: t0<'variadic, 't>, variadic: 'variadic) : 't => %raw(`new f0(...variadic)`) + let apply1 = (f1: t1<'arg1, 'variadic, 't>, arg1: 'arg1, variadic: 'variadic) : 't => %raw(`new f1(arg1, ...variadic)`) + let applyN = (fn: tn<'args, 'variadic, 't>, args: 'args, variadic: 'variadic) : 't => %raw(`new fn(...args, ...variadic)`) } \ No newline at end of file diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 24286840..2dcaf38e 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -7,4 +7,5 @@ type Options = inherit Typer.TyperOptions // code generator options abstract numberAsInt: bool with get, set - abstract safeArity: FeatureFlag with get, set \ No newline at end of file + abstract safeArity: FeatureFlag with get, set + abstract readableNames: bool with get, set \ No newline at end of file diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index d35790a4..da3abdc9 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -88,6 +88,85 @@ module Attr = /// https://rescript-lang.org/docs/manual/latest/unboxed let unboxed = str "@unboxed" +module Naming = + let removeInvalidChars (s: string) = + s.ToCharArray() + |> Array.map (fun c -> if Char.isAlphabetOrDigit c || c = '_' then c else '_') + |> System.String + + let isValid (s: string) = + Char.isAlphabet(s[0]) + && s.ToCharArray() |> Array.forall(fun c -> Char.isAlphabetOrDigit c || c = '_') + + let keywords = + set [ + "and"; "as"; "assert"; "constraint"; "else"; "exception"; "external" + "false"; "for"; "if"; "in"; "include"; "lazy"; "let"; "module"; "mutable" + "of"; "open"; "rec"; "switch"; "true"; "try"; "type"; "when"; "while"; "with" + ] + + let reservedValueNames = + set [ + "create"; "apply"; "invoke"; "get"; "set"; "castFrom" + ] |> Set.union keywords + + let valueName (name: string) = + let name = removeInvalidChars name + let result = + if name = "NaN" then "nan" + else if String.forall (fun c -> Char.IsLower c |> not) name then + name.ToLowerInvariant() + else if Char.IsUpper name.[0] then + sprintf "%c%s" (Char.ToLower name.[0]) name.[1..] + else name + if reservedValueNames |> Set.contains result then result + "_" else result + + let reservedModuleNames = + Set.ofList [ + "Export"; "Default"; "Types" + ] |> Set.union keywords + + let moduleNameReserved (name: string) = + let name = removeInvalidChars name + if Char.IsLower name.[0] then + sprintf "%c%s" (Char.ToUpper name.[0]) name.[1..] + else if name.[0] = '_' then + "M" + name + else name + + let moduleName (name: string) = + let result = moduleNameReserved name + if reservedModuleNames |> Set.contains result then result + "_" else result + + let constructorName (name: string list) = + let s = String.concat "_" name |> removeInvalidChars + let result = + if Char.IsLower s.[0] then + sprintf "%c%s" (Char.ToUpper s.[0]) s.[1..] + else s + if keywords |> Set.contains result then result + "_" else result + + let flattenedTypeName (name: string list) = + let s = String.concat "_" name |> removeInvalidChars + let result = + if Char.IsUpper s.[0] then "_" + s + else s + if keywords |> Set.contains result then result + "_" else result + + let structured (baseName: string -> string) (name: string list) = + let rec prettify = function + | [] -> "" + | [x] -> baseName x + | x :: xs -> moduleName x + "." + prettify xs + prettify name + + let createTypeNameOfArity arity maxArityOpt name = + match maxArityOpt with + | Some maxArity -> + if arity = maxArity then name + else sprintf "%s%d" name arity + | None -> sprintf "%s%d" name arity + [] module Type = /// non-primitive types defined in the standard library @@ -145,6 +224,24 @@ module Type = if List.isEmpty args then t else app t args + let polyVariantBody (cases: {| name:Choice; value:text option; attr: text option |} list) = + let createCase (case: {| name:Choice; value:text option; attr: text option |}) = + let name = + match case.name with + | Choice1Of2 str -> + if Naming.isValid str then str else sprintf "\"%s\"" (String.escape str) + | Choice2Of2 i -> sprintf "%d" i + let attr = + match case.attr with + | None -> empty + | Some a -> a +@ " " + match case.value with + | None -> attr + tprintf "#%s" name + | Some v -> attr + tprintf "#%s(" name + v +@ ")" + cases |> List.map createCase |> concat (str " | ") + + let polyVariant cases = polyVariantBody cases |> between "[" "]" + // primitive types let void_ = str "unit" let string = str "string" @@ -154,6 +251,7 @@ module Type = else str "float" let array = str "array" let readonlyArray = str "array" + let option t = app (str "option") [t] // JS types // ES5 @@ -173,6 +271,9 @@ module Type = let null_or_undefined_or t = app (str "nullable") [t] let null_ = null_or never let undefined = undefined_or never + let intrinsic = str "intrinsic" + let true_ = str "\\\"true\"" + let false_ = str "\\\"false\"" // our types let intf tags baseTy = app (str "intf") [tags; baseTy] @@ -192,6 +293,24 @@ module Type = app (str "intersection8") [x1; x2; x3; x4; x5; x6; x7; intersection (x8 :: rest)] | xs -> app (tprintf "intersection%i" (List.length xs)) xs + let newable args retTy = + match args with + | [] -> app (str "Newable.t0") [retTy] + | [x1] -> app (str "Newable.t1") [x1; retTy] + | xs -> app (str "Newable.tn") [tuple xs; retTy] + + let variadic args variadic retTy = + match args with + | [] -> app (str "Variadic.t0") [variadic; retTy] + | [x1] -> app (str "Variadic.t1") [x1; variadic; retTy] + | xs -> app (str "Variadic.tn") [tuple xs; variadic; retTy] + + let newableVariadic args variadic retTy = + match args with + | [] -> app (str "NewableVariadic.t0") [variadic; retTy] + | [x1] -> app (str "NewableVariadic.t1") [x1; variadic; retTy] + | xs -> app (str "NewableVariadic.tn") [tuple xs; variadic; retTy] + [] module Term = let tuple = function diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index deaab70f..7ed2fc3f 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -1 +1,327 @@ -module Targets.ReScript.Writer \ No newline at end of file +module Targets.ReScript.Writer + +open Ts2Ml +open Syntax +open Typer +open Typer.Type +open DataTypes +open DataTypes.Text + +open Targets.ReScript.Common +open Targets.ReScript.ReScriptHelper + +type ScriptTarget = TypeScript.Ts.ScriptTarget + +type State = { + fileNames: string list + info: Result +} +module State = + let create fileNames info : State = + { fileNames = fileNames + info = info } + +type Context = TyperContext +module Context = TyperContext + +type Variance = Covariant | Contravariant | Invariant with + static member (~-) (v: Variance) = + match v with + | Covariant -> Contravariant + | Contravariant -> Covariant + | Invariant -> Invariant + +type Label = + | Case of text + | TagType of text + +type [] External = + | Root of variadic:bool * nullable:bool + | Return of nullable:bool + | Argument of variadic:bool + | None + +type EmitTypeFlags = { + resolveUnion: bool + needParen: bool + variance: Variance + external: External + simplifyContravariantUnion: bool + avoidTheseArgumentNames: Set +} + +module EmitTypeFlags = + let defaultValue = + { + resolveUnion = true + needParen = false + variance = Covariant + external = External.None + simplifyContravariantUnion = false + avoidTheseArgumentNames = Set.empty + } + + let ofChild flags = + { flags with external = External.None } + let ofFuncArg isVariadic flags = + { flags with + variance = -flags.variance + external = + match flags.external with + | External.Root _ -> External.Argument isVariadic + | _ -> External.None + } + let ofFuncReturn flags = + { flags with + external = + match flags.external with + | External.Root (_, n) -> External.Return n + | _ -> External.None } + +let classifyExternalFunction (f: FuncType) = + let isVariadic = + if not f.isVariadic then false + else if List.isEmpty f.args then false + else + let check = function + | App (APrim (Array | ReadonlyArray), _, _) -> true + | _ -> false + match List.last f.args with + | Choice1Of2 x -> check x.value + | Choice2Of2 t -> check t + let isNullable = + match f.returnType with + | Union u -> + let u = ResolvedUnion.checkNullOrUndefined u + u.hasNull || u.hasUndefined + | _ -> false + let flags = { EmitTypeFlags.defaultValue with external = External.Root(isVariadic, isNullable) } + {| flags = flags; isVariadic = isVariadic; isNullable = isNullable |} + +type TypeEmitter = Context -> Type -> text + +type OverrideFunc = EmitTypeFlags -> TypeEmitter -> Context -> Type -> text option +module OverrideFunc = + let inline noOverride _flags _emitType _ctx _ty = None + let inline combine (f1: OverrideFunc) (f2: OverrideFunc) : OverrideFunc = + fun _flags _emitType _ctx ty -> + match f2 _flags _emitType _ctx ty with + | Some text -> Some text + | None -> f1 _flags _emitType _ctx ty + +let fixme alternative fmt = + Printf.ksprintf (fun msg -> + commentStr (sprintf "FIXME: %s" msg) + alternative + ) fmt + +let enumCaseToIdentifier (e: Enum) (c: EnumCase) = + let duplicateCases = + e.cases |> List.filter (fun c' -> c.value = c'.value) + match duplicateCases with + | [] -> failwith "impossible_enumCaseToIdentifier" + | [c'] -> + assert (c = c') + Naming.constructorName [c.name] + | cs -> + cs |> List.map (fun c -> c.name) |> Naming.constructorName + +let anonymousInterfaceModuleName (ctx: Context) (info: AnonymousInterfaceInfo) = + match info.origin.valueName, info.origin.argName with + | _, Some s | Some s, None when ctx.options.readableNames -> + sprintf "%s%d" (Naming.toCase Naming.PascalCase s) info.id + | _, _ -> + sprintf "AnonymousInterface%d" info.id + +let anonymousInterfaceToIdentifier (ctx: Context) (a: AnonymousInterface) : text = + match ctx |> Context.bindCurrentSourceInfo (fun i -> i.anonymousInterfacesMap |> Map.tryFind a) with + | Some i -> tprintf "%s.t" (anonymousInterfaceModuleName ctx i) + | None -> failwithf "impossible_anonymousInterfaceToIdentifier(%s)" a.loc.AsString + +let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (ty: Type) : text = + let treatIdent (i: Ident) (tyargs: Type list) (loc: Location) = + let arity = List.length tyargs + let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.ofChild + let withTyargs ty = + Type.appOpt ty (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) + let origin = + Ident.pickDefinitionWithFullName ctx i (fun fn -> function + | _ when fn.source <> ctx.currentSourceFile -> None + | Definition.Class { typeParams = tps; loc = loc } + | Definition.TypeAlias { typeParams = tps; loc = loc } -> Some (fn, tps, loc) + | Definition.Enum { loc = loc } + | Definition.EnumCase ({ loc = loc }, _) -> Some (fn, [], loc) + | _ -> None + ) + match origin with + | None -> + let tyName = + let fallback () = + let tyName = + match ctx.options.safeArity with + | FeatureFlag.Full | FeatureFlag.Consume -> Naming.createTypeNameOfArity arity None "t" + | _ -> "t" + Naming.structured Naming.moduleName i.name + "." + tyName |> str + match i.name with + | [name] -> + match PrimType.FromJSClassName name with + | Some p -> emitTypeImpl flags overrideFunc ctx (Prim p) + | None -> fallback () + | _ -> fallback () + tyName |> withTyargs + | Some (fn, typrms, origLoc) -> + let name = Naming.flattenedTypeName fn.name + let ts = + assignTypeParams fn.name (origLoc ++ loc) typrms tyargs + (fun _ t -> t) + (fun tv -> + match tv.defaultType with + | Some t -> t + | None -> failwithf "error: insufficient type params for type '%s' at %s" (String.concat "." fn.name) loc.AsString) + Type.appOpt (str name) (ts |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) + match overrideFunc flags (emitTypeImpl flags overrideFunc) ctx ty with + | Some t -> t + | None -> + match ty with + | App (APrim Array, ts, _) when flags.external = External.Argument true -> + Type.app Type.array (List.map (emitTypeImpl { flags with needParen = true; external = External.None } overrideFunc ctx) ts) + | App (APrim ReadonlyArray, ts, _) when flags.external = External.Argument true -> + Type.app Type.readonlyArray (List.map (emitTypeImpl { flags with needParen = true; external = External.None } overrideFunc ctx) ts) + | _ when flags.external = External.Argument true -> + commentStr (sprintf "FIXME: type '%s' cannot be used for variadic argument" (Type.pp ty)) + Type.app Type.array [Type.any] + | App (t, ts, loc) -> + let flags = flags |> EmitTypeFlags.ofChild + let emit t ts = + Type.appOpt (emitTypeImpl flags overrideFunc ctx t) (List.map (emitTypeImpl { flags with needParen = true } overrideFunc ctx) ts) + match t with + | AIdent i -> treatIdent i ts loc + | APrim _ | AAnonymousInterface _ -> emit (Type.ofAppLeftHandSide t) ts + | Ident i -> treatIdent i [] i.loc + | TypeVar v -> tprintf "'%s" v + | Prim p -> + match p with + | Null -> Type.null_ | Undefined -> Type.undefined + | String -> Type.string | Bool -> Type.boolean + | Number -> Type.number ctx.options + | Object -> Type.object | UntypedFunction -> Type.function_ + | RegExp -> Type.regexp | Symbol _ -> Type.symbol + | Never -> Type.never | Any -> Type.any | Unknown -> Type.unknown | Void -> Type.void_ + | Array -> Type.array | ReadonlyArray -> Type.readonlyArray + | BigInt -> Type.bigint + | TypeLiteral l -> + match l with + | LBool true -> Type.true_ | LBool false -> Type.false_ + | LString s -> Type.polyVariant [{| name = Choice1Of2 s; value = None; attr = None |}] + | LInt i -> Type.polyVariant [{| name = Choice2Of2 i; value = None; attr = None |}] + | LFloat f -> fixme (str "float") "float literal %f" f + | Intersection i -> + let flags = { flags with needParen = true } |> EmitTypeFlags.ofChild + Type.intersection (i.types |> List.distinct |> List.map (emitTypeImpl flags overrideFunc ctx)) + | Union u -> emitUnion flags overrideFunc ctx u + | AnonymousInterface a -> anonymousInterfaceToIdentifier ctx a + | PolymorphicThis -> fixme Type.any "polymorphic 'this' appeared out of context" + | Intrinsic -> Type.intrinsic + | Tuple ts -> + // TODO: emit label + match ts.types with + | [] -> Type.void_ + | [t] -> emitTypeImpl flags overrideFunc ctx t.value + | ts -> Type.tuple (ts |> List.map (fun x -> emitTypeImpl (flags |> EmitTypeFlags.ofChild) overrideFunc ctx x.value)) + | Func (f, [], _) -> emitFuncType flags overrideFunc ctx false f + | NewableFunc (f, [], _) -> emitFuncType flags overrideFunc ctx true f + | Erased (_, loc, origText) -> failwithf "impossible_emitTypeImpl_erased: %s (%s)" loc.AsString origText + | Func (_, _ :: _, loc) -> failwithf "impossible_emitTypeImpl_Func_poly: %s (%s)" loc.AsString (Type.pp ty) + | NewableFunc (_, _, loc) -> failwithf "impossible_emitTypeImpl_NewableFunc_poly: %s (%s)" loc.AsString (Type.pp ty) + | UnknownType msgo -> + match msgo with + | None -> fixme Type.any "unknown type" + | Some msg -> fixme Type.any "unknown type '%s'" msg + +and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) isNewable (f: FuncType) = + let retTy flags = + let argNames = + f.args |> List.choose (function Choice1Of2 x -> Some x.name | Choice2Of2 _ -> None) |> Set.ofList + let flags = { flags with needParen = true; avoidTheseArgumentNames = argNames } |> EmitTypeFlags.ofFuncReturn + emitTypeImpl flags overrideFunc ctx f.returnType + let paren x = + if flags.needParen then between "(" ")" x + else x + let variadicFallback () = + assert f.isVariadic + let retTy = retTy (EmitTypeFlags.ofChild flags) + let args = + let flags = { flags with needParen = true } |> EmitTypeFlags.ofChild + f.args |> List.map (function + | Choice1Of2 x -> + let t = emitTypeImpl flags overrideFunc ctx x.value + if x.isOptional then Type.undefined_or t else t + | Choice2Of2 t -> emitTypeImpl flags overrideFunc ctx t) + let args, variadic = + match List.rev args with + | v :: rest -> List.rev rest, v + | [] -> failwith "impossible_emitFuncType_empty_variadic_function" + if isNewable then Type.newableVariadic args variadic retTy |> paren + else Type.variadic args variadic retTy |> paren + let newableFallback () = + let retTy = retTy (EmitTypeFlags.ofChild flags) + let args = + let flags = { flags with needParen = true } |> EmitTypeFlags.ofChild + f.args |> List.map (function + | Choice1Of2 x -> + let t = emitTypeImpl flags overrideFunc ctx x.value + if x.isOptional then Type.undefined_or t else t + | Choice2Of2 t -> emitTypeImpl flags overrideFunc ctx t) + Type.newable args retTy + let args () = + let rec go optional acc (args: Choice list) = + let flags = { flags with needParen = true } |> EmitTypeFlags.ofFuncArg false + match args with + | [] -> if optional then Type.void_ :: acc else acc + | Choice1Of2 x :: [] when acc = [] && not x.isOptional -> + go optional acc [Choice2Of2 x.value] + | Choice1Of2 x :: [] when f.isVariadic -> + assert (not x.isOptional) + let t = emitTypeImpl { flags with external = External.Argument true } overrideFunc ctx x.value + (tprintf "~%s:" x.name + t) :: acc + | Choice2Of2 t :: [] -> + let flags = + if f.isVariadic then { flags with external = External.Argument true } else flags + emitTypeImpl flags overrideFunc ctx t :: acc + | Choice1Of2 x :: rest -> + let arg = + let tmp = tprintf "~%s:" x.name + emitTypeImpl flags overrideFunc ctx x.value + if x.isOptional then tmp +@ "=?" else tmp + go (optional || x.isOptional) (arg :: acc) rest + | Choice2Of2 t :: rest -> + let t = emitTypeImpl flags overrideFunc ctx t + go false (t :: acc) rest + go false [] f.args |> List.rev + match flags.external with + | _ when isNewable -> + if f.isVariadic then variadicFallback () else newableFallback () + | External.Root (true, _) -> Type.curriedArrow (args ()) (retTy (EmitTypeFlags.ofFuncReturn flags)) + | _ when f.isVariadic -> variadicFallback () + | External.Root (_, _) -> Type.curriedArrow (args ()) (retTy (EmitTypeFlags.ofFuncReturn flags)) + | External.Argument _ -> paren ("@uncurry " @+ Type.curriedArrow (args ()) (retTy (EmitTypeFlags.ofFuncReturn flags))) + | _ -> Type.uncurriedArrow (args ()) (retTy (EmitTypeFlags.ofFuncReturn flags)) |> paren + +and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (u: UnionType) : text = + // TODO: more classification + let u = ResolvedUnion.checkNullOrUndefined u + let rest = + let rest = u.rest |> List.map (emitTypeImpl (EmitTypeFlags.ofChild flags) overrideFunc ctx) + if List.isEmpty rest then Type.never + else Type.union rest + match u.hasNull, u.hasUndefined with + | true, _ | _, true when flags.external = External.Return true -> Type.option rest + | true, true -> Type.null_or_undefined_or rest + | true, false -> Type.null_or rest + | false, true -> Type.undefined_or rest + | false, false -> rest + +let setTyperOptions (ctx: IContext) = + ctx.options.inheritArraylike <- true + ctx.options.inheritIterable <- true + ctx.options.inheritPromiselike <- true + ctx.options.replaceAliasToFunction <- false + ctx.options.replaceNewableFunction <- false + ctx.options.replaceRankNFunction <- true \ No newline at end of file From ba4d353669c94feeebbccf9d7e069b3a2cb3501a Mon Sep 17 00:00:00 2001 From: cannorin Date: Thu, 24 Feb 2022 21:11:31 +0900 Subject: [PATCH 08/56] [WIP] emit members --- dist_rescript/src/Ts__min.res | 3 + src/Targets/ReScript/Common.fs | 203 ++++++++++++++++- src/Targets/ReScript/ReScriptHelper.fs | 44 +++- src/Targets/ReScript/Writer.fs | 296 ++++++++++++++++++++++++- 4 files changed, 528 insertions(+), 18 deletions(-) diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/Ts__min.res index 8b2d6563..aa966bcd 100644 --- a/dist_rescript/src/Ts__min.res +++ b/dist_rescript/src/Ts__min.res @@ -30,9 +30,12 @@ type regexp = Js.Re.t type bigint type \"true" = private bool type \"false" = private bool +type intrinsic = private string type null<+'a> = Js.null<'a> +type null' = null type undefined<+'a> = Js.undefined<'a> +type undefined' = undefined type nullable<+'a> = Js.nullable<'a> module Union = { diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 2dcaf38e..6abeeb68 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -1,11 +1,212 @@ module Targets.ReScript.Common +open Fable.Core open Ts2Ml +open DataTypes + +[] +type Simplify = + | [] All + | [] ImmediateInstance + | [] ImmediateConstructor + | [] AnonymousInterfaceValue + | [] NamedInterfaceValue + | [] Off +with + static member Values = [|All; ImmediateInstance; ImmediateConstructor; AnonymousInterfaceValue; NamedInterfaceValue; Off|] + + static member Has (flags: Simplify list, target: Simplify) = + if flags |> List.contains All then true + else flags |> List.contains target + + static member TryParse (s: string) = + match s with + | "all" -> Some All + | "immediate-instance" -> Some ImmediateInstance + | "immediate-constructor" -> Some ImmediateConstructor + | "anonymous-interface-value" -> Some AnonymousInterfaceValue + | "named-interface-value" -> Some NamedInterfaceValue + | _ -> None + +[] +type Subtyping = + | [] Tag + | [] CastFunction + | [] Off + | [] Default +with + static member Values = [|Tag; CastFunction; Off; Default|] + + static member TryParse (s: string) = + match s with + | "tag" -> Some Tag + | "cast-function" -> Some CastFunction + | _ -> None + +[] +type Preset = + | [] Minimal + | [] Safe + | [] Full +with + static member Values = [|Minimal; Safe; Full|] type Options = inherit GlobalOptions inherit Typer.TyperOptions + // general options + abstract preset: Preset option with get + abstract createMinimalStdlib: bool with get + abstract stdlib: bool with get // hidden + // output options + abstract outputDir: string option with get // code generator options abstract numberAsInt: bool with get, set + abstract subtyping: Subtyping list with get, set + abstract inheritWithTags: FeatureFlag with get, set abstract safeArity: FeatureFlag with get, set - abstract readableNames: bool with get, set \ No newline at end of file + abstract simplify: Simplify list with get, set + abstract readableNames: bool with get, set + +module Options = + open Fable.Core.JsInterop + + let validate : Yargs.MiddlewareFunction = + Yargs.MiddlewareFunction(fun opts yargs -> + if isNullOrUndefined opts.subtyping then opts.subtyping <- [] + if isNullOrUndefined opts.simplify then opts.simplify <- [] + + match opts.preset with + | None -> () + | Some p -> + Log.tracef opts "* using the preset '%s'." !!p + + let subtypingIsDefault = + opts.subtyping = [] + + if p = Preset.Minimal || p = Preset.Safe || p = Preset.Full then + if opts.simplify = [] then + opts.simplify <- [Simplify.All] + + if p = Preset.Safe || p = Preset.Full then + if opts.safeArity = FeatureFlag.Default then + opts.safeArity <- FeatureFlag.Full + if subtypingIsDefault then + opts.subtyping <- Subtyping.CastFunction :: opts.subtyping + + if p = Preset.Full then + if subtypingIsDefault then + opts.subtyping <- Subtyping.Tag :: opts.subtyping + if opts.inheritWithTags = FeatureFlag.Default then + opts.inheritWithTags <- FeatureFlag.Full + + if opts.subtyping |> List.contains Subtyping.Tag |> not + && opts.inheritWithTags <> FeatureFlag.Off + && opts.inheritWithTags <> FeatureFlag.Default then + eprintfn "error: --inherit-with-tags=%s requires --subtyping=tag." !!opts.inheritWithTags + yargs.exit(-1, new System.ArgumentException("--inherit-with-tags requires --subtyping=tag.")) + + !^opts) + + let register (yargs: Yargs.Argv) = + yargs + .group( + !^ResizeArray[ + "create-minimal-stdlib"; "stdlib"; "preset" + ], + "General Options:" + ) + .addFlag( + "create-minimal-stdlib", + (fun (o:Options) -> o.createMinimalStdlib), + descr="Create ts2ocaml_min.mli. When this option is used, most of the other options are ignored.", + defaultValue=false + ) + .addFlag( + "stdlib", + (fun (o: Options) -> o.stdlib), + descr = "Internal. Used to generate Ts2ocaml.mli from typescript/lib/lib.*.d.ts." + ).hide("stdlib") + .addChoice( + "preset", + Preset.Values, + (fun (o: Options) -> o.preset), + descr="Specify the preset to use." + ) + .group(!^ResizeArray[], "Parser Options:") + .group( + !^ResizeArray[ + "output-dir"; "stub-file" + ], + "Output Options:" + ) + .addOption( + "output-dir", + (fun (o: Options) -> o.outputDir), + descr="The directory to place the generated bindings.\nIf not set, it will be the current directory.", + alias="o") + + .group( + !^ResizeArray[ + "number-as-int"; + "subtyping"; + "inherit-with-tags"; + ], + "Typer Options:") + .addFlag( + "number-as-int", + (fun (o: Options) -> o.numberAsInt), + descr="Treat number types as int.\nIf not set, float will be used.", + defaultValue=false, + alias="int") + .addCommaSeparatedStringSet( + "subtyping", + Subtyping.TryParse, + (fun (o: Options) -> o.subtyping), + descr= + sprintf "Turn on subtyping features. Available features: %s" + (Subtyping.Values |> Array.filter ((<>) Subtyping.Default) |> Array.map string |> String.concat ", ")) + .addChoice( + "inherit-with-tags", + FeatureFlag.Values, + (fun (o: Options) -> o.inheritWithTags), + descr="Require --subtyping=tag. Use `TypeName.tags` type names to inherit types from other packages.", + defaultValue=FeatureFlag.Default) + + .group( + !^ResizeArray[ + "safe-arity"; + "rec-module"; + "simplify"; + "human-readable-anonymous-interface-names"; + "functor" + ], + "Code Generator Options:") + .addChoice( + "safe-arity", + FeatureFlag.Values, + (fun (o: Options) -> o.safeArity), + descr="Use `TypeName.t_n` type names to safely use overloaded types from other packages.", + defaultValue=FeatureFlag.Default) + .addCommaSeparatedStringSet( + "simplify", + Simplify.TryParse, + (fun (o: Options) -> o.simplify), + descr= + sprintf "Turn on simplification features. Available features: %s" + (Simplify.Values |> Array.map string |> String.concat ", ")) + .addFlag( + "readable-names", + (fun (o: Options) -> o.readableNames), + descr="Try to use more readable names instead of AnonymousInterfaceN.", + defaultValue = false + ) + + .middleware(!^validate) + + +type Output = { + fileName: string + content: text + stubLines: string list +} \ No newline at end of file diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index da3abdc9..23595264 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -269,9 +269,9 @@ module Type = let null_or t = app (str "null") [t] let undefined_or t = app (str "undefined") [t] let null_or_undefined_or t = app (str "nullable") [t] - let null_ = null_or never - let undefined = undefined_or never - let intrinsic = str "intrinsic" + let null_ = str "null'" + let undefined = str "undefined'" + let intrinsic = app (str "intrinsic") [object] let true_ = str "\\\"true\"" let false_ = str "\\\"false\"" @@ -321,6 +321,23 @@ module Term = let appCurried t us = t + (us |> concat (str ", ") |> between "(" ")") let appUncurried t us = t + (us |> concat (str ", ") |> between "(. " ")") + /// `(arg1, arg2) => ret` + let curriedArrow args ret = + let lhs = + match args with + | [] -> failwith "0-ary function" + | [x] -> x + | xs -> concat (str ", ") xs |> between "(" ")" + lhs +@ " => " + ret + + /// `(. arg1, arg2) => ret` + let uncurriedArrow args ret = + let lhs = + match args with + | [] -> failwith "0-ary function" + | xs -> concat (str ", ") xs |> between "(. " ")" + lhs +@ " => " + ret + let literal (l: Literal) = match l with | LBool true -> str "true" | LBool false -> str "false" @@ -328,11 +345,18 @@ module Term = | LFloat f -> tprintf "%f" f | LString s -> tprintf "\"%s\"" (String.escape s) - let raw js = between "%raw(`" "`)" js + let raw js = js |> String.escapeWith ["`"] |> str |> between "%raw(`" "`)" -let let_ name typ body = - tprintf "let %s: " name + typ +@ " = " + body - -let external (attrs: text list) name (typ: text) target = - concat (str " ") attrs - + tprintf " external %s: " name + typ + tprintf " = \"%s\"" target \ No newline at end of file +[] +module Statement = + let let_ (attrs: text list) name typ value = + concat (str " ") attrs + + tprintf "let %s: " name + typ +@ " = " + value + + let val_ (attrs: text list) name typ = + concat (str " ") attrs + + tprintf "let %s: " name + typ + + let external (attrs: text list) name (typ: text) target = + concat (str " ") attrs + + tprintf " external %s: " name + typ + tprintf " = \"%s\"" target \ No newline at end of file diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 7ed2fc3f..642244c7 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -12,14 +12,16 @@ open Targets.ReScript.ReScriptHelper type ScriptTarget = TypeScript.Ts.ScriptTarget -type State = { +type State = {| fileNames: string list info: Result -} + referencesCache: MutableMap> +|} module State = let create fileNames info : State = - { fileNames = fileNames - info = info } + {| fileNames = fileNames + info = info + referencesCache = new MutableMap<_, _>() |} type Context = TyperContext module Context = TyperContext @@ -78,7 +80,7 @@ module EmitTypeFlags = | External.Root (_, n) -> External.Return n | _ -> External.None } -let classifyExternalFunction (f: FuncType) = +let classifyExternalFunction flags (f: FuncType) = let isVariadic = if not f.isVariadic then false else if List.isEmpty f.args then false @@ -95,7 +97,7 @@ let classifyExternalFunction (f: FuncType) = let u = ResolvedUnion.checkNullOrUndefined u u.hasNull || u.hasUndefined | _ -> false - let flags = { EmitTypeFlags.defaultValue with external = External.Root(isVariadic, isNullable) } + let flags = { flags with external = External.Root(isVariadic, isNullable) } {| flags = flags; isVariadic = isVariadic; isNullable = isNullable |} type TypeEmitter = Context -> Type -> text @@ -324,4 +326,284 @@ let setTyperOptions (ctx: IContext) = ctx.options.inheritPromiselike <- true ctx.options.replaceAliasToFunction <- false ctx.options.replaceNewableFunction <- false - ctx.options.replaceRankNFunction <- true \ No newline at end of file + ctx.options.replaceRankNFunction <- true + +/// `[ #A | #B | ... ]` +let rec emitLabels (ctx: Context) labels = + emitLabelsBody ctx labels |> between "[" "]" + +/// `#A | #B | ...` +and emitLabelsBody (ctx: Context) labels = + let inline tag t = + if ctx.options.inheritWithTags.HasConsume then t + else empty + let rec go firstCaseEmitted acc = function + | [] -> acc + | Case c :: rest -> + if firstCaseEmitted then + go firstCaseEmitted (acc + str " | " + c) rest + else + go true (acc + c) rest + | TagType t :: rest -> + if firstCaseEmitted then + go firstCaseEmitted (acc + tag (" | " @+ t)) rest + else + go ctx.options.inheritWithTags.HasConsume (acc + tag t) rest + go false empty labels + +and getLabelsFromInheritingTypes (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (inheritingTypes: Set) = + let emitType_ = emitTypeImpl flags overrideFunc + let emitCase name args = + match args with + | [] -> str (Naming.constructorName name) + | [arg] -> tprintf "%s(" (Naming.constructorName name) + arg +@ ")" + | _ -> Naming.constructorName name @+ Type.tuple args + let emitTagType name args = + let arity = List.length args + let tagTypeName = + if ctx.options.safeArity.HasConsume then + Naming.createTypeNameOfArity arity None "tags" + else + "tags" + let ty = Naming.structured Naming.moduleName name + "." + tagTypeName + let args = args |> List.map (emitType_ ctx) + Type.appOpt (str ty) args + [ + for e in inheritingTypes do + match e with + | InheritingType.KnownIdent i -> + yield str "#" + emitCase i.fullName.name (i.tyargs |> List.map (emitType_ ctx)) |> Case + | InheritingType.UnknownIdent i -> + yield emitTagType i.name i.tyargs |> TagType + | InheritingType.Prim (p, ts) -> + match p.AsJSClassName with + | Some name -> + yield str "#" + emitCase [name] (ts |> List.map (emitType_ ctx)) |> Case + | None -> () + | InheritingType.Other _ -> () + ] + +/// `Choice2Of2` when it is an alias to a non-JSable prim type. +and getLabelsOfFullName flags overrideFunc (ctx: Context) (fullName: FullName) (typeParams: TypeParam list) = + getAllInheritancesAndSelfFromName ctx fullName |> getLabelsFromInheritingTypes flags overrideFunc ctx |> List.sort + +and getLabelOfFullName flags overrideFunc (ctx: Context) (fullName: FullName) (typeParams: TypeParam list) = + let inheritingType = InheritingType.KnownIdent {| fullName = fullName; tyargs = typeParams |> List.map (fun tp -> TypeVar tp.name) |} + getLabelsFromInheritingTypes flags overrideFunc ctx (Set.singleton inheritingType) |> Choice1Of2 + +type Scope = { + moduleName: string option + /// reversed list of scope + scopeRev: string list +} + +type [] Binding = + | Let of {| name: string; ty: text; body: text; attrs: text list; comments: text list |} + | Ext of {| name: string; ty: text; target: string; attrs: text list; comments: text list |} + +let let_ (attrs: text list) comments name ty body = + Binding.Let {| name = name; ty = ty; body = body; attrs = attrs; comments = comments |} + +let ext (attrs: text list) comments name ty target = + Binding.Ext {| name = name; ty = ty; target = target; attrs = attrs; comments = comments |} + +type StructuredTextItem = + | ImportText of text // import texts should be at the top of the module + | TypeDefText of text // and type definitions should come next + | ScopeIndependentText of text // floating comments, etc + | Binding of (OverloadRenamer -> Scope -> Binding) + +and [] ExportItem = + | Export of {| comments: Comment list; clauses: (ExportClause * Set) list; loc: Location; origText: string |} + | ReExport of {| comments: Comment list; clauses: (ReExportClause * Set) list; loc: Location; specifier: string; origText: string |} + | DefaultUnnamedClass of StructuredTextNode + +and StructuredTextNode = {| + /// By default, key is used as a scope. `Some scope` to override it. + scope: string option + items: StructuredTextItem list + docCommentLines: text list + exports: ExportItem list + knownTypes: Set + anonymousInterfaces: Set +|} + +and StructuredText = Trie + +module StructuredTextNode = + let empty : StructuredTextNode = + {| scope = None; items = []; docCommentLines = []; exports = []; knownTypes = Set.empty; anonymousInterfaces = Set.empty |} + let union (a: StructuredTextNode) (b: StructuredTextNode) : StructuredTextNode = + let mergeScope s1 s2 = + match s1, s2 with + | Some s1, Some s2 -> failwithf "impossible_union_mergeScope(%s, %s)" s1 s2 + | Some s, None | None, Some s -> Some s + | None, None -> None + {| scope = mergeScope a.scope b.scope + items = List.append a.items b.items + docCommentLines = List.append a.docCommentLines b.docCommentLines + exports = List.append a.exports b.exports + knownTypes = Set.union a.knownTypes b.knownTypes + anonymousInterfaces = Set.union a.anonymousInterfaces b.anonymousInterfaces |} + +module StructuredText = + let pp (x: StructuredText) = + let rec go (x: StructuredText) = + concat newline [ + for k, v in x.children |> Map.toArray do + tprintf "- %s" k + indent (go v) + ] + go x + + let rec getReferences (ctx: Context) (x: StructuredText) : WeakTrie = + match ctx.state.referencesCache.TryGetValue(ctx.currentNamespace) with + | true, ts -> ts + | false, _ -> + let fn = ctx.currentNamespace + let trie = + x.value + |> Option.map (fun v -> + v.knownTypes + |> Set.fold (fun state -> function + | KnownType.Ident fn when fn.source = ctx.currentSourceFile -> state |> WeakTrie.add fn.name + | KnownType.AnonymousInterface (_, i) -> + state |> WeakTrie.add (i.namespace_ @ [anonymousInterfaceModuleName ctx i]) + | _ -> state + ) WeakTrie.empty) + |> Option.defaultValue WeakTrie.empty + let trie = + x.children + |> Map.fold (fun state k child -> + WeakTrie.union state (getReferences (ctx |> Context.ofChildNamespace k) child)) trie + |> WeakTrie.remove fn + ctx.state.referencesCache.[fn] <- trie + trie + + let getDependenciesOfChildren (ctx: Context) (x: StructuredText) : (string * string) list = + let parent = ctx.currentNamespace + x.children + |> Map.fold (fun state k child -> + let refs = + getReferences (ctx |> Context.ofChildNamespace k) child + |> WeakTrie.getSubTrie parent + |> Option.defaultValue WeakTrie.empty + |> WeakTrie.ofDepth 1 + |> WeakTrie.toList + |> List.map (function + | [x] -> k, x + | xs -> failwithf "impossible_StructuredText_getDependencyGraphOfChildren_refs(%s): %A" (ctx |> Context.getFullNameString [k]) xs) + refs :: state) [] + |> List.rev + |> List.concat + + let calculateSCCOfChildren (ctx: Context) (x: StructuredText) : string list list = + let g = + let deps = getDependenciesOfChildren ctx x + Graph.ofEdges deps + Graph.stronglyConnectedComponents g (x.children |> Map.toList |> List.map fst) + +let removeLabels (xs: Choice list) = + xs |> List.map (function Choice2Of2 t -> Choice2Of2 t | Choice1Of2 fl -> Choice2Of2 fl.value) + +let inline func ft = Func (ft, [], ft.loc) + +let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: bool) (ma: MemberAttribute) m = + let flags = { flags with simplifyContravariantUnion = true } + let emitType_ = emitTypeImpl flags overrideFunc + + let comments = + // TODO + [] + + let scopeToAttr (s: Scope) attr = + match s.scopeRev, s.moduleName with + | [], None -> attr + | sr, None -> Attr.External.scope (List.rev sr) :: attr + | sr, Some m -> + Attr.External.module_ (Some m) :: Attr.External.scope (List.rev sr) :: attr + + let extFunc (ft: FuncType) = + let c = classifyExternalFunction flags ft + let ty = emitTypeImpl c.flags overrideFunc ctx (func ft) + let attr = [ + if c.isNullable then yield Attr.ExternalModifier.return_nullable + if c.isVariadic then yield Attr.ExternalModifier.variadic + ] + ty, attr + let inline func ft = func ft |> emitType_ ctx + + let inline binding (f: (string -> string) -> Scope -> Binding) = + [Binding (fun renamer scope -> f (renamer.Rename "value") scope)] + + let generateCallable isNewable (args: Choice list) = + let used = + args |> List.choose (function Choice1Of2 f -> Some f.name | Choice2Of2 _ -> None) + |> Set.ofList + let rec rename s = + if used |> Set.contains s |> not then s + else rename (s + "_") + let self = rename "t" + let args = + let rec createArgs index isOptional acc = function + | [] -> + if isOptional then + let name = rename "unit" + List.rev ({| ml = str name; js = name; used = false |} :: acc) + else + List.rev acc + | Choice2Of2 _ :: rest -> + let name = sprintf "arg%d" index |> rename + createArgs (index+1) false ({| ml = str name; js = name; used = true |} :: acc) rest + | Choice1Of2 { name = name; isOptional = isOptional } :: rest -> + let ml = if isOptional then sprintf "~%s=?" name else "~" + name + let js = name |> String.replace "'" "$p" + createArgs (index+1) isOptional ({| ml = str ml; js = js; used = true |} :: acc) rest + createArgs 1 false [] args + let body = + let args = + args |> List.filter (fun arg -> arg.used) + |> List.map (fun arg -> arg.js) + |> String.concat ", " + let body = sprintf "%s(%s)" self args + if isNewable then "new " + body else body + let args = str self :: (args |> List.map (fun arg -> arg.ml)) + Term.curriedArrow args (Term.raw body) + + match m with + | Constructor ft -> + let ty, attrs = extFunc { args = ft.args; isVariadic = ft.isVariadic; returnType = selfTy; loc = ft.loc } + binding (fun rename s -> + let target, attrs = + if isExportDefaultClass then + match s.moduleName with + | Some m -> m, Attr.External.module_ None :: attrs + | None -> failwithf "impossible_emitMembers_Constructor_ExportDefaultClass(%s)" ma.loc.AsString + else + match s.scopeRev with + | self :: sr -> + let attrs = scopeToAttr { s with scopeRev = sr } attrs + self, attrs + | [] -> failwithf "impossible_emitMembers_Constructor(%s)" ma.loc.AsString + let attrs = Attr.External.new_ :: attrs |> List.rev + ext attrs comments (rename "create") ty target + ) + | Newable (ft, _typrm) -> + let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args } + let value = generateCallable true ft.args + binding (fun rename _ -> let_ [] comments (rename "create") ty value) + | Callable (ft, _typrm) -> + let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args } + let value = generateCallable false ft.args + binding (fun rename _ -> let_ [] comments (rename "invoke") ty value) + | Field ({ name = name; value = Func (ft, _typrm, _) }, _) + | Method (name, ft, _typrm) -> + let ty, attrs = + if ma.isStatic then extFunc ft + else + let ft = { ft with args = Choice2Of2 PolymorphicThis :: ft.args } + let ty, attr = extFunc ft + ty, Attr.External.send :: attr + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) + | _ -> failwith "TODO" + From 7849bc1b7a4167e4f460196c7919928114abcb50 Mon Sep 17 00:00:00 2001 From: cannorin Date: Fri, 25 Feb 2022 21:15:51 +0900 Subject: [PATCH 09/56] Emit members, load rescript/lib/ocaml/dom.ml --- dist_rescript/src/Ts__min.res | 4 +- package.json | 1 + src/Targets/ReScript/ReScriptHelper.fs | 67 ++++++--- src/Targets/ReScript/Writer.fs | 182 ++++++++++++++++++++++++- src/ts2ocaml.fsproj | 3 + webpack.config.js | 8 ++ yarn.lock | 5 + 7 files changed, 242 insertions(+), 28 deletions(-) diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/Ts__min.res index aa966bcd..13fc44fd 100644 --- a/dist_rescript/src/Ts__min.res +++ b/dist_rescript/src/Ts__min.res @@ -8,8 +8,8 @@ module Never = { let absurd : t => 'a = x => raise(Never) } -type any -let any : 'a => any = Obj.magic +@unboxed type rec any = Any('a): any +let any : 'a => any = x => Any(x) module Any = { type t = any diff --git a/package.json b/package.json index 03d81e0e..e1e9daea 100644 --- a/package.json +++ b/package.json @@ -43,6 +43,7 @@ "cdk8s": "^2.2.41", "monaco-editor": "0.40.0", "react-player": "2.12.0", + "rescript": "^9.1.4", "ts2fable": "0.8.0-build.723", "webpack": "5.88.0", "webpack-cli": "5.1.0", diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 23595264..e40c3eb2 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -7,6 +7,10 @@ open Targets.ReScript.Common open DataTypes open DataTypes.Text +module Source = + open Fable.Core + let [] dom: string = jsNative + let comment text = if text = empty then empty else @@ -110,15 +114,23 @@ module Naming = "create"; "apply"; "invoke"; "get"; "set"; "castFrom" ] |> Set.union keywords + let upperFirst (s: string) = + if Char.IsLower s[0] then + sprintf "%c%s" (Char.ToUpper s[0]) s[1..] + else s + + let lowerFirst (s: string) = + if Char.IsUpper s[0] then + sprintf "%c%s" (Char.ToLower s[0]) s[1..] + else s + let valueName (name: string) = let name = removeInvalidChars name let result = if name = "NaN" then "nan" else if String.forall (fun c -> Char.IsLower c |> not) name then name.ToLowerInvariant() - else if Char.IsUpper name.[0] then - sprintf "%c%s" (Char.ToLower name.[0]) name.[1..] - else name + else lowerFirst name if reservedValueNames |> Set.contains result then result + "_" else result let reservedModuleNames = @@ -128,30 +140,21 @@ module Naming = let moduleNameReserved (name: string) = let name = removeInvalidChars name - if Char.IsLower name.[0] then - sprintf "%c%s" (Char.ToUpper name.[0]) name.[1..] - else if name.[0] = '_' then + if name.[0] = '_' then "M" + name - else name + else upperFirst name let moduleName (name: string) = let result = moduleNameReserved name if reservedModuleNames |> Set.contains result then result + "_" else result let constructorName (name: string list) = - let s = String.concat "_" name |> removeInvalidChars - let result = - if Char.IsLower s.[0] then - sprintf "%c%s" (Char.ToUpper s.[0]) s.[1..] - else s - if keywords |> Set.contains result then result + "_" else result + let s = String.concat "_" name |> removeInvalidChars |> upperFirst + if keywords |> Set.contains s then s + "_" else s let flattenedTypeName (name: string list) = - let s = String.concat "_" name |> removeInvalidChars - let result = - if Char.IsUpper s.[0] then "_" + s - else s - if keywords |> Set.contains result then result + "_" else result + let s = String.concat "_" name |> removeInvalidChars |> lowerFirst + if keywords |> Set.contains s then s + "_" else s let structured (baseName: string -> string) (name: string list) = let rec prettify = function @@ -191,6 +194,27 @@ module Type = typedArray "Float64Array" ] + /// non-primitive DOM types defined in the standard library + /// + /// `MutableMap` with ignore-case keys, because `dom.ml` has lowered all acronyms (e.g. HTML -> html) + let predefinedDOMTypes = + let types = + Source.dom + |> String.splitManyThenRemoveEmptyEntries ["\n"; "\r"] + |> Array.filter (fun s -> s.StartsWith("type ") && s.Contains("=")) + |> Array.choose (fun s -> s |> String.replace "type " "" |> String.split " = " |> Array.tryHead) + |> Array.filter (fun s -> s.Length > 0 && s.ToCharArray() |> Array.forall Char.isAlphabet) + |> Array.map (fun s -> Naming.upperFirst s, "Dom." + s) + let ignoreCase = + { new Collections.Generic.IEqualityComparer with + member __.Equals(s1: string, s2: string) = + s1.Equals(s2, StringComparison.InvariantCultureIgnoreCase) + member __.GetHashCode(s: string) = s.ToLowerInvariant().GetHashCode() } + let m = new MutableMap(ignoreCase) + for k, v in types do m.Add(k, v) + m.Add("Storage", "Dom.Storage.t") + m + // basic type expressions let var s = tprintf "'%s" s @@ -359,4 +383,9 @@ module Statement = let external (attrs: text list) name (typ: text) target = concat (str " ") attrs - + tprintf " external %s: " name + typ + tprintf " = \"%s\"" target \ No newline at end of file + + tprintf " external %s: " name + typ + tprintf " = \"%s\"" target + + let typeAlias name tyargs ty = + str "type " + + (if List.isEmpty tyargs then str name else Type.app (str name) tyargs) + +@ " = " + ty \ No newline at end of file diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 642244c7..1cb25ffe 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -410,6 +410,7 @@ let ext (attrs: text list) comments name ty target = type StructuredTextItem = | ImportText of text // import texts should be at the top of the module | TypeDefText of text // and type definitions should come next + | Conditional of res:StructuredTextItem list * resi:StructuredTextItem list | ScopeIndependentText of text // floating comments, etc | Binding of (OverloadRenamer -> Scope -> Binding) @@ -430,6 +431,9 @@ and StructuredTextNode = {| and StructuredText = Trie +let inline OnRes texts = Conditional (texts, []) +let inline OnResi texts = Conditional ([], texts) + module StructuredTextNode = let empty : StructuredTextNode = {| scope = None; items = []; docCommentLines = []; exports = []; knownTypes = Set.empty; anonymousInterfaces = Set.empty |} @@ -508,13 +512,18 @@ let removeLabels (xs: Choice list) = let inline func ft = Func (ft, [], ft.loc) +let emitComments (comments: Comment list) : text list = + // TODO + [] + +let inline binding (f: (string -> string) -> Scope -> Binding) = + [Binding (fun renamer scope -> f (renamer.Rename "value") scope)] + let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: bool) (ma: MemberAttribute) m = let flags = { flags with simplifyContravariantUnion = true } let emitType_ = emitTypeImpl flags overrideFunc - let comments = - // TODO - [] + let comments = emitComments ma.comments let scopeToAttr (s: Scope) attr = match s.scopeRev, s.moduleName with @@ -533,9 +542,6 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: ty, attr let inline func ft = func ft |> emitType_ ctx - let inline binding (f: (string -> string) -> Scope -> Binding) = - [Binding (fun renamer scope -> f (renamer.Rename "value") scope)] - let generateCallable isNewable (args: Choice list) = let used = args |> List.choose (function Choice1Of2 f -> Some f.name | Choice2Of2 _ -> None) @@ -598,6 +604,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: binding (fun rename _ -> let_ [] comments (rename "invoke") ty value) | Field ({ name = name; value = Func (ft, _typrm, _) }, _) | Method (name, ft, _typrm) -> + let name = Naming.valueName name let ty, attrs = if ma.isStatic then extFunc ft else @@ -605,5 +612,166 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ty, attr = extFunc ft ty, Attr.External.send :: attr binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) - | _ -> failwith "TODO" + | Getter fl | Field (fl, ReadOnly) -> + let name = + match m with + | Getter _ -> "get" + Naming.upperFirst fl.name |> Naming.valueName + | _ -> fl.name |> Naming.valueName + let fl = + if fl.value <> Prim Void then fl + else + ctx.logger.warnf "the field/getter '%s' at %s has type 'void' and treated as 'undefined'" fl.name ma.loc.AsString + { fl with value = Prim Undefined } + if ma.isStatic then + let ty, attrs = + let ty = emitType_ ctx fl.value + if fl.isOptional then + Type.option ty, [Attr.External.val_; Attr.ExternalModifier.return_nullable] + else + ty, [Attr.External.val_] + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) + else + let ty, attrs = + let args = [Choice2Of2 PolymorphicThis] + let ret = + if fl.isOptional then Union { types = [fl.value; Prim Undefined] } + else fl.value + extFunc { isVariadic = false; args = args; returnType = ret; loc = ma.loc } + let attrs = Attr.External.get_ :: attrs + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) + | Setter fl | Field (fl, WriteOnly) -> + if ma.isStatic then + ctx.logger.warnf "writable global value or static setter '%s' is not supported in ReScript at %s" fl.name ma.loc.AsString + [] + else + let name = + match m with + | Setter _ -> "set" + Naming.upperFirst fl.name |> Naming.valueName + | _ -> fl.name |> Naming.valueName + let fl = + if fl.value <> Prim Void then fl + else + ctx.logger.warnf "the field/setter '%s' at %s has type 'void' and treated as 'undefined'" fl.name ma.loc.AsString + { fl with value = Prim Undefined } + let ty, attrs = + let args = + if ma.isStatic then [Choice2Of2 fl.value] + else [Choice2Of2 PolymorphicThis; Choice2Of2 fl.value] + let ty, attrs = + extFunc { isVariadic = false; args = args; returnType = Prim Void; loc = ma.loc } + ty, Attr.External.set_ :: attrs + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) + | Field (fl, Mutable) -> + List.concat [ + emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Getter fl) + emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Setter fl) + ] + | Indexer (ft, ReadOnly) -> + let ty, attrs = + let args = Choice2Of2 PolymorphicThis :: removeLabels ft.args + extFunc { ft with args = args } + let attrs = Attr.External.get_index :: attrs + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename "get") ty "") + | Indexer (ft, WriteOnly) -> + let ty, attrs = + let args = Choice2Of2 PolymorphicThis :: removeLabels ft.args @ [Choice2Of2 ft.returnType] + let ret = Prim Void + extFunc { ft with args = args; returnType = ret } + let attrs = Attr.External.set_index :: attrs + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename "set") ty "") + | Indexer (ft, Mutable) -> + List.concat [ + emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Indexer (ft, ReadOnly)) + emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Indexer (ft, WriteOnly)) + ] + | SymbolIndexer (symbol, ft, _) -> + let c = + let ft = func ft + comment (tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol) + |> ScopeIndependentText + [ concat newline comments |> ScopeIndependentText; c ] + | UnknownMember msgo -> + let comments = concat newline comments |> ScopeIndependentText + match msgo with + | None -> [comments] + | Some msg -> [comments; ScopeIndependentText (commentStr msg)] + +let emitTypeAliasesImpl + (baseName: string) + flags overrideFunc + (ctx: Context) + (typrms: TypeParam list) + (target: text) + (lines: {| name: string; tyargs:(TypeParam * text) list; target: text; isOverload: bool |} -> 'a list) = + let emitType_ = emitTypeImpl flags overrideFunc + let tyargs = typrms |> List.map (fun x -> tprintf "'%s" x.name) + [ + yield! lines {| name = baseName; tyargs = List.zip typrms tyargs; target = target; isOverload = false |} + let arities = getPossibleArity typrms + let maxArity = List.length tyargs + for arity in arities |> Set.toSeq |> Seq.sortDescending do + if arity <> maxArity || ctx.options.safeArity.HasProvide then + let name = Naming.createTypeNameOfArity arity None baseName + let tyargs' = List.take arity tyargs + let typrms' = List.take arity typrms + let target = + Type.appOpt + (str baseName) + [ + for tyarg in tyargs' do yield tyarg + for t in typrms |> List.skip arity do + match t.defaultType with + | None -> failwith "impossible_emitTypeAliases" + | Some t -> yield emitType_ ctx t + ] + yield! lines {| name = name; tyargs = List.zip typrms' tyargs'; target = target; isOverload = true |} + ] +(* +let emitTypeAliases flags overrideFunc ctx (typrms: TypeParam list) target = + let emitType = emitTypeImpl flags + emitTypeAliasesImpl "t" flags overrideFunc ctx typrms target ( + fun x -> [ + yield Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target |> TypeDefText + ] + ) +*) + +module GetSelfTyText = + /// `ctx.currentNamespace` should be the class + let class_ flags overrideFunc (ctx: Context) (c: Class) baseType = + let emitType = emitTypeImpl flags + let emitType_ = emitType overrideFunc + let fallback = str "private any" + match c.name with + | Name name -> + assert (name = List.last ctx.currentNamespace) + if ctx.options.subtyping |> List.contains Subtyping.Tag then + let labels = + getLabelsOfFullName flags overrideFunc ctx (ctx |> Context.getFullName []) c.typeParams + if List.isEmpty labels then fallback + else + Type.intf (emitLabels ctx labels) baseType + else fallback + | ExportDefaultUnnamedClass -> + let labels = + c.implements + |> List.map (getAllInheritancesAndSelf ctx) |> Set.unionMany + |> getLabelsFromInheritingTypes flags overrideFunc ctx + if List.isEmpty labels then fallback + else + Type.intf (emitLabels ctx labels) baseType + +let getTrie name current = + current |> Trie.getSubTrie name |> Option.defaultValue Trie.empty +let setTrie name trie current = + current |> Trie.setSubTrie name trie +let inTrie name f current = + let m = + current + |> Trie.getSubTrie name + |> Option.defaultValue Trie.empty + |> f + current |> Trie.setSubTrie name m +let set node current = current |> Trie.setOrUpdate node StructuredTextNode.union +let add name node current = current |> Trie.addOrUpdate name node StructuredTextNode.union \ No newline at end of file diff --git a/src/ts2ocaml.fsproj b/src/ts2ocaml.fsproj index 5d99e282..38eb9457 100644 --- a/src/ts2ocaml.fsproj +++ b/src/ts2ocaml.fsproj @@ -19,6 +19,9 @@ + + + diff --git a/webpack.config.js b/webpack.config.js index 34d78ca3..a352dd5c 100644 --- a/webpack.config.js +++ b/webpack.config.js @@ -39,6 +39,14 @@ module.exports = { path: path.join(__dirname, CONFIG.outputDir), filename: 'ts2ocaml.js' }, + module: { + rules: [ + { + resourceQuery: /raw/, + type: 'asset/source' + } + ] + }, plugins: [ new webpack.BannerPlugin({ banner: "#!/usr/bin/env node", diff --git a/yarn.lock b/yarn.lock index 8f874348..d1ebfbc3 100644 --- a/yarn.lock +++ b/yarn.lock @@ -2732,6 +2732,11 @@ requires-port@^1.0.0: resolved "https://registry.yarnpkg.com/requires-port/-/requires-port-1.0.0.tgz#925d2601d39ac485e091cf0da5c6e694dc3dcaff" integrity sha1-kl0mAdOaxIXgkc8NpcbmlNw9yv8= +rescript@^9.1.4: + version "9.1.4" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-9.1.4.tgz#1eb126f98d6c16942c0bf0df67c050198e580515" + integrity sha512-aXANK4IqecJzdnDpJUsU6pxMViCR5ogAxzuqS0mOr8TloMnzAjJFu63fjD6LCkWrKAhlMkFFzQvVQYaAaVkFXw== + resolve-cwd@^3.0.0: version "3.0.0" resolved "https://registry.yarnpkg.com/resolve-cwd/-/resolve-cwd-3.0.0.tgz#0f0075f1bb2544766cf73ba6a6e2adfebcb13f2d" From 459957a62a0f3154f2a620191431cecad933a48e Mon Sep 17 00:00:00 2001 From: cannorin Date: Fri, 25 Feb 2022 21:31:57 +0900 Subject: [PATCH 10/56] Better stdlib --- dist_rescript/src/Ts__min.res | 97 +++++++++++++------------- src/Targets/ReScript/ReScriptHelper.fs | 8 +-- 2 files changed, 54 insertions(+), 51 deletions(-) diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/Ts__min.res index 13fc44fd..ab274dfa 100644 --- a/dist_rescript/src/Ts__min.res +++ b/dist_rescript/src/Ts__min.res @@ -9,18 +9,18 @@ module Never = { } @unboxed type rec any = Any('a): any -let any : 'a => any = x => Any(x) +external any : 'a => any = "%identity" module Any = { type t = any - let unsafeCast : t => 'a = x => Obj.magic(x) + external unsafeCast : t => 'a = "%identity" } type unknown module Unknown = { type t = unknown - let unsafeCast = (x: t) => Obj.magic(x) + external unsafeCast : t => 'a = "%identity" } type untyped_object = Js.Types.obj_val @@ -30,7 +30,7 @@ type regexp = Js.Re.t type bigint type \"true" = private bool type \"false" = private bool -type intrinsic = private string +type intrinsic<'a> = private 'a type null<+'a> = Js.null<'a> type null' = null @@ -39,53 +39,55 @@ type undefined' = undefined type nullable<+'a> = Js.nullable<'a> module Union = { - type t<+'cases> - - let return1 : 't1 => t<[> #U1('t1)]> = x => Obj.magic(x) - let return2 : 't2 => t<[> #U2('t2)]> = x => Obj.magic(x) - let return3 : 't3 => t<[> #U3('t3)]> = x => Obj.magic(x) - let return4 : 't4 => t<[> #U4('t4)]> = x => Obj.magic(x) - let return5 : 't5 => t<[> #U5('t5)]> = x => Obj.magic(x) - let return6 : 't6 => t<[> #U6('t6)]> = x => Obj.magic(x) - let return7 : 't7 => t<[> #U7('t7)]> = x => Obj.magic(x) - let return8 : 't8 => t<[> #U8('t8)]> = x => Obj.magic(x) - - let getUnsafe1 : t<[> #U1('t1)]> => 't1 = x => Obj.magic(x) - let getUnsafe2 : t<[> #U2('t2)]> => 't2 = x => Obj.magic(x) - let getUnsafe3 : t<[> #U3('t3)]> => 't3 = x => Obj.magic(x) - let getUnsafe4 : t<[> #U4('t4)]> => 't4 = x => Obj.magic(x) - let getUnsafe5 : t<[> #U5('t5)]> => 't5 = x => Obj.magic(x) - let getUnsafe6 : t<[> #U6('t6)]> => 't6 = x => Obj.magic(x) - let getUnsafe7 : t<[> #U7('t7)]> => 't7 = x => Obj.magic(x) - let getUnsafe8 : t<[> #U8('t8)]> => 't8 = x => Obj.magic(x) + type container<+'cases> + + external return1 : 't1 => container<[> #U1('t1)]> = "%identity" + external return2 : 't2 => container<[> #U2('t2)]> = "%identity" + external return3 : 't3 => container<[> #U3('t3)]> = "%identity" + external return4 : 't4 => container<[> #U4('t4)]> = "%identity" + external return5 : 't5 => container<[> #U5('t5)]> = "%identity" + external return6 : 't6 => container<[> #U6('t6)]> = "%identity" + external return7 : 't7 => container<[> #U7('t7)]> = "%identity" + external return8 : 't8 => container<[> #U8('t8)]> = "%identity" + + external getUnsafe1 : container<[> #U1('t1)]> => 't1 = "%identity" + external getUnsafe2 : container<[> #U2('t2)]> => 't2 = "%identity" + external getUnsafe3 : container<[> #U3('t3)]> => 't3 = "%identity" + external getUnsafe4 : container<[> #U4('t4)]> => 't4 = "%identity" + external getUnsafe5 : container<[> #U5('t5)]> => 't5 = "%identity" + external getUnsafe6 : container<[> #U6('t6)]> => 't6 = "%identity" + external getUnsafe7 : container<[> #U7('t7)]> => 't7 = "%identity" + external getUnsafe8 : container<[> #U8('t8)]> => 't8 = "%identity" + + type t2<'t1, 't2> = container<[ #U1('t1) | #U2('t2) ]> + type t3<'t1, 't2, 't3> = container<[ #U1('t1) | #U2('t2) | #U3('t3) ]> + type t4<'t1, 't2, 't3, 't4> = container<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) ]> + type t5<'t1, 't2, 't3, 't4, 't5> = container<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) ]> + type t6<'t1, 't2, 't3, 't4, 't5, 't6> = container<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) ]> + type t7<'t1, 't2, 't3, 't4, 't5, 't6, 't7> = container<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) | #U7('t7) ]> + type t8<'t1, 't2, 't3, 't4, 't5, 't6, 't7, 't8> = container<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) | #U7('t7) | #U8('t8) ]> } -type union2<'t1, 't2> = Union.t<[ #U1('t1) | #U2('t2) ]> -type union3<'t1, 't2, 't3> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) ]> -type union4<'t1, 't2, 't3, 't4> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) ]> -type union5<'t1, 't2, 't3, 't4, 't5> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) ]> -type union6<'t1, 't2, 't3, 't4, 't5, 't6> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) ]> -type union7<'t1, 't2, 't3, 't4, 't5, 't6, 't7> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) | #U7('t7) ]> -type union8<'t1, 't2, 't3, 't4, 't5, 't6, 't7, 't8> = Union.t<[ #U1('t1) | #U2('t2) | #U3('t3) | #U4('t4) | #U5('t5) | #U6('t6) | #U7('t7) | #U8('t8) ]> module Intersection = { - type t<-'cases> - - let get1 : t<[> #I1('t1)]> => 't1 = x => Obj.magic(x) - let get2 : t<[> #I2('t2)]> => 't2 = x => Obj.magic(x) - let get3 : t<[> #I3('t3)]> => 't3 = x => Obj.magic(x) - let get4 : t<[> #I4('t4)]> => 't4 = x => Obj.magic(x) - let get5 : t<[> #I5('t5)]> => 't5 = x => Obj.magic(x) - let get6 : t<[> #I6('t6)]> => 't6 = x => Obj.magic(x) - let get7 : t<[> #I7('t7)]> => 't7 = x => Obj.magic(x) - let get8 : t<[> #I8('t8)]> => 't8 = x => Obj.magic(x) + type container<-'cases> + + external get1 : container<[> #I1('t1)]> => 't1 = "%identity" + external get2 : container<[> #I2('t2)]> => 't2 = "%identity" + external get3 : container<[> #I3('t3)]> => 't3 = "%identity" + external get4 : container<[> #I4('t4)]> => 't4 = "%identity" + external get5 : container<[> #I5('t5)]> => 't5 = "%identity" + external get6 : container<[> #I6('t6)]> => 't6 = "%identity" + external get7 : container<[> #I7('t7)]> => 't7 = "%identity" + external get8 : container<[> #I8('t8)]> => 't8 = "%identity" + + type t2<'t1, 't2> = container<[ #I1('t1) | #I2('t2) ]> + type t3<'t1, 't2, 't3> = container<[ #I1('t1) | #I2('t2) | #I3('t3) ]> + type t4<'t1, 't2, 't3, 't4> = container<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) ]> + type t5<'t1, 't2, 't3, 't4, 't5> = container<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) ]> + type t6<'t1, 't2, 't3, 't4, 't5, 't6> = container<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) ]> + type t7<'t1, 't2, 't3, 't4, 't5, 't6, 't7> = container<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) | #I7('t7) ]> + type t8<'t1, 't2, 't3, 't4, 't5, 't6, 't7, 't8> = container<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) | #I7('t7) | #I8('t8) ]> } -type intersection2<'t1, 't2> = Intersection.t<[ #I1('t1) | #I2('t2) ]> -type intersection3<'t1, 't2, 't3> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) ]> -type intersection4<'t1, 't2, 't3, 't4> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) ]> -type intersection5<'t1, 't2, 't3, 't4, 't5> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) ]> -type intersection6<'t1, 't2, 't3, 't4, 't5, 't6> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) ]> -type intersection7<'t1, 't2, 't3, 't4, 't5, 't6, 't7> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) | #I7('t7) ]> -type intersection8<'t1, 't2, 't3, 't4, 't5, 't6, 't7, 't8> = Intersection.t<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) | #I7('t7) | #I8('t8) ]> module Interface = { @unboxed type t<-'tags, 'base> = { value: 'base } @@ -93,6 +95,7 @@ module Interface = { let value = (x: t<_, _>) => x.value } type intf<-'tags, 'base> = Interface.t<'tags, 'base> +type intf'<-'tags> = intf<'tags, any> module Primitive = { type cases<'other> = [ #Null | #Undefined | #String(string) | #Number(float) | #Boolean(bool) | #Symbol(symbol) | #BigInt(bigint) | #Other('other) ] diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index e40c3eb2..7bb9aeca 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -307,15 +307,15 @@ module Type = | [] -> failwith "union type with zero elements" | x :: [] -> x | x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: rest -> - app (str "union8") [x1; x2; x3; x4; x5; x6; x7; union (x8 :: rest)] - | xs -> app (tprintf "union%i" (List.length xs)) xs + app (str "Union.t8") [x1; x2; x3; x4; x5; x6; x7; union (x8 :: rest)] + | xs -> app (tprintf "Union.t%i" (List.length xs)) xs let rec intersection = function | [] -> failwith "intersection type with zero elements" | x :: [] -> x | x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: rest -> - app (str "intersection8") [x1; x2; x3; x4; x5; x6; x7; intersection (x8 :: rest)] - | xs -> app (tprintf "intersection%i" (List.length xs)) xs + app (str "Intersection.t8") [x1; x2; x3; x4; x5; x6; x7; intersection (x8 :: rest)] + | xs -> app (tprintf "Intersection.t%i" (List.length xs)) xs let newable args retTy = match args with From f2278482ed72c43576f097bf5326747650c7c73d Mon Sep 17 00:00:00 2001 From: cannorin Date: Fri, 25 Feb 2022 21:39:31 +0900 Subject: [PATCH 11/56] Embed stdlib --- src/Targets/ReScript/Common.fs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 6abeeb68..ba426efc 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -209,4 +209,6 @@ type Output = { fileName: string content: text stubLines: string list -} \ No newline at end of file +} + +let [] stdlib: string = jsNative \ No newline at end of file From 50b3731a6df6d10740b4622b8d4f67d07bf544bf Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 28 Feb 2022 17:43:03 +0900 Subject: [PATCH 12/56] Emit StructuredText --- dist_rescript/src/Ts__min.res | 31 +- src/Targets/ReScript/ReScriptHelper.fs | 58 +- src/Targets/ReScript/Writer.fs | 750 +++++++++++++++++++++++-- 3 files changed, 766 insertions(+), 73 deletions(-) diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/Ts__min.res index ab274dfa..2ef4730c 100644 --- a/dist_rescript/src/Ts__min.res +++ b/dist_rescript/src/Ts__min.res @@ -110,14 +110,14 @@ module Primitive = { } })(x)`) - let fromNull: null<'a> => t<[> #Null | #Other('a) ]> = Obj.magic - let toNull: t<[< #Null | #Other('a) ]> => null<'a> = Obj.magic + external fromNull: null<'a> => t<[> #Null | #Other('a) ]> = "%identity" + external toNull: t<[< #Null | #Other('a) ]> => null<'a> = "%identity" - let fromUndefined: undefined<'a> => t<[> #Undefined | #Other('a) ]> = Obj.magic - let toUndefined: t<[< #Undefined | #Other('a) ]> => undefined<'a> = Obj.magic + external fromUndefined: undefined<'a> => t<[> #Undefined | #Other('a) ]> = "%identity" + external toUndefined: t<[< #Undefined | #Other('a) ]> => undefined<'a> = "%identity" - let fromNullable: nullable<'a> => t<[> #Null | #Undefined | #Other('a) ]> = Obj.magic - let toNullable: t<[< #Null | #Undefined | #Other('a) ]> => nullable<'a> = Obj.magic + external fromNullable: nullable<'a> => t<[> #Null | #Undefined | #Other('a) ]> = "%identity" + external toNullable: t<[< #Null | #Undefined | #Other('a) ]> => nullable<'a> = "%identity" let classify: t<[< cases<'other>] as 'cases> => 'cases = x => switch (Js.typeof(x)) { @@ -132,7 +132,6 @@ module Primitive = { else { Obj.magic(#Other(x)) } } } -type prim<+'cases> = Primitive.t<'cases> module Interop = { let apply0 = (it: 'Function) => %raw(`it()`) @@ -185,31 +184,31 @@ module Variadic = { type tn<'args, 'variadic, 't> @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) - let create0 : ('variadic => 't) => t0<'variadic, 't> = f => %raw(`(function(...args) { return f(args); })`) + let make0 : ('variadic => 't) => t0<'variadic, 't> = f => %raw(`(function(...args) { return f(args); })`) @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) - let create1 : (('arg1, 'variadic) => 't) => t1<'arg1, 'variadic, 't> = f => %raw(`(function(arg1, ...args) { return f(arg1, args); })`) + let make1 : (('arg1, 'variadic) => 't) => t1<'arg1, 'variadic, 't> = f => %raw(`(function(arg1, ...args) { return f(arg1, args); })`) @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) - let create2 : (('arg1, 'arg2, 'variadic) => 't) => tn<('arg1, 'arg2), 'variadic, 't> = f => %raw(`(function(arg1, arg2, ...args) { return f(arg1, arg2, args); })`) + let make2 : (('arg1, 'arg2, 'variadic) => 't) => tn<('arg1, 'arg2), 'variadic, 't> = f => %raw(`(function(arg1, arg2, ...args) { return f(arg1, arg2, args); })`) @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) - let create3 : (('arg1, 'arg2, 'arg3, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, ...args) { return f(arg1, arg2, arg3, args); })`) + let make3 : (('arg1, 'arg2, 'arg3, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, ...args) { return f(arg1, arg2, arg3, args); })`) @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) - let create4 : (('arg1, 'arg2, 'arg3, 'arg4, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, ...args) { return f(arg1, arg2, arg3, arg4, args); })`) + let make4 : (('arg1, 'arg2, 'arg3, 'arg4, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, ...args) { return f(arg1, arg2, arg3, arg4, args); })`) @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) - let create5 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, ...args) { return f(arg1, arg2, arg3, arg4, arg5, args); })`) + let make5 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, ...args) { return f(arg1, arg2, arg3, arg4, arg5, args); })`) @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) - let create6 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, arg6, ...args) { return f(arg1, arg2, arg3, arg4, arg5, arg6, args); })`) + let make6 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, arg6, ...args) { return f(arg1, arg2, arg3, arg4, arg5, arg6, args); })`) @ocaml.doc(`\`'variadic\` is expected to be array or some other iterable type.`) - let create7 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'arg7, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'arg7), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, arg6, arg7, ...args) { return f(arg1, arg2, arg3, arg4, arg5, arg6, arg7, args); })`) + let make7 : (('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'arg7, 'variadic) => 't) => tn<('arg1, 'arg2, 'arg3, 'arg4, 'arg5, 'arg6, 'arg7), 'variadic, 't> = f => %raw(`(function(arg1, arg2, arg3, arg4, arg5, arg6, arg7, ...args) { return f(arg1, arg2, arg3, arg4, arg5, arg6, arg7, args); })`) @ocaml.doc(`\`'args\` must be a tuple type. \`'variadic\` is expected to be array or some other iterable type.`) - let createN : (('args, 'variadic) => 't, int) => tn<'args, 'variadic, 't> = (f, n) => %raw(`(function(...args) { return f(args.slice(0, n), args.slice(n)); })`) + let makeN : (('args, 'variadic) => 't, int) => tn<'args, 'variadic, 't> = (f, n) => %raw(`(function(...args) { return f(args.slice(0, n), args.slice(n)); })`) let apply0 = (f0: t0<'variadic, 't>, variadic: 'variadic) : 't => %raw(`f0(...variadic)`) let apply1 = (f1: t1<'arg1, 'variadic, 't>, arg1: 'arg1, variadic: 'variadic) : 't => %raw(`f1(arg1, ...variadic)`) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 7bb9aeca..23e56c1b 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -55,6 +55,9 @@ module Attr = /// https://rescript-lang.org/docs/manual/latest/bind-to-js-object#bind-using-special-getter-and-setter-attributes let set_index = str "@set_index" + /// https://rescript-lang.org/docs/manual/latest/generate-converters-accessors#convert-external-into-js-object-creation-function + let obj = str "@obj" + module ExternalModifier = /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#variadic-function-arguments let variadic = str "@variadic" @@ -111,7 +114,7 @@ module Naming = let reservedValueNames = set [ - "create"; "apply"; "invoke"; "get"; "set"; "castFrom" + "make"; "apply"; "get"; "set"; "castFrom" ] |> Set.union keywords let upperFirst (s: string) = @@ -152,10 +155,6 @@ module Naming = let s = String.concat "_" name |> removeInvalidChars |> upperFirst if keywords |> Set.contains s then s + "_" else s - let flattenedTypeName (name: string list) = - let s = String.concat "_" name |> removeInvalidChars |> lowerFirst - if keywords |> Set.contains s then s + "_" else s - let structured (baseName: string -> string) (name: string list) = let rec prettify = function | [] -> "" @@ -170,6 +169,28 @@ module Naming = else sprintf "%s%d" name arity | None -> sprintf "%s%d" name arity + let private jsModuleNameToReScriptName (jsModuleName: string) = + match jsModuleName.TrimStart('@') |> String.splitThenRemoveEmptyEntries "/" |> Array.toList with + | xs -> + xs + |> List.map (fun n -> + n |> Naming.toCase Naming.Case.LowerSnakeCase) + |> String.concat "__" + + let jsModuleNameToFileName isInterfaceFile (jsModuleName: string) = + jsModuleName + |> jsModuleNameToReScriptName + |> fun x -> if isInterfaceFile then $"{x}.resi" else $"{x}.res" + + let jsModuleNameToReScriptModuleName (jsModuleName: string) = + jsModuleName + |> jsModuleNameToReScriptName + |> moduleName + +module Kind = + let generatesReScriptModule kind = + Set.intersect kind (Set.ofList [Kind.Type; Kind.ClassLike; Kind.Module]) |> Set.isEmpty |> not + [] module Type = /// non-primitive types defined in the standard library @@ -295,12 +316,15 @@ module Type = let null_or_undefined_or t = app (str "nullable") [t] let null_ = str "null'" let undefined = str "undefined'" - let intrinsic = app (str "intrinsic") [object] + let intrinsic = app (str "intrinsic") [string] let true_ = str "\\\"true\"" let false_ = str "\\\"false\"" // our types - let intf tags baseTy = app (str "intf") [tags; baseTy] + let intf tags baseTy = + match baseTy with + | Some t -> app (str "intf") [tags; t] + | None -> app (str "intf'") [tags] let prim cases = app (str "prim") [cases] let rec union = function @@ -373,19 +397,25 @@ module Term = [] module Statement = + let attr attrs = + if List.isEmpty attrs then empty + else concat (str " ") attrs + newline + let let_ (attrs: text list) name typ value = - concat (str " ") attrs - + tprintf "let %s: " name + typ +@ " = " + value + attr attrs + tprintf "let %s: " name + typ +@ " = " + value let val_ (attrs: text list) name typ = - concat (str " ") attrs - + tprintf "let %s: " name + typ + attr attrs + tprintf "let %s: " name + typ let external (attrs: text list) name (typ: text) target = - concat (str " ") attrs - + tprintf " external %s: " name + typ + tprintf " = \"%s\"" target + attr attrs + tprintf "external %s: " name + typ + tprintf " = \"%s\"" target let typeAlias name tyargs ty = str "type " + (if List.isEmpty tyargs then str name else Type.app (str name) tyargs) - +@ " = " + ty \ No newline at end of file + +@ " = " + ty + + let include_ name = tprintf "include %s" name + let open_ name = tprintf "open %s" name + + let moduleAlias name target = tprintf "module %s = %s" name target \ No newline at end of file diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 1cb25ffe..b4936f9e 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -10,6 +10,10 @@ open DataTypes.Text open Targets.ReScript.Common open Targets.ReScript.ReScriptHelper +let [] stdlibEsSrc = "lib.es.d.ts" +let [] stdlibDomSrc = "lib.dom.d.ts" +let [] stdlibWebworkerSrc = "lib.webworker.d.ts" + type ScriptTarget = TypeScript.Ts.ScriptTarget type State = {| @@ -171,7 +175,7 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C | _ -> fallback () tyName |> withTyargs | Some (fn, typrms, origLoc) -> - let name = Naming.flattenedTypeName fn.name + let name = Naming.structured Naming.moduleName fn.name + ".t" let ts = assignTypeParams fn.name (origLoc ++ loc) typrms tyargs (fun _ t -> t) @@ -400,6 +404,7 @@ type Scope = { type [] Binding = | Let of {| name: string; ty: text; body: text; attrs: text list; comments: text list |} | Ext of {| name: string; ty: text; target: string; attrs: text list; comments: text list |} + | Unknown of {| msg:text option; comments: text list |} let let_ (attrs: text list) comments name ty body = Binding.Let {| name = name; ty = ty; body = body; attrs = attrs; comments = comments |} @@ -407,10 +412,44 @@ let let_ (attrs: text list) comments name ty body = let ext (attrs: text list) comments name ty target = Binding.Ext {| name = name; ty = ty; target = target; attrs = attrs; comments = comments |} +let unknownBinding comments msg = + Binding.Unknown {| msg = msg; comments = comments |} + +let cast comments name ty = + Binding.Ext {| name = name; ty = ty; target = "%identity"; attrs = []; comments = comments |} + +let builder name (fields: {| isOptional: bool; name: string; value: text |} list) (thisType: text) = + let args = + fields + |> List.map (fun f -> + let name = + if Naming.isValid name && (name[0] = '_' || System.Char.IsLower(name[0])) then name + else String.escape name |> sprintf "\\\"%s\"" + let suffix = + if f.isOptional then "=?" else "" + tprintf "~%s: " name + f.value +@ suffix) + let args = + match List.tryLast fields with + | None -> args + | Some last -> if last.isOptional then args @ [Type.void_] else args + let ty = + Type.curriedArrow args thisType + Binding.Ext {| name = name; ty = ty; target = ""; attrs = [Attr.External.obj]; comments = []|} + +type EmitCondition = { + /// Emit in the `Types` module in `.res` + onTypes: bool + /// Emit in `.res` + onImpl: bool + /// Emit in `.resi` + onIntf: bool +} with + static member empty = { onTypes = false; onImpl = false; onIntf = false } + type StructuredTextItem = | ImportText of text // import texts should be at the top of the module | TypeDefText of text // and type definitions should come next - | Conditional of res:StructuredTextItem list * resi:StructuredTextItem list + | Conditional of StructuredTextItem * EmitCondition | ScopeIndependentText of text // floating comments, etc | Binding of (OverloadRenamer -> Scope -> Binding) @@ -423,7 +462,7 @@ and StructuredTextNode = {| /// By default, key is used as a scope. `Some scope` to override it. scope: string option items: StructuredTextItem list - docCommentLines: text list + comments: text list exports: ExportItem list knownTypes: Set anonymousInterfaces: Set @@ -431,12 +470,11 @@ and StructuredTextNode = {| and StructuredText = Trie -let inline OnRes texts = Conditional (texts, []) -let inline OnResi texts = Conditional ([], texts) +let inline conditional cond x = Conditional (x, cond) module StructuredTextNode = let empty : StructuredTextNode = - {| scope = None; items = []; docCommentLines = []; exports = []; knownTypes = Set.empty; anonymousInterfaces = Set.empty |} + {| scope = None; items = []; comments = []; exports = []; knownTypes = Set.empty; anonymousInterfaces = Set.empty |} let union (a: StructuredTextNode) (b: StructuredTextNode) : StructuredTextNode = let mergeScope s1 s2 = match s1, s2 with @@ -445,7 +483,7 @@ module StructuredTextNode = | None, None -> None {| scope = mergeScope a.scope b.scope items = List.append a.items b.items - docCommentLines = List.append a.docCommentLines b.docCommentLines + comments = List.append a.comments b.comments exports = List.append a.exports b.exports knownTypes = Set.union a.knownTypes b.knownTypes anonymousInterfaces = Set.union a.anonymousInterfaces b.anonymousInterfaces |} @@ -510,8 +548,6 @@ module StructuredText = let removeLabels (xs: Choice list) = xs |> List.map (function Choice2Of2 t -> Choice2Of2 t | Choice1Of2 fl -> Choice2Of2 fl.value) -let inline func ft = Func (ft, [], ft.loc) - let emitComments (comments: Comment list) : text list = // TODO [] @@ -519,28 +555,33 @@ let emitComments (comments: Comment list) : text list = let inline binding (f: (string -> string) -> Scope -> Binding) = [Binding (fun renamer scope -> f (renamer.Rename "value") scope)] +let scopeToAttr (s: Scope) attr = + match s.scopeRev, s.moduleName with + | [], None -> attr + | sr, None -> Attr.External.scope (List.rev sr) :: attr + | sr, Some m -> + Attr.External.module_ (Some m) :: Attr.External.scope (List.rev sr) :: attr + +let func flags overrideFunc ctx (ft: FuncType) = + Func (ft, [], ft.loc) |> emitTypeImpl flags overrideFunc ctx + +let extFunc flags overrideFunc ctx (ft: FuncType) = + let c = classifyExternalFunction flags ft + let ty = func c.flags overrideFunc ctx ft + let attr = [ + if c.isNullable then yield Attr.ExternalModifier.return_nullable + if c.isVariadic then yield Attr.ExternalModifier.variadic + ] + ty, attr + let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: bool) (ma: MemberAttribute) m = let flags = { flags with simplifyContravariantUnion = true } let emitType_ = emitTypeImpl flags overrideFunc let comments = emitComments ma.comments - let scopeToAttr (s: Scope) attr = - match s.scopeRev, s.moduleName with - | [], None -> attr - | sr, None -> Attr.External.scope (List.rev sr) :: attr - | sr, Some m -> - Attr.External.module_ (Some m) :: Attr.External.scope (List.rev sr) :: attr - - let extFunc (ft: FuncType) = - let c = classifyExternalFunction flags ft - let ty = emitTypeImpl c.flags overrideFunc ctx (func ft) - let attr = [ - if c.isNullable then yield Attr.ExternalModifier.return_nullable - if c.isVariadic then yield Attr.ExternalModifier.variadic - ] - ty, attr - let inline func ft = func ft |> emitType_ ctx + let inline extFunc ft = extFunc flags overrideFunc ctx ft + let inline func ft = func flags overrideFunc ctx ft let generateCallable isNewable (args: Choice list) = let used = @@ -592,21 +633,23 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: self, attrs | [] -> failwithf "impossible_emitMembers_Constructor(%s)" ma.loc.AsString let attrs = Attr.External.new_ :: attrs |> List.rev - ext attrs comments (rename "create") ty target + ext attrs comments (rename "make") ty target ) | Newable (ft, _typrm) -> let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args } let value = generateCallable true ft.args - binding (fun rename _ -> let_ [] comments (rename "create") ty value) + binding (fun rename _ -> let_ [] comments (rename "make") ty value) | Callable (ft, _typrm) -> let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args } let value = generateCallable false ft.args - binding (fun rename _ -> let_ [] comments (rename "invoke") ty value) + binding (fun rename _ -> let_ [] comments (rename "apply") ty value) | Field ({ name = name; value = Func (ft, _typrm, _) }, _) | Method (name, ft, _typrm) -> let name = Naming.valueName name let ty, attrs = - if ma.isStatic then extFunc ft + if ma.isStatic then + let ty, attr = extFunc ft + ty, Attr.External.val_ :: attr else let ft = { ft with args = Choice2Of2 PolymorphicThis :: ft.args } let ty, attr = extFunc ft @@ -687,14 +730,10 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: | SymbolIndexer (symbol, ft, _) -> let c = let ft = func ft - comment (tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol) - |> ScopeIndependentText - [ concat newline comments |> ScopeIndependentText; c ] + tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol + binding (fun _ _ -> unknownBinding comments (Some c)) | UnknownMember msgo -> - let comments = concat newline comments |> ScopeIndependentText - match msgo with - | None -> [comments] - | Some msg -> [comments; ScopeIndependentText (commentStr msg)] + binding (fun _ _ -> unknownBinding comments (msgo |> Option.map str)) let emitTypeAliasesImpl (baseName: string) @@ -727,19 +766,23 @@ let emitTypeAliasesImpl yield! lines {| name = name; tyargs = List.zip typrms' tyargs'; target = target; isOverload = true |} ] -(* let emitTypeAliases flags overrideFunc ctx (typrms: TypeParam list) target = let emitType = emitTypeImpl flags emitTypeAliasesImpl "t" flags overrideFunc ctx typrms target ( - fun x -> [ - yield Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target |> TypeDefText - ] + fun x -> [Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target |> TypeDefText] + ) + +let emitTypeAlias flags overrideFunc ctx (typrms: TypeParam list) target = + let emitType = emitTypeImpl flags + emitTypeAliasesImpl "t" flags overrideFunc ctx typrms target ( + fun x -> + if not x.isOverload then [Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target |> TypeDefText] + else [] ) -*) module GetSelfTyText = /// `ctx.currentNamespace` should be the class - let class_ flags overrideFunc (ctx: Context) (c: Class) baseType = + let class_ flags overrideFunc (ctx: Context) (c: Class) (baseType: text option) = let emitType = emitTypeImpl flags let emitType_ = emitType overrideFunc let fallback = str "private any" @@ -762,6 +805,9 @@ module GetSelfTyText = else Type.intf (emitLabels ctx labels) baseType + let enumCases (e: Enum) (cases: EnumCase list) = + failwith "TODO" + let getTrie name current = current |> Trie.getSubTrie name |> Option.defaultValue Trie.empty let setTrie name trie current = @@ -774,4 +820,622 @@ let inTrie name f current = |> f current |> Trie.setSubTrie name m let set node current = current |> Trie.setOrUpdate node StructuredTextNode.union -let add name node current = current |> Trie.addOrUpdate name node StructuredTextNode.union \ No newline at end of file +let add name node current = current |> Trie.addOrUpdate name node StructuredTextNode.union + +let getExportFromStatement (ctx: Context) (name: string) (kind: Kind list) (kindString: string) (s: Statement) : ExportItem option = + let fn = ctx |> Context.getFullName [name] + let ident = { name = [name]; fullName = [fn]; kind = Some (Set.ofList kind); parent = None; loc = s.loc } + match s.isExported.AsExport ident with + | None -> None + | Some clause -> + let prefix = + match clause with + | ES6DefaultExport _ -> "export default" + | _ -> "export" + Some (ExportItem.Export {| comments = []; clauses = [clause, Set.ofList kind]; loc = s.loc; origText = sprintf "%s %s %s" prefix kindString name |}) + +type [] ClassKind<'a, 'b, 'c> = + | NormalClass of 'a + | ExportDefaultClass of 'b + | AnonymousInterface of 'c + +let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c: ClassOrAnonymousInterface) (additionalMembers: Context -> EmitTypeFlags -> OverrideFunc -> list, additionalKnownTypes: Set, forceScope: string option) = + let emitType orf ctx ty = emitTypeImpl flags orf ctx ty + + let typrms = List.map (fun (tp: TypeParam) -> TypeVar tp.name) c.typeParams + let kind, selfTy, overrideFunc = + match c.name with + | Choice1Of2 (Name n) -> + let k = ctx |> Context.getFullName [n] + let ident = { name = [n]; fullName = [k]; kind = Some (Set.ofList Kind.OfClass); parent = None; loc = UnknownLocation } + let selfTy = + if List.isEmpty c.typeParams then Ident ident + else App (AIdent ident, typrms, UnknownLocation) + ClassKind.NormalClass {| name = n; orig = c.MapName(fun _ -> Name n) |}, + selfTy, + overrideFunc + | Choice1Of2 ExportDefaultUnnamedClass -> + ClassKind.ExportDefaultClass {| orig = c.MapName(fun _ -> ExportDefaultUnnamedClass) |}, + PolymorphicThis, + overrideFunc + | Choice2Of2 Anonymous -> + let ai = c.MapName (fun _ -> Anonymous) + match ctx |> Context.bindCurrentSourceInfo (fun info -> info.anonymousInterfacesMap |> Map.tryFind ai) with + | None -> failwith "impossible_emitClass_unknown_anonymousInterface" + | Some i -> + let selfTy = + if List.isEmpty c.typeParams then AnonymousInterface ai + else App (AAnonymousInterface ai, typrms, UnknownLocation) + let orf _flags _emitType _ctx = function + | AnonymousInterface a when a = ai -> Some (str "t") + | App (AAnonymousInterface a, ts, _) when a = ai -> + Some (Type.appOpt (str "t") (ts |> List.map (_emitType _ctx))) + | _ -> None + ClassKind.AnonymousInterface {| + name = anonymousInterfaceModuleName ctx i + orig = c.MapName(fun _ -> Anonymous) + |}, + selfTy, + OverrideFunc.combine overrideFunc orf + + let knownTypes = + let dummy = c.MapName(fun _ -> ExportDefaultUnnamedClass) + Statement.getKnownTypes ctx [Class dummy] |> Set.union additionalKnownTypes + + let isAnonymous, isExportDefaultClass = + match kind with + | ClassKind.AnonymousInterface _ -> true, false + | ClassKind.ExportDefaultClass _ -> false, true + | ClassKind.NormalClass _ -> false, false + + let node = + let ctx, innerCtx = + (), + ctx + |> (match kind with + | ClassKind.NormalClass x -> Context.ofChildNamespace x.name + | ClassKind.AnonymousInterface x -> Context.ofChildNamespace x.name + | ClassKind.ExportDefaultClass _ -> id) + |> Context.mapOptions (fun options -> + if not isAnonymous then options + else + // no need to generate t_n types for anonymous interfaces + ctx.options |> JS.cloneWith (fun o -> o.safeArity <- o.safeArity.WithProvide(false))) + let typrms = List.map (fun (tp: TypeParam) -> tprintf "'%s" tp.name) c.typeParams + let selfTyText = Type.appOpt (str "t") typrms + let currentNamespace = innerCtx |> Context.getFullName [] + + let labels = + let emitType_ = emitType overrideFunc // labels should not have polymorphic this type + match kind with + | ClassKind.NormalClass _ -> + getLabelsOfFullName flags overrideFunc innerCtx currentNamespace c.typeParams + | ClassKind.ExportDefaultClass _ -> + c.implements + |> List.map (getAllInheritancesAndSelf innerCtx) |> Set.unionMany + |> getLabelsFromInheritingTypes flags overrideFunc innerCtx + | ClassKind.AnonymousInterface _ -> [] + + let useTags = + not isAnonymous + && innerCtx.options.subtyping |> List.contains Subtyping.Tag + && not (List.isEmpty labels) + + let polymorphicThis = + if useTags then + Type.appOpt (str "this") (str "'tags" :: str "'base" :: typrms) + else + selfTyText + + let overrideFunc = + OverrideFunc.combine overrideFunc <| + fun _flags _emitType _ctx -> function + | PolymorphicThis -> Some polymorphicThis + | _ -> None + + let emitType_ ctx ty = emitType overrideFunc ctx ty + let members = [ + for ma, m in c.members do + yield! emitMembers flags overrideFunc innerCtx PolymorphicThis isExportDefaultClass ma m + yield! additionalMembers innerCtx flags overrideFunc + ] + + let scope = + match kind with + | ClassKind.ExportDefaultClass _ -> None + | _ -> forceScope + + let comments = c.comments |> emitComments + + let tagsDefinition = + if useTags && innerCtx.options.inheritWithTags.HasProvide then + let alias = + emitTypeAliasesImpl + "tags" flags overrideFunc innerCtx c.typeParams (emitLabels innerCtx labels) + (fun x -> [Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target]) + |> concat newline + alias|> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some + else None + + let polymorphicThisDefinition = + if useTags then + let tags = + getLabelOfFullName flags overrideFunc innerCtx currentNamespace c.typeParams + |> function Choice1Of2 xs -> xs | Choice2Of2 (_, x) -> [x] + |> emitLabelsBody innerCtx + |> between "[> " " ]" + Statement.typeAlias "this" + (str "'tags" :: str "'base" :: typrms) + (Type.intf (str "'tags") (Some (str "'base")) +@ " constraint 'tags = " + tags) + |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some + else None + + let baseType, baseTypeDefinition = + let fallback () = + // TODO + None, [] + match kind with + | ClassKind.ExportDefaultClass _ | ClassKind.AnonymousInterface _ -> fallback () + | ClassKind.NormalClass x -> + if not innerCtx.options.stdlib then fallback () + else if innerCtx.currentSourceFile = stdlibEsSrc then + match Type.predefinedTypes |> Map.tryFind x.name with + | Some t -> Some (str t), [] + | None -> fallback () + else if innerCtx.currentSourceFile = stdlibDomSrc then + match Type.predefinedDOMTypes.TryGetValue(x.name) with + | true, t -> Some (str t), [] + | false, _ -> fallback () + else fallback () + + let typeDefinition = + let selfTyText = + match kind with + | ClassKind.NormalClass x -> GetSelfTyText.class_ flags overrideFunc innerCtx x.orig baseType + | ClassKind.ExportDefaultClass x -> GetSelfTyText.class_ flags overrideFunc innerCtx x.orig None + | ClassKind.AnonymousInterface _ -> str "private any" + + let onTypes = + emitTypeAlias flags overrideFunc innerCtx c.typeParams selfTyText + |> List.map (conditional { EmitCondition.empty with onTypes = true }) + + let onIntf = + emitTypeAliases flags overrideFunc innerCtx c.typeParams selfTyText + |> List.map (conditional { EmitCondition.empty with onIntf = true }) + + let onImpl = + let selfTyText = + let tyargs = c.typeParams |> List.map (fun x -> tprintf "'%s" x.name) + Type.appOpt (str "t") tyargs + emitTypeAliases flags overrideFunc innerCtx c.typeParams selfTyText + |> List.map (conditional { EmitCondition.empty with onImpl = true }) + + List.concat [onTypes; onIntf; onImpl] + + let castFunctions = [ + // add a generic cast function if tag is available + if useTags then + let castTy = + Type.curriedArrow [polymorphicThis] selfTyText + yield! binding (fun _ _ -> cast [] "castFrom" castTy) + + if innerCtx.options.subtyping |> List.contains Subtyping.CastFunction then + let inline func ft = func flags overrideFunc innerCtx ft + for parent in c.implements do + let ty = func { isVariadic = false; args = [Choice2Of2 selfTy]; returnType = parent; loc = UnknownLocation } + let parentName = getHumanReadableName innerCtx parent + yield! binding (fun rename _ -> cast [] (rename $"cast_to_{parentName}") ty) + ] + + let builder = + let emitType_ ctx ty = + emitTypeImpl { flags with needParen = true; variance = Contravariant } overrideFunc ctx ty + if not c.isPOJO then [] + else + let field (fl: FieldLike) = + let value, isOptional = + match fl.value with + | Prim Null | Prim Undefined -> Prim Never, true + | Union u -> + let nulls, others = + u.types |> List.partition (function Prim Null | Prim Undefined -> true | _ -> false) + if List.isEmpty nulls then fl.value, fl.isOptional + else Union { types = others }, true + | _ -> fl.value, fl.isOptional + {| fl with value = value |> emitType_ innerCtx; isOptional = isOptional |} + let fields = + c.members + |> List.choose (fun (ma, m) -> + match m with + | Field (fl, (Mutable | ReadOnly)) -> Some (field fl) + | Getter fl -> Some (field fl) + (* + | Method (name, ft, _) -> + let value = emitType_ innerCtx (Func (ft, [], ma.loc)) + Some {| isOptional = false; name = name; value = value |} + *) + | _ -> None) + binding (fun rename _ -> builder (rename "create") fields selfTyText) + + let items = [ + yield! baseTypeDefinition + yield! typeDefinition + yield! tagsDefinition |> Option.toList + yield! polymorphicThisDefinition |> Option.toList + yield! members + yield! builder + yield! castFunctions + ] + + {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes; scope = scope |} + + let export = + match kind with + | ClassKind.NormalClass x -> + let kind = + if not c.isInterface || node.scope.IsSome then Kind.OfClass + else Kind.OfInterface + getExportFromStatement ctx x.name kind (if c.isInterface then "interface" else "class") (Class x.orig) + | _ -> None + + let addAsNode (name: string) = + current + |> add [name] node + |> inTrie [name] (addAnonymousInterface flags ctx knownTypes) + |> set {| StructuredTextNode.empty with exports = Option.toList export |} + + match kind with + | ClassKind.NormalClass x -> addAsNode x.name + | ClassKind.AnonymousInterface x -> addAsNode x.name + | ClassKind.ExportDefaultClass _ -> + current + |> set {| + StructuredTextNode.empty with + scope = None + exports = [ExportItem.DefaultUnnamedClass node] + |} + |> addAnonymousInterface flags ctx knownTypes + +and addAnonymousInterfaceExcluding emitTypeFlags (ctx: Context) knownTypes ais (current: StructuredText) = + knownTypes + |> Seq.choose (function KnownType.AnonymousInterface (a, info) -> Some (a, info) | _ -> None) + |> Seq.filter (fun (a, _) -> ais |> List.contains a |> not) + |> Seq.fold (fun (current: StructuredText) (a, _) -> + let shouldSkip = + current.value + |> Option.map (fun v -> v.anonymousInterfaces |> Set.contains a) + |> Option.defaultValue false + if shouldSkip then current + else + emitClass emitTypeFlags OverrideFunc.noOverride ctx current (a.MapName Choice2Of2) ((fun _ _ _ -> []), Set.empty, None) + |> set {| StructuredTextNode.empty with anonymousInterfaces = Set.singleton a |} + ) current +and addAnonymousInterface emitTypeFlags ctx knownTypes (current: StructuredText) = addAnonymousInterfaceExcluding emitTypeFlags ctx knownTypes [] current + +let emitVariable flags overrideFunc ctx (v: Variable) = + let emitType = emitTypeImpl flags + let emitType_ = emitType overrideFunc + let inline extFunc ft = extFunc flags overrideFunc ctx ft + let ty, attr = + match v.typ with + | Func (ft, _, _) -> + let ty, attr = extFunc ft + ty, Attr.External.val_ :: attr + | _ -> emitType_ ctx v.typ, [Attr.External.val_] + let comments = emitComments v.comments + binding (fun rename s -> + ext (scopeToAttr s attr) comments (Naming.valueName v.name |> rename) ty v.name + ) + +let emitFunction flags overrideFunc ctx (f: Function) = + let emitType = emitTypeImpl flags + let emitType_ = emitType overrideFunc + let inline extFunc ft = extFunc flags overrideFunc ctx ft + let ty, attr = extFunc f.typ + let comments = emitComments f.comments + binding (fun rename s -> + ext (scopeToAttr s (Attr.External.val_ :: attr)) comments (Naming.valueName f.name |> rename) ty f.name + ) + +let emitImport (ctx: Context) (i: Import) : StructuredTextItem list = + let emitImportClause (c: ImportClause) = + let getModuleName (specifier: string) = + if specifier.StartsWith(".") |> not then Naming.jsModuleNameToReScriptModuleName specifier |> Some + else + match JsHelper.tryGetActualFileNameFromRelativeImportPath ctx.currentSourceFile ctx.state.fileNames specifier with + | Some _ -> None // if the imported file is included in the input files, skip emitting it + | None -> + JsHelper.resolveRelativeImportPath (ctx.state.info |> Result.toOption) ctx.currentSourceFile ctx.state.fileNames specifier + |> JsHelper.InferenceResult.tryUnwrap + |> Option.defaultValue specifier + |> Naming.jsModuleNameToReScriptModuleName + |> Some + + let isModule (name: string) (kind: Set option) = + i.isTypeOnly + || kind |> Option.map Kind.generatesReScriptModule + |> Option.defaultValue false + || ctx |> Context.tryCurrentSourceInfo (fun i -> i.unknownIdentTypes |> Trie.containsKey [name]) + |> Option.defaultValue false + || name |> Naming.isCase Naming.PascalCase + + match c with + | LocalImport x -> + let shouldEmit = + match x.kind with + | Some kind -> kind |> Kind.generatesReScriptModule + | None -> x.target |> Ident.getKind ctx |> Kind.generatesReScriptModule + if shouldEmit then + [Statement.moduleAlias (Naming.moduleName x.name) (x.target.name |> Naming.structured Naming.moduleName) |> ImportText] + else [] + | NamespaceImport x when isModule x.name x.kind -> + getModuleName x.specifier + |> Option.map (fun moduleName -> + [Statement.moduleAlias (Naming.moduleName x.name) (sprintf "%s.Export" moduleName) |> ImportText]) + |> Option.defaultValue [] + | ES6WildcardImport s -> + getModuleName s + |> Option.map (fun moduleName -> [Statement.open_ (sprintf "%s.Export" moduleName) |> ImportText]) + |> Option.defaultValue [] + | ES6DefaultImport x when isModule x.name x.kind -> + getModuleName x.specifier + |> Option.map (fun moduleName -> + [Statement.moduleAlias (Naming.moduleName x.name) (sprintf "%s.Export.Default" moduleName) |> ImportText]) + |> Option.defaultValue [] + | ES6Import x when isModule x.name x.kind -> + let name = + match x.renameAs with + | Some name -> Naming.moduleName name + | None -> Naming.moduleName x.name + getModuleName x.specifier + |> Option.map (fun moduleName -> + [Statement.moduleAlias name (sprintf "%s.Export.%s" moduleName (Naming.moduleName x.name)) |> ImportText]) + |> Option.defaultValue [] + | NamespaceImport _ | ES6DefaultImport _ | ES6Import _ -> [] + + [ yield! emitComments i.comments |> List.map (ImportText >> conditional { onImpl = true; onIntf = true; onTypes = false }) + yield commentStr i.origText |> ImportText + for c in i.clauses do + yield! emitImportClause c] + +let emitTypeAliasToUnionFunctions flags overrideFunc ctx (u: UnionType) : StructuredTextItem list = + failwith "TODO" + +let createStructuredText (rootCtx: Context) (stmts: Statement list) : StructuredText = + let emitTypeFlags = EmitTypeFlags.defaultValue + let overrideFunc = OverrideFunc.noOverride + let emitType = emitTypeImpl emitTypeFlags + let emitType_ = emitType overrideFunc + let emitSelfType = emitTypeImpl emitTypeFlags overrideFunc + + /// convert interface members to appropriate statements + let intfToStmts (moduleIntf: Class<_>) ctx flags overrideFunc = + let flags = { flags with simplifyContravariantUnion = true } + let emitType_ = emitTypeImpl flags overrideFunc + let inline extFunc ft = extFunc flags overrideFunc ctx ft + let inline func ft = func flags overrideFunc ctx ft + let emitAsVariable name typ isConst (memberAttr: MemberAttribute) = + let v = + { name = name; typ = typ; + isConst = isConst; isExported = Exported.No; accessibility = Some memberAttr.accessibility; + comments = memberAttr.comments; loc = memberAttr.loc } + emitVariable flags overrideFunc ctx v + let emitAsFunction name typ typrms (memberAttr: MemberAttribute) = + let f = + { name = name; typ = typ; typeParams = typrms; + isExported = Exported.No; accessibility = Some memberAttr.accessibility; + comments = memberAttr.comments; loc = memberAttr.loc } + emitFunction flags overrideFunc ctx f + [ for ma, m in moduleIntf.members do + let comments = emitComments ma.comments + match m with + | Field (fl, mt) -> + yield! emitAsVariable fl.name fl.value (mt = ReadOnly) ma + | Getter fl -> + yield! emitAsVariable fl.name fl.value true ma + | Setter _ -> () + | Method (name, ft, tps) -> + yield! emitAsFunction name ft tps ma + | Newable (ft, _tps) -> + let ty, attrs = extFunc ft + yield! + binding (fun rename s -> + let target, attrs = + match s.scopeRev with + | self :: sr -> + let attrs = scopeToAttr { s with scopeRev = sr } attrs + self, attrs + | [] -> failwithf "impossible_intfToStmts_Newable(%s)" ma.loc.AsString + let attrs = Attr.External.new_ :: attrs |> List.rev + ext attrs comments (rename "make") ty target + ) + | Callable (ft, _tps) -> + let ty, attrs = extFunc ft + yield! + binding (fun rename s -> + let target, attrs = + match s.scopeRev with + | self :: sr -> + let attrs = scopeToAttr { s with scopeRev = sr } attrs + self, attrs + | [] -> failwithf "impossible_intfToStmts_Callable(%s)" ma.loc.AsString + let attrs = Attr.External.val_ :: attrs |> List.rev + ext attrs comments (rename "apply") ty target + ) + | Constructor _ -> failwith "impossible_emitStructuredDefinition_Pattern_intfToModule_Constructor" // because interface! + | Indexer (ft, _) -> + let ty = func ft + yield! binding (fun _ _ -> unknownBinding comments (Some ("unsupported indexer of type: " @+ ty))) + | UnknownMember (Some msg) -> + yield! binding (fun _ _ -> unknownBinding comments (Some (str msg))) + | SymbolIndexer _ | UnknownMember None -> () ] + + let rec folder ctx (current: StructuredText) (s: Statement) : StructuredText = + let comments = (s :> ICommented<_>).getComments() |> emitComments + + let knownTypes () = Statement.getKnownTypes ctx [s] + let addExport name kind kindString current = + match getExportFromStatement ctx name kind kindString s with + | None -> current + | Some e -> current |> set {| StructuredTextNode.empty with exports = [e] |} + let addAnonymousInterfaceWithKnownTypes knownTypes current = addAnonymousInterface emitTypeFlags ctx knownTypes current + let addAnonymousInterface current = addAnonymousInterfaceWithKnownTypes (knownTypes ()) current + let addAnonymousInterfaceExcludingWithKnownTypes knownTypes ais current = addAnonymousInterfaceExcluding emitTypeFlags ctx knownTypes ais current + let addAnonymousInterfaceExcluding ais current = addAnonymousInterfaceExcludingWithKnownTypes (knownTypes ()) ais current + + match s with + | Module m -> + let module' = + let node = {| StructuredTextNode.empty with comments = comments; knownTypes = knownTypes () |} + let module' = current |> getTrie [m.name] |> set node + let ctx = ctx |> Context.ofChildNamespace m.name + m.statements |> List.fold (folder ctx) module' + let current = + current |> setTrie [m.name] module' + match module'.value with + | None -> current + | Some _ -> + let kind = + if m.isNamespace then Kind.OfNamespace + else Kind.OfModule + current |> addExport m.name kind (if m.isNamespace then "namespace" else "module") + | Global m -> m.statements |> List.fold (folder ctx) current + | Class c -> + emitClass emitTypeFlags OverrideFunc.noOverride ctx current (c.MapName Choice1Of2) ((fun _ _ _ -> []), Set.empty, None) + | Enum e -> + current + |> inTrie [e.name] (fun module' -> + let ctx = ctx |> Context.ofChildNamespace e.name + let items = emitTypeAliases emitTypeFlags OverrideFunc.noOverride ctx [] (GetSelfTyText.enumCases e e.cases) + let module' = + let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes () |} + module' |> set node + e.cases |> List.fold (fun state c -> + let ctx = ctx |> Context.ofChildNamespace c.name + let comments = emitComments c.comments + let items = + emitTypeAliases emitTypeFlags OverrideFunc.noOverride ctx [] (GetSelfTyText.enumCases e [c]) + let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes () |} + state |> add [c.name] node + ) module') + |> addExport e.name Kind.OfEnum "enum" + | TypeAlias ta -> + let ctx = ctx |> Context.ofChildNamespace ta.name + let items = + emitTypeAliases emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target) + let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes () |} + current + |> inTrie [ta.name] (set node) + |> addExport ta.name Kind.OfTypeAlias "type" + |> inTrie [ta.name] ( + match ta.target with + | Union u -> + let functions = emitTypeAliasToUnionFunctions emitTypeFlags OverrideFunc.noOverride ctx u + set {| StructuredTextNode.empty with items = functions |} + | _ -> id) + |> inTrie [ta.name] addAnonymousInterface + | Pattern p -> + let fallback current = + p.underlyingStatements + |> List.fold (folder ctx) current + |> addAnonymousInterface + match p with + | ImmediateInstance (intf & { name = Name intfName }, value) when Simplify.Has(ctx.options.simplify, Simplify.ImmediateInstance) -> + let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] + let createModule () = + let items = intfToStmts intf (ctx |> Context.ofChildNamespace value.name) emitTypeFlags overrideFunc + {| StructuredTextNode.empty with items = items; knownTypes = knownTypesInMembers; scope = Some value.name |} + if knownTypesInMembers |> Set.contains (KnownType.Ident (ctx |> Context.getFullName [intfName])) then + fallback current + else + current + |> inTrie [value.name] (set (createModule ())) + |> addExport value.name Kind.OfClass "interface" + |> inTrie [value.name] addAnonymousInterface + | ImmediateConstructor (baseIntf, ctorIntf, ctorValue) when Simplify.Has(ctx.options.simplify, Simplify.ImmediateConstructor) -> + emitClass emitTypeFlags OverrideFunc.noOverride ctx current (baseIntf.MapName Choice1Of2) (intfToStmts ctorIntf, Statement.getKnownTypes ctx [Class ctorIntf], Some ctorValue.name) + | _ -> fallback current + | Function func -> + let node = + {| StructuredTextNode.empty with + items = emitFunction emitTypeFlags overrideFunc ctx func + knownTypes = knownTypes () |} + current + |> set node + |> addExport func.name Kind.OfValue "function" + |> addAnonymousInterface + | Variable value -> + let fallback current = + let node = + {| StructuredTextNode.empty with + items = emitVariable emitTypeFlags overrideFunc ctx value + knownTypes = knownTypes () |} + current + |> set node + |> addExport value.name Kind.OfValue (if value.isConst then "const" else "let") + |> addAnonymousInterface + let inline (|Dummy|) _ = [] + match value.typ with + | AnonymousInterface intf when Simplify.Has(ctx.options.simplify, Simplify.AnonymousInterfaceValue) -> + let knownTypes = knownTypes () + let items = intfToStmts intf (ctx |> Context.ofChildNamespace value.name) emitTypeFlags overrideFunc + current + |> inTrie [value.name] + (set + {| StructuredTextNode.empty with + items = items + knownTypes = + knownTypes |> Set.filter (function KnownType.AnonymousInterface (ai, _) -> ai.loc <> intf.loc | _ -> true) + scope = Some value.name |}) + |> addExport value.name Kind.OfClass (if value.isConst then "const" else "let") + |> inTrie [value.name] (addAnonymousInterfaceExcluding [intf]) + | Ident (i & { loc = loc }) & Dummy tyargs + | App (AIdent i, tyargs, loc) when Simplify.Has(ctx.options.simplify, Simplify.NamedInterfaceValue) -> + let intf = + Ident.pickDefinition ctx i (function Definition.Class c when c.isInterface -> Some c | _ -> None) + match intf with + | None -> fallback current + | Some intf -> + let bindings = createBindings i.name loc intf.typeParams tyargs + let intf = intf |> mapInClass (substTypeVar bindings) ctx + let name = value.name + "Static" + let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] + let createModule () = + let items = intfToStmts intf ctx emitTypeFlags overrideFunc + {| StructuredTextNode.empty with items = items; knownTypes = knownTypesInMembers; scope = Some value.name |} + current + |> inTrie [name] (set (createModule ())) + |> addExport name Kind.OfClass (if value.isConst then "const" else "let") + |> inTrie [name] (addAnonymousInterfaceWithKnownTypes knownTypesInMembers) + |> fallback + | _ -> fallback current + | Import i -> + current |> set {| StructuredTextNode.empty with items = emitImport ctx i |} + | Export e -> + let getKind = function + | CommonJsExport i | ES6DefaultExport i -> i |> Ident.getKind ctx + | ES6Export x -> x.target |> Ident.getKind ctx + | NamespaceExport _ -> Set.empty + current + |> set + {| StructuredTextNode.empty with + exports = [ExportItem.Export {| e with clauses = e.clauses |> List.map (fun c -> c, getKind c) |}] |} + | ReExport e -> + let getKind = function + | ES6ReExport x -> x.target |> Ident.getKind ctx + | ES6NamespaceReExport _ | ES6WildcardReExport -> Set.empty + current + |> set + {| StructuredTextNode.empty with + exports = [ExportItem.ReExport {| e with clauses = e.clauses |> List.map (fun c -> c, getKind c) |}] |} + | UnknownStatement u -> + let cmt = + match u.origText with + | Some s -> commentStr s | None -> commentStr "unknown statement" + current |> set {| StructuredTextNode.empty with items = [ScopeIndependentText cmt] |} + | FloatingComment c -> + let cmt = c.comments |> emitComments |> List.map ScopeIndependentText + current |> set {| StructuredTextNode.empty with items = ScopeIndependentText empty :: cmt |} + and folder' ctx stmt node = folder ctx node stmt + + stmts |> List.fold (folder rootCtx) Trie.empty From f2842ad27dd51a637c4cabc310acc6fc39db138f Mon Sep 17 00:00:00 2001 From: Sora Morimoto Date: Mon, 28 Feb 2022 18:21:19 +0900 Subject: [PATCH 13/56] Lock the package version of ReScript Signed-off-by: Sora Morimoto --- yarn.lock | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yarn.lock b/yarn.lock index d1ebfbc3..c39655d6 100644 --- a/yarn.lock +++ b/yarn.lock @@ -2732,7 +2732,7 @@ requires-port@^1.0.0: resolved "https://registry.yarnpkg.com/requires-port/-/requires-port-1.0.0.tgz#925d2601d39ac485e091cf0da5c6e694dc3dcaff" integrity sha1-kl0mAdOaxIXgkc8NpcbmlNw9yv8= -rescript@^9.1.4: +rescript@9.1.4: version "9.1.4" resolved "https://registry.yarnpkg.com/rescript/-/rescript-9.1.4.tgz#1eb126f98d6c16942c0bf0df67c050198e580515" integrity sha512-aXANK4IqecJzdnDpJUsU6pxMViCR5ogAxzuqS0mOr8TloMnzAjJFu63fjD6LCkWrKAhlMkFFzQvVQYaAaVkFXw== From 410b1f925a9522c26782a42aaf337282036feed9 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 1 Mar 2022 19:56:21 +0900 Subject: [PATCH 14/56] Emit enum definition --- src/Targets/ReScript/ReScriptHelper.fs | 47 +++- src/Targets/ReScript/Writer.fs | 300 ++++++++++++++++++------- 2 files changed, 262 insertions(+), 85 deletions(-) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 23e56c1b..3b8e4d5d 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -395,6 +395,30 @@ module Term = let raw js = js |> String.escapeWith ["`"] |> str |> between "%raw(`" "`)" +type TextModule = {| name: string; origName: string; content: text list; comments: text list |} + +let private moduleSigImplLines (prefix: string) (isRec: bool) (m: TextModule) = + [ yield! m.comments + let isEmpty = List.isEmpty m.content + let head = + tprintf "%s %s%s : {" + prefix + (if isRec then "rec " else "") + m.name + if isEmpty then + yield head +@ " }" + else + // make it one liner if possible + if m.content |> List.forall (isMultiLine >> not) && (m.content |> List.sumBy Text.length) < 80 then + yield head +@ " " + (concat (str "; ") m.content) +@ " }" + else + yield head + yield indent (concat newline m.content) + yield str "}" ] + +let private moduleSigImpl (prefix: string) (isRec: bool) (m: TextModule) = + moduleSigImplLines prefix isRec m |> concat newline + [] module Statement = let attr attrs = @@ -418,4 +442,25 @@ module Statement = let include_ name = tprintf "include %s" name let open_ name = tprintf "open %s" name - let moduleAlias name target = tprintf "module %s = %s" name target \ No newline at end of file + let moduleAlias name target = tprintf "module %s = %s" name target + + let moduleSig (m: TextModule) = moduleSigImpl "module" false m + + let moduleSigRec (ms: TextModule list) = + match ms with + | [] -> [] + | [m] -> [moduleSig m] + | m :: ms -> + moduleSigImpl "module" true m :: (ms |> List.map (moduleSigImpl "and" false)) + + let moduleSigNonRec (ms: TextModule list) = ms |> List.map moduleSig + + let moduleVal (m: TextModule) : text = + concat newline [ + yield! m.comments + yield tprintf "module %s = {" m.name + yield indent (concat newline m.content) + yield str "}" + ] + + let moduleValMany ms = ms |> List.map moduleVal diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index b4936f9e..3f7f04e0 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -120,17 +120,6 @@ let fixme alternative fmt = commentStr (sprintf "FIXME: %s" msg) + alternative ) fmt -let enumCaseToIdentifier (e: Enum) (c: EnumCase) = - let duplicateCases = - e.cases |> List.filter (fun c' -> c.value = c'.value) - match duplicateCases with - | [] -> failwith "impossible_enumCaseToIdentifier" - | [c'] -> - assert (c = c') - Naming.constructorName [c.name] - | cs -> - cs |> List.map (fun c -> c.name) |> Naming.constructorName - let anonymousInterfaceModuleName (ctx: Context) (info: AnonymousInterfaceInfo) = match info.origin.valueName, info.origin.argName with | _, Some s | Some s, None when ctx.options.readableNames -> @@ -437,7 +426,7 @@ let builder name (fields: {| isOptional: bool; name: string; value: text |} list Binding.Ext {| name = name; ty = ty; target = ""; attrs = [Attr.External.obj]; comments = []|} type EmitCondition = { - /// Emit in the `Types` module in `.res` + /// Emit in the `Types` module onTypes: bool /// Emit in `.res` onImpl: bool @@ -447,10 +436,16 @@ type EmitCondition = { static member empty = { onTypes = false; onImpl = false; onIntf = false } type StructuredTextItem = - | ImportText of text // import texts should be at the top of the module - | TypeDefText of text // and type definitions should come next + /// Will always be emitted at the top of the module. + | ImportText of text + /// Will always be emitted at the next top of the module. + /// + /// In `.res`, the presence of this item makes `open ModuleName` also emitted. + | TypeDefText of text | Conditional of StructuredTextItem * EmitCondition - | ScopeIndependentText of text // floating comments, etc + /// Will be emitted in `.res` and `.resi`, but not in the `Types` module + | Comment of text + /// Will only be emitted in `.res` (not in `.resi` or in the `Types` module) | Binding of (OverloadRenamer -> Scope -> Binding) and [] ExportItem = @@ -464,7 +459,9 @@ and StructuredTextNode = {| items: StructuredTextItem list comments: text list exports: ExportItem list - knownTypes: Set + openTypesModule: bool + /// Used to emit module signatures recursively. + typeReferences: Set anonymousInterfaces: Set |} @@ -474,7 +471,7 @@ let inline conditional cond x = Conditional (x, cond) module StructuredTextNode = let empty : StructuredTextNode = - {| scope = None; items = []; comments = []; exports = []; knownTypes = Set.empty; anonymousInterfaces = Set.empty |} + {| scope = None; items = []; comments = []; exports = []; typeReferences = Set.empty; anonymousInterfaces = Set.empty; openTypesModule = true |} let union (a: StructuredTextNode) (b: StructuredTextNode) : StructuredTextNode = let mergeScope s1 s2 = match s1, s2 with @@ -485,7 +482,8 @@ module StructuredTextNode = items = List.append a.items b.items comments = List.append a.comments b.comments exports = List.append a.exports b.exports - knownTypes = Set.union a.knownTypes b.knownTypes + openTypesModule = a.openTypesModule || b.openTypesModule + typeReferences = Set.union a.typeReferences b.typeReferences anonymousInterfaces = Set.union a.anonymousInterfaces b.anonymousInterfaces |} module StructuredText = @@ -506,7 +504,7 @@ module StructuredText = let trie = x.value |> Option.map (fun v -> - v.knownTypes + v.typeReferences |> Set.fold (fun state -> function | KnownType.Ident fn when fn.source = ctx.currentSourceFile -> state |> WeakTrie.add fn.name | KnownType.AnonymousInterface (_, i) -> @@ -780,34 +778,6 @@ let emitTypeAlias flags overrideFunc ctx (typrms: TypeParam list) target = else [] ) -module GetSelfTyText = - /// `ctx.currentNamespace` should be the class - let class_ flags overrideFunc (ctx: Context) (c: Class) (baseType: text option) = - let emitType = emitTypeImpl flags - let emitType_ = emitType overrideFunc - let fallback = str "private any" - match c.name with - | Name name -> - assert (name = List.last ctx.currentNamespace) - if ctx.options.subtyping |> List.contains Subtyping.Tag then - let labels = - getLabelsOfFullName flags overrideFunc ctx (ctx |> Context.getFullName []) c.typeParams - if List.isEmpty labels then fallback - else - Type.intf (emitLabels ctx labels) baseType - else fallback - | ExportDefaultUnnamedClass -> - let labels = - c.implements - |> List.map (getAllInheritancesAndSelf ctx) |> Set.unionMany - |> getLabelsFromInheritingTypes flags overrideFunc ctx - if List.isEmpty labels then fallback - else - Type.intf (emitLabels ctx labels) baseType - - let enumCases (e: Enum) (cases: EnumCase list) = - failwith "TODO" - let getTrie name current = current |> Trie.getSubTrie name |> Option.defaultValue Trie.empty let setTrie name trie current = @@ -882,6 +852,9 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let dummy = c.MapName(fun _ -> ExportDefaultUnnamedClass) Statement.getKnownTypes ctx [Class dummy] |> Set.union additionalKnownTypes + let typeReferences = + c.implements |> List.map (getKnownTypes ctx) |> Set.unionMany + let isAnonymous, isExportDefaultClass = match kind with | ClassKind.AnonymousInterface _ -> true, false @@ -989,16 +962,34 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c else fallback () let typeDefinition = + let fallback = str "private any" + let getSelfTyText (c: Class) = + match c.name with + | Name name -> + assert (name = List.last innerCtx.currentNamespace) + if innerCtx.options.subtyping |> List.contains Subtyping.Tag then + let labels = + getLabelsOfFullName flags overrideFunc innerCtx (innerCtx |> Context.getFullName []) c.typeParams + if List.isEmpty labels then fallback + else + Type.intf (emitLabels innerCtx labels) baseType + else fallback + | ExportDefaultUnnamedClass -> + let labels = + c.implements + |> List.map (getAllInheritancesAndSelf innerCtx) |> Set.unionMany + |> getLabelsFromInheritingTypes flags overrideFunc innerCtx + if List.isEmpty labels then fallback + else + Type.intf (emitLabels innerCtx labels) baseType let selfTyText = match kind with - | ClassKind.NormalClass x -> GetSelfTyText.class_ flags overrideFunc innerCtx x.orig baseType - | ClassKind.ExportDefaultClass x -> GetSelfTyText.class_ flags overrideFunc innerCtx x.orig None - | ClassKind.AnonymousInterface _ -> str "private any" - + | ClassKind.NormalClass x -> getSelfTyText x.orig + | ClassKind.ExportDefaultClass x -> getSelfTyText x.orig + | ClassKind.AnonymousInterface _ -> fallback let onTypes = emitTypeAlias flags overrideFunc innerCtx c.typeParams selfTyText |> List.map (conditional { EmitCondition.empty with onTypes = true }) - let onIntf = emitTypeAliases flags overrideFunc innerCtx c.typeParams selfTyText |> List.map (conditional { EmitCondition.empty with onIntf = true }) @@ -1067,7 +1058,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c yield! castFunctions ] - {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes; scope = scope |} + {| StructuredTextNode.empty with items = items; comments = comments; scope = scope; typeReferences = typeReferences |} let export = match kind with @@ -1112,6 +1103,149 @@ and addAnonymousInterfaceExcluding emitTypeFlags (ctx: Context) knownTypes ais ( ) current and addAnonymousInterface emitTypeFlags ctx knownTypes (current: StructuredText) = addAnonymousInterfaceExcluding emitTypeFlags ctx knownTypes [] current +type EnumType = + /// Integer enum of which first case is `0` and (n+1)th case is `n`. + | CleanInt = 0 + /// Integer enum but not 'clean' in the above sense. + | Int = 1 + /// Float enum. + | Float = 2 + /// Boolean enum. + | Boolean = 3 + /// String enum. + | String = 4 + /// Enum with integer and float cases. + | Number = 5 + /// Enum with integer and string cases. + | PolyVariant = 6 + /// Other heterogeneous enum. + | Heterogeneous = 7 + +let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enum) = + let enumCaseToIdentifier (e: Enum) (c: EnumCase) = + let duplicateCases = + e.cases |> List.filter (fun c' -> c.value = c'.value) + match duplicateCases with + | [] -> failwith "impossible_enumCaseToIdentifier" + | [c'] -> + assert (c = c') + Naming.constructorName [c.name] + | cs -> + cs |> List.map (fun c -> c.name) |> Naming.constructorName + + let distinctCases = + e.cases + |> List.map (fun c -> enumCaseToIdentifier e c, c.value) + |> List.distinctBy snd + let enumValues = distinctCases |> List.map snd + let enumType = + let types = + enumValues + |> List.map (function + | None -> EnumType.Heterogeneous + | Some (LString _) -> EnumType.String + | Some (LInt _) -> EnumType.Int + | Some (LFloat _) -> EnumType.Float + | Some (LBool _) -> EnumType.Boolean) + |> List.sort + match types with + | [EnumType.Int] -> + let values = + enumValues + |> List.map (function Some (LInt i) -> i | _ -> failwith "impossible") + |> Set.ofList + let min = Set.minElement values + let max = Set.maxElement values + let clean = Set.ofList [min..max] + if min = 0 && values = clean then EnumType.CleanInt + else EnumType.Int + | [x] -> x + | [EnumType.Int; EnumType.Float] -> EnumType.Number + | [EnumType.Int; EnumType.String] -> EnumType.PolyVariant + | _ -> EnumType.Heterogeneous + + let aritySafety = + if ctx.options.safeArity.HasProvide then + Statement.typeAlias "t_0" [] (str "t") + |> TypeDefText + |> conditional { onIntf = true; onImpl = true; onTypes = false } + |> List.singleton + else [] + let appendAritySafety x = x :: aritySafety + + let parentNode = + let items = + match enumType with + | EnumType.CleanInt -> + let cases = + distinctCases + |> List.map (fun (n, v) -> n, match v with Some (LInt i) -> i | _ -> failwith "impossible") + |> List.sortBy snd + |> List.map fst + if (cases |> List.sumBy (fun s -> s.Length)) > 80 then + concat newline [ + yield str "type t =" + for case in cases do + yield indent (tprintf "| %s" case) + ] |> TypeDefText |> appendAritySafety + else + cases |> String.concat " | " |> tprintf "type t = %s" |> TypeDefText |> appendAritySafety + | EnumType.Int | EnumType.String | EnumType.PolyVariant -> + let cases = + distinctCases + |> List.map snd + |> List.map (function + | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} + | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} + | _ -> failwith "impossible") + Statement.typeAlias "t" [] (Type.polyVariant cases) |> TypeDefText |> appendAritySafety + | EnumType.Boolean -> Statement.typeAlias "t" [] (str "private bool") |> TypeDefText |> appendAritySafety + | EnumType.Float | EnumType.Number -> + ctx.logger.warnf "an enum type '%s' contains a case with float value, which is not supported in ReScript at %s" e.name e.loc.AsString + [ + yield commentStr (sprintf "FIXME: float enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } + yield Statement.typeAlias "t" [] (str "private float") |> TypeDefText + yield! aritySafety + ] + | _ -> + ctx.logger.warnf "a heterogeneous enum '%s' is not supported at %s" e.name e.loc.AsString + [ + yield commentStr (sprintf "FIXME: heterogeneous enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } + yield Statement.typeAlias "t" [] (str "private any") |> TypeDefText + yield! aritySafety + ] + let comments = e.comments |> emitComments + let exports = getExportFromStatement ctx e.name Kind.OfEnum "enum" (Enum e) + {| StructuredTextNode.empty with items = items; comments = comments; exports = Option.toList exports; openTypesModule = false |} + + let childNode (c: EnumCase) = + let typeDef = + match enumType with + | EnumType.Int | EnumType.String | EnumType.PolyVariant -> + let case = + match c.value with + | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} + | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} + | _ -> failwith "impossible" + Statement.typeAlias "t" [] (Type.polyVariant [case]) |> TypeDefText + | _ -> Statement.typeAlias "t" [] (str "private t") |> TypeDefText + let items = [ + yield Statement.typeAlias "parent" [] (str "t") |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } + yield typeDef + yield! aritySafety + yield! // emit a binding to the enum case value + binding (fun rename s -> + ext (scopeToAttr s [Attr.External.val_]) [] (rename "value") (str "parent") c.name + ) + ] + let comments = c.comments |> emitComments + {| StructuredTextNode.empty with items = items; comments = comments; openTypesModule = false |} + + current + |> add [e.name] parentNode + |> inTrie [e.name] (fun m -> + e.cases |> List.fold (fun state c -> state |> add [c.name] (childNode c)) m) + let emitVariable flags overrideFunc ctx (v: Variable) = let emitType = emitTypeImpl flags let emitType_ = emitType overrideFunc @@ -1199,7 +1333,8 @@ let emitImport (ctx: Context) (i: Import) : StructuredTextItem list = yield! emitImportClause c] let emitTypeAliasToUnionFunctions flags overrideFunc ctx (u: UnionType) : StructuredTextItem list = - failwith "TODO" + // TODO + [] let createStructuredText (rootCtx: Context) (stmts: Statement list) : StructuredText = let emitTypeFlags = EmitTypeFlags.defaultValue @@ -1286,7 +1421,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured match s with | Module m -> let module' = - let node = {| StructuredTextNode.empty with comments = comments; knownTypes = knownTypes () |} + let node = {| StructuredTextNode.empty with comments = comments |} let module' = current |> getTrie [m.name] |> set node let ctx = ctx |> Context.ofChildNamespace m.name m.statements |> List.fold (folder ctx) module' @@ -1303,27 +1438,13 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Class c -> emitClass emitTypeFlags OverrideFunc.noOverride ctx current (c.MapName Choice1Of2) ((fun _ _ _ -> []), Set.empty, None) | Enum e -> - current - |> inTrie [e.name] (fun module' -> - let ctx = ctx |> Context.ofChildNamespace e.name - let items = emitTypeAliases emitTypeFlags OverrideFunc.noOverride ctx [] (GetSelfTyText.enumCases e e.cases) - let module' = - let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes () |} - module' |> set node - e.cases |> List.fold (fun state c -> - let ctx = ctx |> Context.ofChildNamespace c.name - let comments = emitComments c.comments - let items = - emitTypeAliases emitTypeFlags OverrideFunc.noOverride ctx [] (GetSelfTyText.enumCases e [c]) - let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes () |} - state |> add [c.name] node - ) module') - |> addExport e.name Kind.OfEnum "enum" + emitEnum emitTypeFlags OverrideFunc.noOverride ctx current e | TypeAlias ta -> let ctx = ctx |> Context.ofChildNamespace ta.name let items = emitTypeAliases emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target) - let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes () |} + let typeReferences = getKnownTypes ctx ta.target + let node = {| StructuredTextNode.empty with items = items; typeReferences = typeReferences; comments = comments |} current |> inTrie [ta.name] (set node) |> addExport ta.name Kind.OfTypeAlias "type" @@ -1344,7 +1465,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] let createModule () = let items = intfToStmts intf (ctx |> Context.ofChildNamespace value.name) emitTypeFlags overrideFunc - {| StructuredTextNode.empty with items = items; knownTypes = knownTypesInMembers; scope = Some value.name |} + {| StructuredTextNode.empty with items = items; scope = Some value.name |} if knownTypesInMembers |> Set.contains (KnownType.Ident (ctx |> Context.getFullName [intfName])) then fallback current else @@ -1358,8 +1479,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Function func -> let node = {| StructuredTextNode.empty with - items = emitFunction emitTypeFlags overrideFunc ctx func - knownTypes = knownTypes () |} + items = emitFunction emitTypeFlags overrideFunc ctx func |} current |> set node |> addExport func.name Kind.OfValue "function" @@ -1368,8 +1488,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let fallback current = let node = {| StructuredTextNode.empty with - items = emitVariable emitTypeFlags overrideFunc ctx value - knownTypes = knownTypes () |} + items = emitVariable emitTypeFlags overrideFunc ctx value |} current |> set node |> addExport value.name Kind.OfValue (if value.isConst then "const" else "let") @@ -1377,15 +1496,12 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let inline (|Dummy|) _ = [] match value.typ with | AnonymousInterface intf when Simplify.Has(ctx.options.simplify, Simplify.AnonymousInterfaceValue) -> - let knownTypes = knownTypes () let items = intfToStmts intf (ctx |> Context.ofChildNamespace value.name) emitTypeFlags overrideFunc current |> inTrie [value.name] (set {| StructuredTextNode.empty with items = items - knownTypes = - knownTypes |> Set.filter (function KnownType.AnonymousInterface (ai, _) -> ai.loc <> intf.loc | _ -> true) scope = Some value.name |}) |> addExport value.name Kind.OfClass (if value.isConst then "const" else "let") |> inTrie [value.name] (addAnonymousInterfaceExcluding [intf]) @@ -1402,7 +1518,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] let createModule () = let items = intfToStmts intf ctx emitTypeFlags overrideFunc - {| StructuredTextNode.empty with items = items; knownTypes = knownTypesInMembers; scope = Some value.name |} + {| StructuredTextNode.empty with items = items; scope = Some value.name |} current |> inTrie [name] (set (createModule ())) |> addExport name Kind.OfClass (if value.isConst then "const" else "let") @@ -1432,10 +1548,26 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let cmt = match u.origText with | Some s -> commentStr s | None -> commentStr "unknown statement" - current |> set {| StructuredTextNode.empty with items = [ScopeIndependentText cmt] |} + current |> set {| StructuredTextNode.empty with items = [Comment cmt] |} | FloatingComment c -> - let cmt = c.comments |> emitComments |> List.map ScopeIndependentText - current |> set {| StructuredTextNode.empty with items = ScopeIndependentText empty :: cmt |} + let cmt = c.comments |> emitComments |> List.map Comment + current |> set {| StructuredTextNode.empty with items = Comment empty :: cmt |} and folder' ctx stmt node = folder ctx node stmt stmts |> List.fold (folder rootCtx) Trie.empty + +type ModuleEmitter = Context -> StructuredText -> (TextModule list -> text list) +module ModuleEmitter = + let signature (ctx: Context) (st: StructuredText) = + if Map.count st.children < 3 then + Statement.moduleSigRec + else + let scc = StructuredText.calculateSCCOfChildren ctx st + fun (modules: TextModule list) -> + let modules = modules |> List.fold (fun state x -> state |> Map.add x.origName x) Map.empty + scc + |> List.map (fun group -> + group |> List.map (fun name -> modules |> Map.find name) |> Statement.moduleSigRec) + |> List.concat + + let structure (_: Context) (_: StructuredText) = Statement.moduleValMany \ No newline at end of file From eca335099f0ac5cc666e16139270423c66eda9db Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 2 Mar 2022 19:15:13 +0900 Subject: [PATCH 15/56] Emit StructuredText --- src/Targets/ReScript/Writer.fs | 265 +++++++++++++++++++++++++++------ 1 file changed, 223 insertions(+), 42 deletions(-) diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 3f7f04e0..cdf44b67 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -7,6 +7,9 @@ open Typer.Type open DataTypes open DataTypes.Text +open Fable.Core +open Fable.Core.JsInterop + open Targets.ReScript.Common open Targets.ReScript.ReScriptHelper @@ -216,7 +219,6 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C | PolymorphicThis -> fixme Type.any "polymorphic 'this' appeared out of context" | Intrinsic -> Type.intrinsic | Tuple ts -> - // TODO: emit label match ts.types with | [] -> Type.void_ | [t] -> emitTypeImpl flags overrideFunc ctx t.value @@ -384,16 +386,13 @@ and getLabelOfFullName flags overrideFunc (ctx: Context) (fullName: FullName) (t let inheritingType = InheritingType.KnownIdent {| fullName = fullName; tyargs = typeParams |> List.map (fun tp -> TypeVar tp.name) |} getLabelsFromInheritingTypes flags overrideFunc ctx (Set.singleton inheritingType) |> Choice1Of2 -type Scope = { - moduleName: string option - /// reversed list of scope - scopeRev: string list -} - type [] Binding = | Let of {| name: string; ty: text; body: text; attrs: text list; comments: text list |} | Ext of {| name: string; ty: text; target: string; attrs: text list; comments: text list |} | Unknown of {| msg:text option; comments: text list |} +with + member this.comments = + match this with Let x -> x.comments | Ext x -> x.comments | Unknown x -> x.comments let let_ (attrs: text list) comments name ty body = Binding.Let {| name = name; ty = ty; body = body; attrs = attrs; comments = comments |} @@ -407,6 +406,22 @@ let unknownBinding comments msg = let cast comments name ty = Binding.Ext {| name = name; ty = ty; target = "%identity"; attrs = []; comments = comments |} +module Binding = + let emitForImplementation (b: Binding) = [ + match b with + | Binding.Let x -> yield Statement.let_ x.attrs x.name x.ty x.body + | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target + | Binding.Unknown x -> match x.msg with Some msg -> yield msg | None -> () + ] + + let emitForInterface (b: Binding) = [ + yield! b.comments + match b with + | Binding.Let x -> yield Statement.val_ x.attrs x.name x.ty + | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target + | Binding.Unknown x -> match x.msg with Some msg -> yield msg | None -> () + ] + let builder name (fields: {| isOptional: bool; name: string; value: text |} list) (thisType: text) = let args = fields @@ -434,6 +449,7 @@ type EmitCondition = { onIntf: bool } with static member empty = { onTypes = false; onImpl = false; onIntf = false } + static member all = { onTypes = true; onImpl = true; onIntf = true } type StructuredTextItem = /// Will always be emitted at the top of the module. @@ -446,7 +462,20 @@ type StructuredTextItem = /// Will be emitted in `.res` and `.resi`, but not in the `Types` module | Comment of text /// Will only be emitted in `.res` (not in `.resi` or in the `Types` module) - | Binding of (OverloadRenamer -> Scope -> Binding) + | Binding of (OverloadRenamer -> CurrentScope -> Binding) + +and CurrentScope = { + jsModule: string option + /// reversed list of scope + scopeRev: string list +} + +and [] Scope = + | Default + | Module of string + | Path of string + | Global + | Ignore and [] ExportItem = | Export of {| comments: Comment list; clauses: (ExportClause * Set) list; loc: Location; origText: string |} @@ -455,7 +484,7 @@ and [] ExportItem = and StructuredTextNode = {| /// By default, key is used as a scope. `Some scope` to override it. - scope: string option + scope: Scope items: StructuredTextItem list comments: text list exports: ExportItem list @@ -471,13 +500,12 @@ let inline conditional cond x = Conditional (x, cond) module StructuredTextNode = let empty : StructuredTextNode = - {| scope = None; items = []; comments = []; exports = []; typeReferences = Set.empty; anonymousInterfaces = Set.empty; openTypesModule = true |} + {| scope = Scope.Default; items = []; comments = []; exports = []; typeReferences = Set.empty; anonymousInterfaces = Set.empty; openTypesModule = true |} let union (a: StructuredTextNode) (b: StructuredTextNode) : StructuredTextNode = let mergeScope s1 s2 = match s1, s2 with - | Some s1, Some s2 -> failwithf "impossible_union_mergeScope(%s, %s)" s1 s2 - | Some s, None | None, Some s -> Some s - | None, None -> None + | Scope.Default, s | s, Scope.Default -> s + | _, _ -> failwithf "impossible_mergeScope(%A, %A)" s1 s2 {| scope = mergeScope a.scope b.scope items = List.append a.items b.items comments = List.append a.comments b.comments @@ -550,11 +578,11 @@ let emitComments (comments: Comment list) : text list = // TODO [] -let inline binding (f: (string -> string) -> Scope -> Binding) = +let inline binding (f: (string -> string) -> CurrentScope -> Binding) = [Binding (fun renamer scope -> f (renamer.Rename "value") scope)] -let scopeToAttr (s: Scope) attr = - match s.scopeRev, s.moduleName with +let scopeToAttr (s: CurrentScope) attr = + match s.scopeRev, s.jsModule with | [], None -> attr | sr, None -> Attr.External.scope (List.rev sr) :: attr | sr, Some m -> @@ -621,7 +649,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: binding (fun rename s -> let target, attrs = if isExportDefaultClass then - match s.moduleName with + match s.jsModule with | Some m -> m, Attr.External.module_ None :: attrs | None -> failwithf "impossible_emitMembers_Constructor_ExportDefaultClass(%s)" ma.loc.AsString else @@ -809,7 +837,7 @@ type [] ClassKind<'a, 'b, 'c> = | ExportDefaultClass of 'b | AnonymousInterface of 'c -let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c: ClassOrAnonymousInterface) (additionalMembers: Context -> EmitTypeFlags -> OverrideFunc -> list, additionalKnownTypes: Set, forceScope: string option) = +let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c: ClassOrAnonymousInterface) (additionalMembers: Context -> EmitTypeFlags -> OverrideFunc -> list, additionalKnownTypes: Set, forceScope: Scope option) = let emitType orf ctx ty = emitTypeImpl flags orf ctx ty let typrms = List.map (fun (tp: TypeParam) -> TypeVar tp.name) c.typeParams @@ -915,8 +943,8 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let scope = match kind with - | ClassKind.ExportDefaultClass _ -> None - | _ -> forceScope + | ClassKind.NormalClass _ -> forceScope |> Option.defaultValue Scope.Default + | _ -> Scope.Ignore let comments = c.comments |> emitComments @@ -1064,7 +1092,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c match kind with | ClassKind.NormalClass x -> let kind = - if not c.isInterface || node.scope.IsSome then Kind.OfClass + if not c.isInterface || node.scope <> Scope.Ignore then Kind.OfClass else Kind.OfInterface getExportFromStatement ctx x.name kind (if c.isInterface then "interface" else "class") (Class x.orig) | _ -> None @@ -1080,11 +1108,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | ClassKind.AnonymousInterface x -> addAsNode x.name | ClassKind.ExportDefaultClass _ -> current - |> set {| - StructuredTextNode.empty with - scope = None - exports = [ExportItem.DefaultUnnamedClass node] - |} + |> set {| StructuredTextNode.empty with exports = [ExportItem.DefaultUnnamedClass node] |} |> addAnonymousInterface flags ctx knownTypes and addAnonymousInterfaceExcluding emitTypeFlags (ctx: Context) knownTypes ais (current: StructuredText) = @@ -1246,6 +1270,22 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu |> inTrie [e.name] (fun m -> e.cases |> List.fold (fun state c -> state |> add [c.name] (childNode c)) m) +let private createExternalForValue (ctx: Context) (rename: string -> string) (s: CurrentScope) attr comments name ty = + let fallback () = + ext (scopeToAttr s attr) comments (Naming.valueName name |> rename) ty name + let jsModule () = + match s.jsModule with + | None -> failwith "impossible_createExternalForValue" + | Some jsModule -> jsModule + match ctx |> Context.getExportTypeOfName [name] with + | None | Some (ExportType.Child _) | Some (ExportType.ES6 None) -> fallback () + | Some ExportType.CommonJS -> + ext (Attr.External.module_ None :: attr) comments (Naming.valueName name |> rename) ty (jsModule ()) + | Some ExportType.ES6Default -> + ext (scopeToAttr s attr) comments (Naming.valueName name |> rename) ty "default" + | Some (ExportType.ES6 (Some renameAs)) -> + ext (scopeToAttr s attr) comments (Naming.valueName name |> rename) ty renameAs + let emitVariable flags overrideFunc ctx (v: Variable) = let emitType = emitTypeImpl flags let emitType_ = emitType overrideFunc @@ -1257,9 +1297,7 @@ let emitVariable flags overrideFunc ctx (v: Variable) = ty, Attr.External.val_ :: attr | _ -> emitType_ ctx v.typ, [Attr.External.val_] let comments = emitComments v.comments - binding (fun rename s -> - ext (scopeToAttr s attr) comments (Naming.valueName v.name |> rename) ty v.name - ) + binding (fun rename s -> createExternalForValue ctx rename s attr comments v.name ty) let emitFunction flags overrideFunc ctx (f: Function) = let emitType = emitTypeImpl flags @@ -1267,9 +1305,7 @@ let emitFunction flags overrideFunc ctx (f: Function) = let inline extFunc ft = extFunc flags overrideFunc ctx ft let ty, attr = extFunc f.typ let comments = emitComments f.comments - binding (fun rename s -> - ext (scopeToAttr s (Attr.External.val_ :: attr)) comments (Naming.valueName f.name |> rename) ty f.name - ) + binding (fun rename s -> createExternalForValue ctx rename s (Attr.External.val_ :: attr) comments f.name ty) let emitImport (ctx: Context) (i: Import) : StructuredTextItem list = let emitImportClause (c: ImportClause) = @@ -1421,12 +1457,14 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured match s with | Module m -> let module' = - let node = {| StructuredTextNode.empty with comments = comments |} + let scope = + if m.isNamespace then Scope.Default + else Scope.Module m.name + let node = {| StructuredTextNode.empty with comments = comments; scope = scope |} let module' = current |> getTrie [m.name] |> set node let ctx = ctx |> Context.ofChildNamespace m.name m.statements |> List.fold (folder ctx) module' - let current = - current |> setTrie [m.name] module' + let current = current |> setTrie [m.name] module' match module'.value with | None -> current | Some _ -> @@ -1434,7 +1472,11 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured if m.isNamespace then Kind.OfNamespace else Kind.OfModule current |> addExport m.name kind (if m.isNamespace then "namespace" else "module") - | Global m -> m.statements |> List.fold (folder ctx) current + | Global m -> + current |> inTrie ["global"] (fun g -> + let node = {| StructuredTextNode.empty with scope = Scope.Global |} + m.statements |> List.fold (folder ctx) (set node g) + ) | Class c -> emitClass emitTypeFlags OverrideFunc.noOverride ctx current (c.MapName Choice1Of2) ((fun _ _ _ -> []), Set.empty, None) | Enum e -> @@ -1465,7 +1507,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] let createModule () = let items = intfToStmts intf (ctx |> Context.ofChildNamespace value.name) emitTypeFlags overrideFunc - {| StructuredTextNode.empty with items = items; scope = Some value.name |} + {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name |} if knownTypesInMembers |> Set.contains (KnownType.Ident (ctx |> Context.getFullName [intfName])) then fallback current else @@ -1474,7 +1516,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured |> addExport value.name Kind.OfClass "interface" |> inTrie [value.name] addAnonymousInterface | ImmediateConstructor (baseIntf, ctorIntf, ctorValue) when Simplify.Has(ctx.options.simplify, Simplify.ImmediateConstructor) -> - emitClass emitTypeFlags OverrideFunc.noOverride ctx current (baseIntf.MapName Choice1Of2) (intfToStmts ctorIntf, Statement.getKnownTypes ctx [Class ctorIntf], Some ctorValue.name) + emitClass emitTypeFlags OverrideFunc.noOverride ctx current (baseIntf.MapName Choice1Of2) (intfToStmts ctorIntf, Statement.getKnownTypes ctx [Class ctorIntf], Some (Scope.Path ctorValue.name)) | _ -> fallback current | Function func -> let node = @@ -1502,7 +1544,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured (set {| StructuredTextNode.empty with items = items - scope = Some value.name |}) + scope = Scope.Path value.name |}) |> addExport value.name Kind.OfClass (if value.isConst then "const" else "let") |> inTrie [value.name] (addAnonymousInterfaceExcluding [intf]) | Ident (i & { loc = loc }) & Dummy tyargs @@ -1518,7 +1560,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] let createModule () = let items = intfToStmts intf ctx emitTypeFlags overrideFunc - {| StructuredTextNode.empty with items = items; scope = Some value.name |} + {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name |} current |> inTrie [name] (set (createModule ())) |> addExport name Kind.OfClass (if value.isConst then "const" else "let") @@ -1556,7 +1598,6 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured stmts |> List.fold (folder rootCtx) Trie.empty -type ModuleEmitter = Context -> StructuredText -> (TextModule list -> text list) module ModuleEmitter = let signature (ctx: Context) (st: StructuredText) = if Map.count st.children < 3 then @@ -1570,4 +1611,144 @@ module ModuleEmitter = group |> List.map (fun name -> modules |> Map.find name) |> Statement.moduleSigRec) |> List.concat - let structure (_: Context) (_: StructuredText) = Statement.moduleValMany \ No newline at end of file + let structure (_: Context) (_: StructuredText) = Statement.moduleValMany + +type EmitModuleFlags = {| + /// The module being emitted is a reserved one (e.g. `Export`) + isReservedModule: bool + jsModule: string option + scopeRev: string list +|} + +type EmitModuleResult = {| + imports: text list + /// The `Types` module + types: text list + /// The content of the `.res` file + impl: text list + /// The content of the `.resi` file + intf: text list + comments: text list +|} + +let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) : EmitModuleResult = + let renamer = new OverloadRenamer() + let children = + st.children + |> Map.toList + |> List.map (fun (k, v) -> + let name = + let name = + if flags.isReservedModule then Naming.moduleNameReserved k + else Naming.moduleName k + name |> renamer.Rename "module" + let scopeRev, jsModule = + let overrideScope name = + match ctx |> Context.getExportTypeOfName [name] with + | None + | Some (ExportType.Child _) -> name :: flags.scopeRev + | Some ExportType.CommonJS + | Some (ExportType.ES6 None) -> [name] + | Some ExportType.ES6Default -> ["default"] + | Some (ExportType.ES6 (Some name)) -> [name] + match v.value with + | None -> k :: flags.scopeRev, flags.jsModule + | Some v -> + match v.scope with + | Scope.Default -> overrideScope k, flags.jsModule + | Scope.Path p -> overrideScope p, flags.jsModule + | Scope.Module m -> [], Some m + | Scope.Global -> [], None + | Scope.Ignore -> flags.scopeRev, flags.jsModule + let flags = {| flags with scopeRev = scopeRev; jsModule = jsModule |} + let ctx = ctx |> Context.ofChildNamespace k + let result = emitModule flags ctx v + let openTypesModule = + v.value + |> Option.map (fun v -> v.openTypesModule) + |> Option.defaultValue (result.types |> List.isEmpty |> not) + {| name = name; origName = k |}, openTypesModule, result) + + let items = + let currentScope : CurrentScope = !!flags + let rec f = function + | Conditional (i, c) -> c, snd (f i) + | ImportText t -> { EmitCondition.all with onTypes = false }, Choice1Of4 t + | TypeDefText t -> EmitCondition.all, Choice2Of4 t + | Binding b -> { EmitCondition.all with onTypes = false }, Choice3Of4 (b renamer currentScope) + | Comment c -> { EmitCondition.all with onTypes = false }, Choice4Of4 c + match st.value with None -> [] | Some v -> v.items |> List.map f + + let imports = + items |> List.choose (function (_, Choice1Of4 t) -> Some t | _ -> None) + + let types = + let items = + items |> List.choose (function (c, Choice2Of4 t) when c.onTypes -> Some t | _ -> None) + let children = + children + |> List.filter (fun (_, _, c) -> c.types |> List.isEmpty |> not) + |> List.map (fun (k, _, c) -> {| k with content = c.imports @ c.types; comments = [] |}) + |> ModuleEmitter.signature ctx st + children @ items + + let exports = + // TODO + [] + + let intf = + let children = + children + |> List.filter (fun (_, _, c) -> c.intf |> List.isEmpty |> not) + |> List.map (fun (k, openTypesModule, c) -> + let content = + if openTypesModule then + tprintf "open %s" k.name :: c.imports @ c.intf + else + c.imports @ c.intf + {| k with content = content; comments = c.comments |}) + |> ModuleEmitter.signature ctx st + let typeDefs = + items |> List.choose (function (c, Choice2Of4 t) when c.onIntf -> Some t | _ -> None) + [ + yield! children + yield! typeDefs + for cond, item in items do + if cond.onIntf then + match item with + | Choice3Of4 b -> yield! Binding.emitForInterface b + | Choice4Of4 c -> yield c + | _ -> () + yield! exports + ] + + let impl = + let children = + children + |> List.filter (fun (_, _, c) -> c.impl |> List.isEmpty |> not) + |> List.map (fun (k, openTypesModule, c) -> + let content = + if openTypesModule then + tprintf "open %s" k.name :: c.imports @ c.intf + else + c.imports @ c.intf + {| k with content = content; comments = c.comments |}) + |> ModuleEmitter.signature ctx st + let typeDefs = + items |> List.choose (function (c, Choice2Of4 t) when c.onImpl -> Some t | _ -> None) + [ + yield! children + yield! typeDefs + for cond, item in items do + if cond.onImpl then + match item with + | Choice3Of4 b -> yield! Binding.emitForImplementation b + | Choice4Of4 c -> yield c + | _ -> () + yield! exports + ] + + let comments = + match st.value with None -> [] | Some v -> v.comments + + {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} \ No newline at end of file From f8dc729b9d23001d6492030506f38af7ae4c9720 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 7 Mar 2022 20:24:42 +0900 Subject: [PATCH 16/56] Implement ReScript target --- build/build.fs | 69 ++++++-- dist_rescript/src/Ts.res | 6 +- src/Main.fs | 1 + src/Targets/ReScript/Common.fs | 48 +++++- src/Targets/ReScript/ReScriptHelper.fs | 18 ++- src/Targets/ReScript/Target.fs | 65 +++++++- src/Targets/ReScript/Writer.fs | 216 ++++++++++++++++++++++--- src/ts2ocaml.fsproj | 3 - test/res/.gitignore | 5 + test/res/bsconfig.json | 18 +++ test/res/package.json | 20 +++ test/res/src/Ts.res | 5 + test/res/yarn.lock | 181 +++++++++++++++++++++ 13 files changed, 609 insertions(+), 46 deletions(-) create mode 100644 test/res/.gitignore create mode 100644 test/res/bsconfig.json create mode 100644 test/res/package.json create mode 100644 test/res/src/Ts.res create mode 100644 test/res/yarn.lock diff --git a/build/build.fs b/build/build.fs index 3df90a61..22cd6a0d 100644 --- a/build/build.fs +++ b/build/build.fs @@ -74,7 +74,7 @@ let setup () = Target.create "Watch" <| fun _ -> dotnetExec "fable" $"watch {srcDir} --sourceMaps --define DEBUG --run webpack -w --mode=development" - Target.create "TestComplete" ignore + Target.create "Test" ignore "Clean" ?=> "Build" @@ -145,6 +145,56 @@ module Test = printfn "* copied to %s" file inDirectory testDir <| fun () -> dune "build" + module Res = + let testDir = testDir "res" + let outputDir = outputDir "test_res" + let srcDir = testDir "src" + let srcGeneratedDir = testDir "src" "generated" + + let clean () = + !! $"{outputDir}/*" + ++ $"{srcGeneratedDir}/*.res" + ++ $"{srcGeneratedDir}/generated/*.resi" + |> Seq.iter Shell.rm + + let generateBindings () = + Directory.create outputDir + + let ts2res args files = + Yarn.exec (sprintf "ts2ocaml res %s" (String.concat " " (Seq.append args files))) id + + ts2res ["--verbose"; "--nowarn"; "--stdlib"; $"-o {outputDir}"] <| + !! "node_modules/typescript/lib/lib.*.d.ts" + + let packages = [ + // "full" package involving a lot of inheritance + "full", !! "node_modules/typescript/lib/typescript.d.ts", []; + + // "full" packages involving a lot of dependencies (which includes some "safe" packages) + "safe", !! "node_modules/@types/scheduler/tracing.d.ts", []; + "full", !! "node_modules/csstype/index.d.ts", []; + "safe", !! "node_modules/@types/prop-types/index.d.ts", []; + "full", !! "node_modules/@types/react/index.d.ts" ++ "node_modules/@types/react/global.d.ts", ["--readable-names"]; + "full", !! "node_modules/@types/react-modal/index.d.ts", ["--readable-names"]; + + // "safe" package which depends on another "safe" package + "safe", !! "node_modules/@types/yargs-parser/index.d.ts", []; + "safe", !! "node_modules/@types/yargs/index.d.ts", []; + + "minimal", !! "node_modules/@types/vscode/index.d.ts", ["--safe-arity=full"; "--readable-names"]; + ] + + for preset, package, additionalOptions in packages do + ts2res + (["--verbose"; "--nowarn"; "--follow-relative-references"; + $"--preset {preset}"; $"-o {outputDir}"] @ additionalOptions) + package + + let build () = + for file in outputDir |> Shell.copyRecursiveTo true srcGeneratedDir do + printfn "* copied to %s" file + // inDirectory testDir <| fun () -> dune "build" + let setup () = Target.create "TestJsooClean" <| fun _ -> Jsoo.clean () Target.create "TestJsooGenerateBindings" <| fun _ -> Jsoo.generateBindings () @@ -157,13 +207,16 @@ module Test = ==> "TestJsooBuild" ==> "TestJsoo" - Target.create "Test" ignore - Target.create "TestOnly" ignore + Target.create "TestResClean" <| fun _ -> Test.Res.clean () + Target.create "TestResGenerateBindings" <| fun _ -> Test.Res.generateBindings () + Target.create "TestResBuild" <| fun _ -> Test.Res.build () + Target.create "TestRes" ignore - "TestJsoo" - ==> "TestOnly" - ==> "TestComplete" - ==> "Test" + "BuildForTest" + ==> "TestResClean" + ==> "TestResGenerateBindings" + ==> "TestResBuild" + ==> "TestRes" // Publish targets @@ -213,7 +266,6 @@ module Publish = let setup () = Target.create "Publish" <| fun _ -> () - Target.create "PublishOnly" <| fun _ -> () Target.create "PublishNpm" <| fun _ -> Npm.updateVersion () @@ -226,7 +278,6 @@ module Publish = "BuildForPublish" ==> "PublishNpm" ==> "PublishJsoo" - ==> "PublishOnly" ==> "Publish" "TestJsoo" ==> "PublishJsoo" diff --git a/dist_rescript/src/Ts.res b/dist_rescript/src/Ts.res index 95172239..097097b7 100644 --- a/dist_rescript/src/Ts.res +++ b/dist_rescript/src/Ts.res @@ -1 +1,5 @@ -include Ts__min \ No newline at end of file +include Ts__min +include Ts__es + +module Dom = Ts__dom +module WebWorker = Ts__webworker \ No newline at end of file diff --git a/src/Main.fs b/src/Main.fs index 2bcacbfb..72f9ee58 100644 --- a/src/Main.fs +++ b/src/Main.fs @@ -24,6 +24,7 @@ let main argv = .config() |> GlobalOptions.register |> Target.register parse Targets.JsOfOCaml.Target.target + |> Target.register parse Targets.ReScript.Target.target |> Target.register parse Targets.ParserTest.target yargs.demandCommand(1.0).scriptName("ts2ocaml").help().argv |> ignore 0 diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index ba426efc..340edd4c 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -51,6 +51,15 @@ type Preset = with static member Values = [|Minimal; Safe; Full|] +[] +type ModuleKind = + | [] None + | [] ES + | [] CJS + | [] Default +with + static member Values = [|None; ES; CJS; Default|] + type Options = inherit GlobalOptions inherit Typer.TyperOptions @@ -58,8 +67,12 @@ type Options = abstract preset: Preset option with get abstract createMinimalStdlib: bool with get abstract stdlib: bool with get // hidden + // JS options + abstract ``module``: ModuleKind with get + abstract name: string option with get // output options abstract outputDir: string option with get + abstract resi: bool with get // code generator options abstract numberAsInt: bool with get, set abstract subtyping: Subtyping list with get, set @@ -136,7 +149,24 @@ module Options = .group(!^ResizeArray[], "Parser Options:") .group( !^ResizeArray[ - "output-dir"; "stub-file" + "module"; "name" + ], "JS Module Options:") + .addOption( + "name", + (fun (o: Options) -> o.name), + descr="Override the JS module name used in the @module attribute (default: inferred from package.json).", + alias="n" + ) + .addChoice( + "module", + ModuleKind.Values, + (fun (o: Options) -> o.``module``), + descr="Override the JS module type (default: inferred from the input).", + defaultValue=ModuleKind.Default + ) + .group( + !^ResizeArray[ + "output-dir"; "resi" ], "Output Options:" ) @@ -145,6 +175,12 @@ module Options = (fun (o: Options) -> o.outputDir), descr="The directory to place the generated bindings.\nIf not set, it will be the current directory.", alias="o") + .addFlag( + "resi", + (fun (o: Options) -> o.resi), + descr = "Generate interface file (.resi) too. --no-resi to disable.", + defaultValue=true + ) .group( !^ResizeArray[ @@ -176,10 +212,8 @@ module Options = .group( !^ResizeArray[ "safe-arity"; - "rec-module"; "simplify"; "human-readable-anonymous-interface-names"; - "functor" ], "Code Generator Options:") .addChoice( @@ -206,9 +240,11 @@ module Options = type Output = { - fileName: string - content: text - stubLines: string list + baseName: string + /// the content of `.resi` file + resi: text option + /// the content of `.res` file + res: text } let [] stdlib: string = jsNative \ No newline at end of file diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 3b8e4d5d..73686f1c 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -177,10 +177,9 @@ module Naming = n |> Naming.toCase Naming.Case.LowerSnakeCase) |> String.concat "__" - let jsModuleNameToFileName isInterfaceFile (jsModuleName: string) = - jsModuleName - |> jsModuleNameToReScriptName - |> fun x -> if isInterfaceFile then $"{x}.resi" else $"{x}.res" + let jsModuleNameToFileName (jsModuleName: string) = + let basename = jsModuleName |> jsModuleNameToReScriptName + {| resi = $"{basename}.resi"; res = $"{basename}.res" |} let jsModuleNameToReScriptModuleName (jsModuleName: string) = jsModuleName @@ -248,7 +247,7 @@ module Type = let curriedArrow args ret = let lhs = match args with - | [] -> failwith "0-ary function" + | [] -> str "()" | [x] -> x | xs -> concat (str ", ") xs |> between "(" ")" lhs +@ " => " + ret @@ -257,7 +256,7 @@ module Type = let uncurriedArrow args ret = let lhs = match args with - | [] -> failwith "0-ary function" + | [] -> str "(. )" | xs -> concat (str ", ") xs |> between "(. " ")" lhs +@ " => " + ret @@ -464,3 +463,10 @@ module Statement = ] let moduleValMany ms = ms |> List.map moduleVal + + let moduleSigRec1 name (content: text list) = + concat newline [ + yield tprintf "module %s : {" name + yield indent (concat newline content) + yield tprintf "} = %s" name + ] \ No newline at end of file diff --git a/src/Targets/ReScript/Target.fs b/src/Targets/ReScript/Target.fs index f81effac..2b532d72 100644 --- a/src/Targets/ReScript/Target.fs +++ b/src/Targets/ReScript/Target.fs @@ -1 +1,64 @@ -module Targets.ReScript.Target \ No newline at end of file +module Targets.ReScript.Target + +open Ts2Ml +open Syntax +open DataTypes + +open Target +open Targets.ReScript.Common +open Targets.ReScript.Writer + +open Fable.Core.JsInterop + +let private builder (argv: Yargs.Argv) : Yargs.Argv = + argv |> Options.register + +let private run (input: Input) (ctx: IContext) = + let outputDir = + let curdir = Node.Api.``process``.cwd() + match ctx.options.outputDir with + | None -> curdir + | Some dir -> + let path = + if Node.Api.path.isAbsolute dir then dir + else Node.Api.path.join [|curdir; dir|] + let fail () = + failwithf "The output directory '%s' does not exist." path + try + if Node.Api.fs.lstatSync(!^path).isDirectory() then path + else fail () + with + _ -> fail () + + let results = + let result = + if ctx.options.createMinimalStdlib then + [{ baseName = "Ts__min"; res = Text.str stdlib; resi = None }] + else [] + if List.isEmpty input.sources then result + else if ctx.options.stdlib then + result @ emitStdlib input ctx + else + result @ emit input ctx + + if results = [] then + ctx.logger.warnf "no input files are given." + + for result in results do + let fileName = result.baseName + ".res" + let fullPath = Node.Api.path.join[|outputDir; fileName|] + ctx.logger.tracef "* writing the binding to '%s'..." fullPath + Node.Api.fs.writeFileSync(fullPath, Text.toString 2 result.res) + match result.resi with + | None -> () + | Some resi -> + let fileName = result.baseName + ".resi" + let fullPath = Node.Api.path.join[|outputDir; fileName|] + Node.Api.fs.writeFileSync(fullPath, Text.toString 2 resi) + +let target = + { new ITarget with + member __.Command = "res" + member __.Description = "Generate binding for ReScript" + member __.Builder = builder + member __.Run (srcs, options) = run srcs options } \ No newline at end of file diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index cdf44b67..973c373a 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -315,14 +315,6 @@ and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) | false, true -> Type.undefined_or rest | false, false -> rest -let setTyperOptions (ctx: IContext) = - ctx.options.inheritArraylike <- true - ctx.options.inheritIterable <- true - ctx.options.inheritPromiselike <- true - ctx.options.replaceAliasToFunction <- false - ctx.options.replaceNewableFunction <- false - ctx.options.replaceRankNFunction <- true - /// `[ #A | #B | ... ]` let rec emitLabels (ctx: Context) labels = emitLabelsBody ctx labels |> between "[" "]" @@ -426,6 +418,7 @@ let builder name (fields: {| isOptional: bool; name: string; value: text |} list let args = fields |> List.map (fun f -> + let name = f.name let name = if Naming.isValid name && (name[0] = '_' || System.Char.IsLower(name[0])) then name else String.escape name |> sprintf "\\\"%s\"" @@ -584,6 +577,7 @@ let inline binding (f: (string -> string) -> CurrentScope -> Binding) = let scopeToAttr (s: CurrentScope) attr = match s.scopeRev, s.jsModule with | [], None -> attr + | [], Some m -> Attr.External.module_ (Some m) :: attr | sr, None -> Attr.External.scope (List.rev sr) :: attr | sr, Some m -> Attr.External.module_ (Some m) :: Attr.External.scope (List.rev sr) :: attr @@ -1021,12 +1015,11 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let onIntf = emitTypeAliases flags overrideFunc innerCtx c.typeParams selfTyText |> List.map (conditional { EmitCondition.empty with onIntf = true }) - let onImpl = - let selfTyText = + let origTyText = let tyargs = c.typeParams |> List.map (fun x -> tprintf "'%s" x.name) Type.appOpt (str "t") tyargs - emitTypeAliases flags overrideFunc innerCtx c.typeParams selfTyText + emitTypeAliases flags overrideFunc innerCtx c.typeParams origTyText |> List.map (conditional { EmitCondition.empty with onImpl = true }) List.concat [onTypes; onIntf; onImpl] @@ -1074,7 +1067,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c Some {| isOptional = false; name = name; value = value |} *) | _ -> None) - binding (fun rename _ -> builder (rename "create") fields selfTyText) + binding (fun rename _ -> builder (rename "make") fields selfTyText) let items = [ yield! baseTypeDefinition @@ -1171,17 +1164,17 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu | Some (LInt _) -> EnumType.Int | Some (LFloat _) -> EnumType.Float | Some (LBool _) -> EnumType.Boolean) + |> List.distinct |> List.sort match types with | [EnumType.Int] -> - let values = + let isClean = enumValues |> List.map (function Some (LInt i) -> i | _ -> failwith "impossible") - |> Set.ofList - let min = Set.minElement values - let max = Set.maxElement values - let clean = Set.ofList [min..max] - if min = 0 && values = clean then EnumType.CleanInt + |> Seq.sort + |> Seq.mapi ((=)) + |> Seq.forall id + if isClean then EnumType.CleanInt else EnumType.Int | [x] -> x | [EnumType.Int; EnumType.Float] -> EnumType.Number @@ -1608,7 +1601,7 @@ module ModuleEmitter = let modules = modules |> List.fold (fun state x -> state |> Map.add x.origName x) Map.empty scc |> List.map (fun group -> - group |> List.map (fun name -> modules |> Map.find name) |> Statement.moduleSigRec) + group |> List.choose (fun name -> modules |> Map.tryFind name) |> Statement.moduleSigRec) |> List.concat let structure (_: Context) (_: StructuredText) = Statement.moduleValMany @@ -1751,4 +1744,187 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) let comments = match st.value with None -> [] | Some v -> v.comments - {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} \ No newline at end of file + {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} + +let setTyperOptions (ctx: IContext) = + ctx.options.inheritArraylike <- true + ctx.options.inheritIterable <- true + ctx.options.inheritPromiselike <- true + ctx.options.replaceAliasToFunction <- false + ctx.options.replaceNewableFunction <- false + ctx.options.replaceRankNFunction <- true + +let emitTypes (types: text list) : text list = + [ + Statement.moduleSigRec1 "Types" types + Statement.open_ "Types" + ] + +let emitStdlib (input: Input) (ctx: IContext) : Output list = + let srcs = input.sources + + ctx.logger.tracef "* looking up the minimal supported ES version for each definition..." + let esSrc = + srcs + |> List.filter (fun src -> src.fileName.Contains("lib.es") && src.fileName.EndsWith(".d.ts")) + |> mergeESLibDefinitions + let domSrc = + srcs + |> List.filter (fun src -> src.fileName.Contains("lib.dom") && src.fileName.EndsWith(".d.ts")) + |> mergeSources "lib.dom.d.ts" + let webworkerSrc = + srcs + |> List.filter (fun src -> src.fileName.Contains("lib.webworker") && src.fileName.EndsWith(".d.ts")) + |> mergeSources "lib.webworker.d.ts" + |> fun src -> + let statements = + src.statements |> Statement.mapIdent (fun i -> + i |> Ident.mapSource (fun path -> + // webworker does not depend on DOM but fullnames can still refer to it + if path.Contains("lib.dom") && src.fileName.EndsWith(".d.ts") then "lib.webworker.d.ts" + else path + ) + ) + { src with statements = statements } + + ctx.logger.tracef "* running typer..." + + setTyperOptions ctx + let opts = ctx.options + opts.simplify <- [Simplify.All] + opts.inheritWithTags <- FeatureFlag.Full + opts.safeArity <- FeatureFlag.Full + opts.subtyping <- [Subtyping.Tag] + + let flags : EmitModuleFlags = + {| jsModule = None; scopeRev = []; isReservedModule = false |} + + let esCtx, esSrc = runAll [esSrc] ctx + let domCtx, domSrc = runAll [domSrc] ctx + let webworkerCtx, webworkerSrc = runAll [webworkerSrc] ctx + + let writerCtx (srcs: SourceFile list) ctx = + ctx |> Context.mapOptions (fun _ -> opts) + |> Context.mapState (fun _ -> State.create (srcs |> List.map (fun src -> src.fileName)) (Error None)) + + ctx.logger.tracef "* emitting stdlib..." + + let createOutput (baseName: string) (opens: string list) (ctx: Context) (src: SourceFile list) = + let stmts = src |> List.collect (fun x -> x.statements) + let ctx = ctx |> Context.ofSourceFileRoot (src[0].fileName) + let st = createStructuredText ctx stmts + let m = emitModule flags ctx st + let res = + concat newline [ + yield! m.comments + for o in opens do yield Statement.open_ o + yield! m.imports + yield! emitTypes m.types + yield! m.impl + ] + let resi = + concat newline [ + yield! m.comments + for o in opens do yield Statement.open_ o + yield! m.imports + yield! m.intf + ] + { baseName = baseName; resi = Some resi; res = res } + + let minLib = + { baseName = "Ts__min"; resi = None; res = str stdlib } + + [ minLib + createOutput "Ts__es" ["Ts__min"] (writerCtx esSrc esCtx) esSrc + createOutput "Ts__dom" ["Ts__min"; "Ts__es"] (writerCtx domSrc domCtx) domSrc + createOutput "Ts__webworker" ["Ts__min"; "Ts__es"] (writerCtx webworkerSrc webworkerCtx) webworkerSrc ] + +let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: IContext) = + let moduleName = + match ctx.options.name with + | Some name -> name + | None -> + JsHelper.deriveModuleName info (sources |> List.map (fun s -> s.fileName)) + |> JsHelper.InferenceResult.unwrap "package" + + let outputBaseName = + match ctx.options.name with + | Some name -> name + | None -> + let inline log x = + ctx.logger.tracef "* the inferred output file name is '%s.res'" x + x + JsHelper.deriveModuleName info (sources |> List.map (fun s -> s.fileName)) + |> JsHelper.InferenceResult.tryUnwrap + |> Option.map log + |> Option.defaultWith (fun () -> + ctx.logger.warnf "* the output file name cannot be inferred. 'output.res' is used instead." + "output") + + let fileNames = sources |> List.map (fun s -> s.fileName) + + let info = + match info with + | Some info -> Ok info + | None -> Error (Some moduleName) + + let sources, mergedFileName = + match sources with + | [] -> failwith "impossible_emitImpl (empty sources)" + | [src] -> [src], src.fileName + | _ -> [mergeSources "input.d.ts" sources], "input.d.ts" + + ctx.logger.tracef "* running typer..." + setTyperOptions ctx + let ctx, sources = runAll sources ctx + let ctx = + ctx + |> Context.mapState (fun _ -> State.create fileNames info) + |> Context.ofSourceFileRoot mergedFileName + let stmts = sources |> List.collect (fun x -> x.statements) + + ctx.logger.tracef "* emitting a binding to '%s' for rescript..." moduleName + let structuredText = createStructuredText ctx stmts + let flags : EmitModuleFlags = + let jsModule = + match ctx.options.``module`` with + | ModuleKind.None -> None + | ModuleKind.ES | ModuleKind.CJS -> Some moduleName + | ModuleKind.Default -> + let hasExport = + ctx.info |> Map.exists (fun _ v -> v.exportMap |> Trie.isEmpty |> not) + if hasExport then Some moduleName else None + {| jsModule = jsModule; scopeRev = []; isReservedModule = false |} + let m = emitModule flags ctx structuredText + + let opens = [ + yield Statement.open_ "Ts" + yield Statement.open_ "Ts.Dom" + ] + + let res = + concat newline [ + yield! m.comments + yield! opens + yield! m.imports + yield! emitTypes m.types + yield! m.impl + ] + let resi = + if ctx.options.resi then + concat newline [ + yield! m.comments + yield! opens + yield! m.imports + yield! m.intf + ] |> Some + else None + + { baseName = outputBaseName; resi = resi; res = res} + +let emit (input: Input) (ctx: IContext) : Output list = + if ctx.options.merge then + [emitImpl input.sources input.info ctx] + else + input.sources + |> List.map (fun source -> emitImpl [source] input.info ctx) \ No newline at end of file diff --git a/src/ts2ocaml.fsproj b/src/ts2ocaml.fsproj index 38eb9457..5d99e282 100644 --- a/src/ts2ocaml.fsproj +++ b/src/ts2ocaml.fsproj @@ -19,9 +19,6 @@ - - - diff --git a/test/res/.gitignore b/test/res/.gitignore new file mode 100644 index 00000000..3deb57a7 --- /dev/null +++ b/test/res/.gitignore @@ -0,0 +1,5 @@ +.DS_Store +/node_modules/ +/lib/ +.bsb.lock +.merlin diff --git a/test/res/bsconfig.json b/test/res/bsconfig.json new file mode 100644 index 00000000..67357883 --- /dev/null +++ b/test/res/bsconfig.json @@ -0,0 +1,18 @@ +{ + "name": "rescript-project-template", + "version": "0.0.1", + "sources": { + "dir" : "src", + "subdirs" : true + }, + "package-specs": { + "module": "commonjs", + "in-source": true + }, + "suffix": ".bs.js", + "bs-dependencies": [ + ], + "warnings": { + "error" : "+101" + } +} diff --git a/test/res/package.json b/test/res/package.json new file mode 100644 index 00000000..0feac795 --- /dev/null +++ b/test/res/package.json @@ -0,0 +1,20 @@ +{ + "name": "rescript-project-template", + "version": "0.0.1", + "scripts": { + "build": "rescript", + "clean": "rescript clean -with-deps", + "start": "rescript build -w" + }, + "keywords": [ + "rescript" + ], + "author": "", + "license": "MIT", + "dependencies": { + "rescript": "9.1.4", + "typescript": "4.6.2", + "yargs": "17.3.1", + "react-player": "2.9.0" + } +} diff --git a/test/res/src/Ts.res b/test/res/src/Ts.res new file mode 100644 index 00000000..097097b7 --- /dev/null +++ b/test/res/src/Ts.res @@ -0,0 +1,5 @@ +include Ts__min +include Ts__es + +module Dom = Ts__dom +module WebWorker = Ts__webworker \ No newline at end of file diff --git a/test/res/yarn.lock b/test/res/yarn.lock new file mode 100644 index 00000000..23cfa1c5 --- /dev/null +++ b/test/res/yarn.lock @@ -0,0 +1,181 @@ +# THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY. +# yarn lockfile v1 + + +ansi-regex@^5.0.1: + version "5.0.1" + resolved "https://registry.yarnpkg.com/ansi-regex/-/ansi-regex-5.0.1.tgz#082cb2c89c9fe8659a311a53bd6a4dc5301db304" + integrity sha512-quJQXlTSUGL2LH9SUXo8VwsY4soanhgo6LNSm84E1LBcE8s3O0wpdiRzyR9z/ZZJMlMWv37qOOb9pdJlMUEKFQ== + +ansi-styles@^4.0.0: + version "4.3.0" + resolved "https://registry.yarnpkg.com/ansi-styles/-/ansi-styles-4.3.0.tgz#edd803628ae71c04c85ae7a0906edad34b648937" + integrity sha512-zbB9rCJAT1rbjiVDb2hqKFHNYLxgtk8NURxZ3IZwD3F6NtxbXZQCnnSi1Lkx+IDohdPlFp222wVALIheZJQSEg== + dependencies: + color-convert "^2.0.1" + +cliui@^7.0.2: + version "7.0.4" + resolved "https://registry.yarnpkg.com/cliui/-/cliui-7.0.4.tgz#a0265ee655476fc807aea9df3df8df7783808b4f" + integrity sha512-OcRE68cOsVMXp1Yvonl/fzkQOyjLSu/8bhPDfQt0e0/Eb283TKP20Fs2MqoPsr9SwA595rRCA+QMzYc9nBP+JQ== + dependencies: + string-width "^4.2.0" + strip-ansi "^6.0.0" + wrap-ansi "^7.0.0" + +color-convert@^2.0.1: + version "2.0.1" + resolved "https://registry.yarnpkg.com/color-convert/-/color-convert-2.0.1.tgz#72d3a68d598c9bdb3af2ad1e84f21d896abd4de3" + integrity sha512-RRECPsj7iu/xb5oKYcsFHSppFNnsj/52OVTRKb4zP5onXwVF3zVmmToNcOfGC+CRDpfK/U584fMg38ZHCaElKQ== + dependencies: + color-name "~1.1.4" + +color-name@~1.1.4: + version "1.1.4" + resolved "https://registry.yarnpkg.com/color-name/-/color-name-1.1.4.tgz#c2a09a87acbde69543de6f63fa3995c826c536a2" + integrity sha512-dOy+3AuW3a2wNbZHIuMZpTcgjGuLU/uBL/ubcZF9OXbDo8ff4O8yVp5Bf0efS8uEoYo5q4Fx7dY9OgQGXgAsQA== + +deepmerge@^4.0.0: + version "4.2.2" + resolved "https://registry.yarnpkg.com/deepmerge/-/deepmerge-4.2.2.tgz#44d2ea3679b8f4d4ffba33f03d865fc1e7bf4955" + integrity sha512-FJ3UgI4gIl+PHZm53knsuSFpE+nESMr7M4v9QcgB7S63Kj/6WqMiFQJpBBYz1Pt+66bZpP3Q7Lye0Oo9MPKEdg== + +emoji-regex@^8.0.0: + version "8.0.0" + resolved "https://registry.yarnpkg.com/emoji-regex/-/emoji-regex-8.0.0.tgz#e818fd69ce5ccfcb404594f842963bf53164cc37" + integrity sha512-MSjYzcWNOA0ewAHpz0MxpYFvwg6yjy1NG3xteoqz644VCo/RPgnr1/GGt+ic3iJTzQ8Eu3TdM14SawnVUmGE6A== + +escalade@^3.1.1: + version "3.1.1" + resolved "https://registry.yarnpkg.com/escalade/-/escalade-3.1.1.tgz#d8cfdc7000965c5a0174b4a82eaa5c0552742e40" + integrity sha512-k0er2gUkLf8O0zKJiAhmkTnJlTvINGv7ygDNPbeIsX/TJjGJZHuh9B2UxbsaEkmlEo9MfhrSzmhIlhRlI2GXnw== + +get-caller-file@^2.0.5: + version "2.0.5" + resolved "https://registry.yarnpkg.com/get-caller-file/-/get-caller-file-2.0.5.tgz#4f94412a82db32f36e3b0b9741f8a97feb031f7e" + integrity sha512-DyFP3BM/3YHTQOCUL/w0OZHR0lpKeGrxotcHWcqNEdnltqFwXVfhEBQ94eIo34AfQpo0rGki4cyIiftY06h2Fg== + +is-fullwidth-code-point@^3.0.0: + version "3.0.0" + resolved "https://registry.yarnpkg.com/is-fullwidth-code-point/-/is-fullwidth-code-point-3.0.0.tgz#f116f8064fe90b3f7844a38997c0b75051269f1d" + integrity sha512-zymm5+u+sCsSWyD9qNaejV3DFvhCKclKdizYaJUuHA83RLjb7nSuGnddCHGv0hk+KY7BMAlsWeK4Ueg6EV6XQg== + +"js-tokens@^3.0.0 || ^4.0.0": + version "4.0.0" + resolved "https://registry.yarnpkg.com/js-tokens/-/js-tokens-4.0.0.tgz#19203fb59991df98e3a287050d4647cdeaf32499" + integrity sha512-RdJUflcE3cUzKiMqQgsCu06FPu9UdIJO0beYbPhHN4k6apgJtifcoCtT9bcxOpYBtpD2kCM6Sbzg4CausW/PKQ== + +load-script@^1.0.0: + version "1.0.0" + resolved "https://registry.yarnpkg.com/load-script/-/load-script-1.0.0.tgz#0491939e0bee5643ee494a7e3da3d2bac70c6ca4" + integrity sha1-BJGTngvuVkPuSUp+PaPSuscMbKQ= + +loose-envify@^1.4.0: + version "1.4.0" + resolved "https://registry.yarnpkg.com/loose-envify/-/loose-envify-1.4.0.tgz#71ee51fa7be4caec1a63839f7e682d8132d30caf" + integrity sha512-lyuxPGr/Wfhrlem2CL/UcnUc1zcqKAImBDzukY7Y5F/yQiNdko6+fRLevlw1HgMySw7f611UIY408EtxRSoK3Q== + dependencies: + js-tokens "^3.0.0 || ^4.0.0" + +memoize-one@^5.1.1: + version "5.2.1" + resolved "https://registry.yarnpkg.com/memoize-one/-/memoize-one-5.2.1.tgz#8337aa3c4335581839ec01c3d594090cebe8f00e" + integrity sha512-zYiwtZUcYyXKo/np96AGZAckk+FWWsUdJ3cHGGmld7+AhvcWmQyGCYUh1hc4Q/pkOhb65dQR/pqCyK0cOaHz4Q== + +object-assign@^4.1.1: + version "4.1.1" + resolved "https://registry.yarnpkg.com/object-assign/-/object-assign-4.1.1.tgz#2109adc7965887cfc05cbbd442cac8bfbb360863" + integrity sha1-IQmtx5ZYh8/AXLvUQsrIv7s2CGM= + +prop-types@^15.7.2: + version "15.8.1" + resolved "https://registry.yarnpkg.com/prop-types/-/prop-types-15.8.1.tgz#67d87bf1a694f48435cf332c24af10214a3140b5" + integrity sha512-oj87CgZICdulUohogVAR7AjlC0327U4el4L6eAvOqCeudMDVU0NThNaV+b9Df4dXgSP1gXMTnPdhfe/2qDH5cg== + dependencies: + loose-envify "^1.4.0" + object-assign "^4.1.1" + react-is "^16.13.1" + +react-fast-compare@^3.0.1: + version "3.2.0" + resolved "https://registry.yarnpkg.com/react-fast-compare/-/react-fast-compare-3.2.0.tgz#641a9da81b6a6320f270e89724fb45a0b39e43bb" + integrity sha512-rtGImPZ0YyLrscKI9xTpV8psd6I8VAtjKCzQDlzyDvqJA8XOW78TXYQwNRNd8g8JZnDu8q9Fu/1v4HPAVwVdHA== + +react-is@^16.13.1: + version "16.13.1" + resolved "https://registry.yarnpkg.com/react-is/-/react-is-16.13.1.tgz#789729a4dc36de2999dc156dd6c1d9c18cea56a4" + integrity sha512-24e6ynE2H+OKt4kqsOvNd8kBpV65zoxbA4BVsEOB3ARVWQki/DHzaUoC5KuON/BiccDaCCTZBuOcfZs70kR8bQ== + +react-player@2.9.0: + version "2.9.0" + resolved "https://registry.yarnpkg.com/react-player/-/react-player-2.9.0.tgz#ef7fe7073434087565f00ff219824e1e02c4b046" + integrity sha512-jNUkTfMmUhwPPAktAdIqiBcVUKsFKrVGH6Ocutj6535CNfM91yrvWxHg6fvIX8Y/fjYUPoejddwh7qboNV9vGA== + dependencies: + deepmerge "^4.0.0" + load-script "^1.0.0" + memoize-one "^5.1.1" + prop-types "^15.7.2" + react-fast-compare "^3.0.1" + +require-directory@^2.1.1: + version "2.1.1" + resolved "https://registry.yarnpkg.com/require-directory/-/require-directory-2.1.1.tgz#8c64ad5fd30dab1c976e2344ffe7f792a6a6df42" + integrity sha1-jGStX9MNqxyXbiNE/+f3kqam30I= + +rescript@9.1.4: + version "9.1.4" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-9.1.4.tgz#1eb126f98d6c16942c0bf0df67c050198e580515" + integrity sha512-aXANK4IqecJzdnDpJUsU6pxMViCR5ogAxzuqS0mOr8TloMnzAjJFu63fjD6LCkWrKAhlMkFFzQvVQYaAaVkFXw== + +string-width@^4.1.0, string-width@^4.2.0, string-width@^4.2.3: + version "4.2.3" + resolved "https://registry.yarnpkg.com/string-width/-/string-width-4.2.3.tgz#269c7117d27b05ad2e536830a8ec895ef9c6d010" + integrity sha512-wKyQRQpjJ0sIp62ErSZdGsjMJWsap5oRNihHhu6G7JVO/9jIB6UyevL+tXuOqrng8j/cxKTWyWUwvSTriiZz/g== + dependencies: + emoji-regex "^8.0.0" + is-fullwidth-code-point "^3.0.0" + strip-ansi "^6.0.1" + +strip-ansi@^6.0.0, strip-ansi@^6.0.1: + version "6.0.1" + resolved "https://registry.yarnpkg.com/strip-ansi/-/strip-ansi-6.0.1.tgz#9e26c63d30f53443e9489495b2105d37b67a85d9" + integrity sha512-Y38VPSHcqkFrCpFnQ9vuSXmquuv5oXOKpGeT6aGrr3o3Gc9AlVa6JBfUSOCnbxGGZF+/0ooI7KrPuUSztUdU5A== + dependencies: + ansi-regex "^5.0.1" + +typescript@4.6.2: + version "4.6.2" + resolved "https://registry.yarnpkg.com/typescript/-/typescript-4.6.2.tgz#fe12d2727b708f4eef40f51598b3398baa9611d4" + integrity sha512-HM/hFigTBHZhLXshn9sN37H085+hQGeJHJ/X7LpBWLID/fbc2acUMfU+lGD98X81sKP+pFa9f0DZmCwB9GnbAg== + +wrap-ansi@^7.0.0: + version "7.0.0" + resolved "https://registry.yarnpkg.com/wrap-ansi/-/wrap-ansi-7.0.0.tgz#67e145cff510a6a6984bdf1152911d69d2eb9e43" + integrity sha512-YVGIj2kamLSTxw6NsZjoBxfSwsn0ycdesmc4p+Q21c5zPuZ1pl+NfxVdxPtdHvmNVOQ6XSYG4AUtyt/Fi7D16Q== + dependencies: + ansi-styles "^4.0.0" + string-width "^4.1.0" + strip-ansi "^6.0.0" + +y18n@^5.0.5: + version "5.0.8" + resolved "https://registry.yarnpkg.com/y18n/-/y18n-5.0.8.tgz#7f4934d0f7ca8c56f95314939ddcd2dd91ce1d55" + integrity sha512-0pfFzegeDWJHJIAmTLRP2DwHjdF5s7jo9tuztdQxAhINCdvS+3nGINqPd00AphqJR/0LhANUS6/+7SCb98YOfA== + +yargs-parser@^21.0.0: + version "21.0.1" + resolved "https://registry.yarnpkg.com/yargs-parser/-/yargs-parser-21.0.1.tgz#0267f286c877a4f0f728fceb6f8a3e4cb95c6e35" + integrity sha512-9BK1jFpLzJROCI5TzwZL/TU4gqjK5xiHV/RfWLOahrjAko/e4DJkRDZQXfvqAsiZzzYhgAzbgz6lg48jcm4GLg== + +yargs@17.3.1: + version "17.3.1" + resolved "https://registry.yarnpkg.com/yargs/-/yargs-17.3.1.tgz#da56b28f32e2fd45aefb402ed9c26f42be4c07b9" + integrity sha512-WUANQeVgjLbNsEmGk20f+nlHgOqzRFpiGWVaBrYGYIGANIIu3lWjoyi0fNlFmJkvfhCZ6BXINe7/W2O2bV4iaA== + dependencies: + cliui "^7.0.2" + escalade "^3.1.1" + get-caller-file "^2.0.5" + require-directory "^2.1.1" + string-width "^4.2.3" + y18n "^5.0.5" + yargs-parser "^21.0.0" From 27e0543c50f527d92a3548db85b1d2aa1056270d Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 9 Mar 2022 18:34:50 +0900 Subject: [PATCH 17/56] [WIP] try to generate compilable stdlib --- src/Targets/ReScript/ReScriptHelper.fs | 36 ++-- src/Targets/ReScript/Writer.fs | 241 ++++++++++++++----------- test/res/.gitignore | 1 + 3 files changed, 158 insertions(+), 120 deletions(-) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 73686f1c..0e589b08 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -98,25 +98,20 @@ module Attr = module Naming = let removeInvalidChars (s: string) = s.ToCharArray() - |> Array.map (fun c -> if Char.isAlphabetOrDigit c || c = '_' then c else '_') + |> Array.map (fun c -> if Char.isAlphabetOrDigit c || c = '_' || c = '\'' then c else '_') |> System.String let isValid (s: string) = Char.isAlphabet(s[0]) - && s.ToCharArray() |> Array.forall(fun c -> Char.isAlphabetOrDigit c || c = '_') + && s.ToCharArray() |> Array.forall(fun c -> Char.isAlphabetOrDigit c || c = '_' || c = '\'') let keywords = set [ "and"; "as"; "assert"; "constraint"; "else"; "exception"; "external" "false"; "for"; "if"; "in"; "include"; "lazy"; "let"; "module"; "mutable" - "of"; "open"; "rec"; "switch"; "true"; "try"; "type"; "when"; "while"; "with" + "of"; "open"; "private"; "rec"; "switch"; "true"; "try"; "type"; "when"; "while"; "with" ] - let reservedValueNames = - set [ - "make"; "apply"; "get"; "set"; "castFrom" - ] |> Set.union keywords - let upperFirst (s: string) = if Char.IsLower s[0] then sprintf "%c%s" (Char.ToUpper s[0]) s[1..] @@ -128,13 +123,16 @@ module Naming = else s let valueName (name: string) = - let name = removeInvalidChars name - let result = - if name = "NaN" then "nan" - else if String.forall (fun c -> Char.IsLower c |> not) name then - name.ToLowerInvariant() - else lowerFirst name - if reservedValueNames |> Set.contains result then result + "_" else result + let check name = + if keywords |> Set.contains name then + String.escape name |> sprintf "\\\"%s\"" + else name + if name = "NaN" then "nan" + else if not (isValid name) then + String.escape name |> sprintf "\\\"%s\"" + else if String.forall (fun c -> Char.IsUpper c || c = '_' || c = '\'') name then + name.ToLower() |> check + else lowerFirst name |> check let reservedModuleNames = Set.ofList [ @@ -169,7 +167,7 @@ module Naming = else sprintf "%s%d" name arity | None -> sprintf "%s%d" name arity - let private jsModuleNameToReScriptName (jsModuleName: string) = + let jsModuleNameToReScriptName (jsModuleName: string) = match jsModuleName.TrimStart('@') |> String.splitThenRemoveEmptyEntries "/" |> Array.toList with | xs -> xs @@ -256,7 +254,7 @@ module Type = let uncurriedArrow args ret = let lhs = match args with - | [] -> str "(. )" + | [] -> str "()" | xs -> concat (str ", ") xs |> between "(. " ")" lhs +@ " => " + ret @@ -273,7 +271,9 @@ module Type = let name = match case.name with | Choice1Of2 str -> - if Naming.isValid str then str else sprintf "\"%s\"" (String.escape str) + if Naming.isValid str && Naming.keywords |> Set.contains str |> not then + str + else sprintf "\"%s\"" (String.escape str) | Choice2Of2 i -> sprintf "%d" i let attr = match case.attr with diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 973c373a..8a945faf 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -167,15 +167,28 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C | _ -> fallback () tyName |> withTyargs | Some (fn, typrms, origLoc) -> - let name = Naming.structured Naming.moduleName fn.name + ".t" - let ts = - assignTypeParams fn.name (origLoc ++ loc) typrms tyargs - (fun _ t -> t) - (fun tv -> - match tv.defaultType with - | Some t -> t - | None -> failwithf "error: insufficient type params for type '%s' at %s" (String.concat "." fn.name) loc.AsString) - Type.appOpt (str name) (ts |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) + let result name = + let ts = + assignTypeParams fn.name (origLoc ++ loc) typrms tyargs + (fun _ t -> t) + (fun tv -> + match tv.defaultType with + | Some t -> t + | None -> failwithf "error: insufficient type params for type '%s' at %s" (String.concat "." fn.name) loc.AsString) + Type.appOpt (str name) (ts |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) + let fullName = Naming.structured Naming.moduleName fn.name + ".t" + if fn.source <> ctx.currentSourceFile then result fullName + else + match ctx |> Context.getRelativeNameTo fn.name with + | Ok relativeName -> result (Naming.structured Naming.moduleName relativeName + ".t") + | Error [] -> result "t" + | Error diff -> + let fn = String.concat "." fn.name + let selfName = String.concat "." diff + let warnText = $"cannot reference a type {fn} from its sub-namespace {selfName}" + Log.warnf ctx.options "%s at %s" warnText loc.AsString + commentStr warnText + Type.any + match overrideFunc flags (emitTypeImpl flags overrideFunc) ctx ty with | Some t -> t | None -> @@ -278,14 +291,14 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte | Choice1Of2 x :: [] when f.isVariadic -> assert (not x.isOptional) let t = emitTypeImpl { flags with external = External.Argument true } overrideFunc ctx x.value - (tprintf "~%s:" x.name + t) :: acc + (tprintf "~%s:" (Naming.valueName x.name) + t) :: acc | Choice2Of2 t :: [] -> let flags = if f.isVariadic then { flags with external = External.Argument true } else flags emitTypeImpl flags overrideFunc ctx t :: acc | Choice1Of2 x :: rest -> let arg = - let tmp = tprintf "~%s:" x.name + emitTypeImpl flags overrideFunc ctx x.value + let tmp = tprintf "~%s:" (Naming.valueName x.name) + emitTypeImpl flags overrideFunc ctx x.value if x.isOptional then tmp +@ "=?" else tmp go (optional || x.isOptional) (arg :: acc) rest | Choice2Of2 t :: rest -> @@ -295,11 +308,11 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte match flags.external with | _ when isNewable -> if f.isVariadic then variadicFallback () else newableFallback () - | External.Root (true, _) -> Type.curriedArrow (args ()) (retTy (EmitTypeFlags.ofFuncReturn flags)) + | External.Root (true, _) -> Type.curriedArrow (args ()) (retTy flags) | _ when f.isVariadic -> variadicFallback () - | External.Root (_, _) -> Type.curriedArrow (args ()) (retTy (EmitTypeFlags.ofFuncReturn flags)) - | External.Argument _ -> paren ("@uncurry " @+ Type.curriedArrow (args ()) (retTy (EmitTypeFlags.ofFuncReturn flags))) - | _ -> Type.uncurriedArrow (args ()) (retTy (EmitTypeFlags.ofFuncReturn flags)) |> paren + | External.Root (_, _) -> Type.curriedArrow (args ()) (retTy flags) + | External.Argument _ -> paren ("@uncurry " @+ Type.curriedArrow (args ()) (retTy flags)) + | _ -> Type.uncurriedArrow (args ()) (retTy flags) |> paren and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (u: UnionType) : text = // TODO: more classification @@ -316,7 +329,7 @@ and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) | false, false -> rest /// `[ #A | #B | ... ]` -let rec emitLabels (ctx: Context) labels = +and emitLabels (ctx: Context) labels = emitLabelsBody ctx labels |> between "[" "]" /// `#A | #B | ...` @@ -403,7 +416,7 @@ module Binding = match b with | Binding.Let x -> yield Statement.let_ x.attrs x.name x.ty x.body | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target - | Binding.Unknown x -> match x.msg with Some msg -> yield msg | None -> () + | Binding.Unknown x -> match x.msg with Some msg -> yield comment msg | None -> () ] let emitForInterface (b: Binding) = [ @@ -411,17 +424,14 @@ module Binding = match b with | Binding.Let x -> yield Statement.val_ x.attrs x.name x.ty | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target - | Binding.Unknown x -> match x.msg with Some msg -> yield msg | None -> () + | Binding.Unknown x -> match x.msg with Some msg -> yield comment msg | None -> () ] let builder name (fields: {| isOptional: bool; name: string; value: text |} list) (thisType: text) = let args = fields |> List.map (fun f -> - let name = f.name - let name = - if Naming.isValid name && (name[0] = '_' || System.Char.IsLower(name[0])) then name - else String.escape name |> sprintf "\\\"%s\"" + let name = f.name |> Naming.valueName let suffix = if f.isOptional then "=?" else "" tprintf "~%s: " name + f.value +@ suffix) @@ -456,6 +466,7 @@ type StructuredTextItem = | Comment of text /// Will only be emitted in `.res` (not in `.resi` or in the `Types` module) | Binding of (OverloadRenamer -> CurrentScope -> Binding) + | EnumCaseText of {| name: string; ty: text; comments: Comment list |} and CurrentScope = { jsModule: string option @@ -642,7 +653,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ty, attrs = extFunc { args = ft.args; isVariadic = ft.isVariadic; returnType = selfTy; loc = ft.loc } binding (fun rename s -> let target, attrs = - if isExportDefaultClass then + if isExportDefaultClass || List.isEmpty s.scopeRev then match s.jsModule with | Some m -> m, Attr.External.module_ None :: attrs | None -> failwithf "impossible_emitMembers_Constructor_ExportDefaultClass(%s)" ma.loc.AsString @@ -665,7 +676,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: binding (fun rename _ -> let_ [] comments (rename "apply") ty value) | Field ({ name = name; value = Func (ft, _typrm, _) }, _) | Method (name, ft, _typrm) -> - let name = Naming.valueName name + let origName = name let ty, attrs = if ma.isStatic then let ty, attr = extFunc ft @@ -674,12 +685,13 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ft = { ft with args = Choice2Of2 PolymorphicThis :: ft.args } let ty, attr = extFunc ft ty, Attr.External.send :: attr - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) | Getter fl | Field (fl, ReadOnly) -> + let origName = fl.name let name = match m with - | Getter _ -> "get" + Naming.upperFirst fl.name |> Naming.valueName - | _ -> fl.name |> Naming.valueName + | Getter _ -> "get" + Naming.upperFirst fl.name + | _ -> fl.name let fl = if fl.value <> Prim Void then fl else @@ -692,7 +704,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: Type.option ty, [Attr.External.val_; Attr.ExternalModifier.return_nullable] else ty, [Attr.External.val_] - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) else let ty, attrs = let args = [Choice2Of2 PolymorphicThis] @@ -701,16 +713,17 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: else fl.value extFunc { isVariadic = false; args = args; returnType = ret; loc = ma.loc } let attrs = Attr.External.get_ :: attrs - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) | Setter fl | Field (fl, WriteOnly) -> + let origName = fl.name if ma.isStatic then ctx.logger.warnf "writable global value or static setter '%s' is not supported in ReScript at %s" fl.name ma.loc.AsString [] else let name = match m with - | Setter _ -> "set" + Naming.upperFirst fl.name |> Naming.valueName - | _ -> fl.name |> Naming.valueName + | Setter _ -> "set" + Naming.upperFirst fl.name + | _ -> fl.name let fl = if fl.value <> Prim Void then fl else @@ -723,7 +736,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ty, attrs = extFunc { isVariadic = false; args = args; returnType = Prim Void; loc = ma.loc } ty, Attr.External.set_ :: attrs - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name) ty name) + binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) | Field (fl, Mutable) -> List.concat [ emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Getter fl) @@ -750,7 +763,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: | SymbolIndexer (symbol, ft, _) -> let c = let ft = func ft - tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol + tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol |> comment binding (fun _ _ -> unknownBinding comments (Some c)) | UnknownMember msgo -> binding (fun _ _ -> unknownBinding comments (msgo |> Option.map str)) @@ -931,7 +944,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let emitType_ ctx ty = emitType overrideFunc ctx ty let members = [ for ma, m in c.members do - yield! emitMembers flags overrideFunc innerCtx PolymorphicThis isExportDefaultClass ma m + yield! emitMembers flags overrideFunc innerCtx selfTy isExportDefaultClass ma m yield! additionalMembers innerCtx flags overrideFunc ] @@ -1036,7 +1049,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c for parent in c.implements do let ty = func { isVariadic = false; args = [Choice2Of2 selfTy]; returnType = parent; loc = UnknownLocation } let parentName = getHumanReadableName innerCtx parent - yield! binding (fun rename _ -> cast [] (rename $"cast_to_{parentName}") ty) + yield! binding (fun rename _ -> cast [] (rename $"as{parentName}") ty) ] let builder = @@ -1161,7 +1174,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu |> List.map (function | None -> EnumType.Heterogeneous | Some (LString _) -> EnumType.String - | Some (LInt _) -> EnumType.Int + | Some (LInt i) -> if i >= 0 then EnumType.Int else EnumType.Float | Some (LFloat _) -> EnumType.Float | Some (LBool _) -> EnumType.Boolean) |> List.distinct @@ -1188,7 +1201,24 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu |> conditional { onIntf = true; onImpl = true; onTypes = false } |> List.singleton else [] - let appendAritySafety x = x :: aritySafety + let appendAritySafety x = [ + yield x |> conditional { EmitCondition.all with onImpl = false } + yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } + yield! aritySafety + ] + + let child (c: EnumCase) = + let ty = + match enumType with + | EnumType.Int | EnumType.String | EnumType.PolyVariant -> + let case = + match c.value with + | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} + | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} + | _ -> failwith "impossible" + Type.polyVariant [case] + | _ -> str "private t" + EnumCaseText {| name = c.name; ty = ty; comments = c.comments |} let parentNode = let items = @@ -1218,54 +1248,31 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu Statement.typeAlias "t" [] (Type.polyVariant cases) |> TypeDefText |> appendAritySafety | EnumType.Boolean -> Statement.typeAlias "t" [] (str "private bool") |> TypeDefText |> appendAritySafety | EnumType.Float | EnumType.Number -> - ctx.logger.warnf "an enum type '%s' contains a case with float value, which is not supported in ReScript at %s" e.name e.loc.AsString + ctx.logger.warnf "an enum type '%s' contains a case with float or negative value, which is not supported in ReScript at %s" e.name e.loc.AsString [ - yield commentStr (sprintf "FIXME: float enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } - yield Statement.typeAlias "t" [] (str "private float") |> TypeDefText + yield commentStr (sprintf "FIXME: float/negative enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } + yield Statement.typeAlias "t" [] (str "private float") |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } + yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } yield! aritySafety ] | _ -> ctx.logger.warnf "a heterogeneous enum '%s' is not supported at %s" e.name e.loc.AsString [ yield commentStr (sprintf "FIXME: heterogeneous enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } - yield Statement.typeAlias "t" [] (str "private any") |> TypeDefText + yield Statement.typeAlias "t" [] (str "private any") |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } + yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } yield! aritySafety ] + let items = items @ List.map child e.cases let comments = e.comments |> emitComments let exports = getExportFromStatement ctx e.name Kind.OfEnum "enum" (Enum e) - {| StructuredTextNode.empty with items = items; comments = comments; exports = Option.toList exports; openTypesModule = false |} + {| StructuredTextNode.empty with items = items; comments = comments; exports = Option.toList exports |} - let childNode (c: EnumCase) = - let typeDef = - match enumType with - | EnumType.Int | EnumType.String | EnumType.PolyVariant -> - let case = - match c.value with - | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} - | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} - | _ -> failwith "impossible" - Statement.typeAlias "t" [] (Type.polyVariant [case]) |> TypeDefText - | _ -> Statement.typeAlias "t" [] (str "private t") |> TypeDefText - let items = [ - yield Statement.typeAlias "parent" [] (str "t") |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } - yield typeDef - yield! aritySafety - yield! // emit a binding to the enum case value - binding (fun rename s -> - ext (scopeToAttr s [Attr.External.val_]) [] (rename "value") (str "parent") c.name - ) - ] - let comments = c.comments |> emitComments - {| StructuredTextNode.empty with items = items; comments = comments; openTypesModule = false |} - - current - |> add [e.name] parentNode - |> inTrie [e.name] (fun m -> - e.cases |> List.fold (fun state c -> state |> add [c.name] (childNode c)) m) + current |> add [e.name] parentNode let private createExternalForValue (ctx: Context) (rename: string -> string) (s: CurrentScope) attr comments name ty = let fallback () = - ext (scopeToAttr s attr) comments (Naming.valueName name |> rename) ty name + ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty name let jsModule () = match s.jsModule with | None -> failwith "impossible_createExternalForValue" @@ -1273,11 +1280,11 @@ let private createExternalForValue (ctx: Context) (rename: string -> string) (s: match ctx |> Context.getExportTypeOfName [name] with | None | Some (ExportType.Child _) | Some (ExportType.ES6 None) -> fallback () | Some ExportType.CommonJS -> - ext (Attr.External.module_ None :: attr) comments (Naming.valueName name |> rename) ty (jsModule ()) + ext (Attr.External.module_ None :: attr) comments (rename name |> Naming.valueName) ty (jsModule ()) | Some ExportType.ES6Default -> - ext (scopeToAttr s attr) comments (Naming.valueName name |> rename) ty "default" + ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty "default" | Some (ExportType.ES6 (Some renameAs)) -> - ext (scopeToAttr s attr) comments (Naming.valueName name |> rename) ty renameAs + ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty renameAs let emitVariable flags overrideFunc ctx (v: Variable) = let emitType = emitTypeImpl flags @@ -1409,7 +1416,10 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | self :: sr -> let attrs = scopeToAttr { s with scopeRev = sr } attrs self, attrs - | [] -> failwithf "impossible_intfToStmts_Newable(%s)" ma.loc.AsString + | [] -> + match s.jsModule with + | Some m -> m, Attr.External.module_ None :: attrs + | None -> failwithf "impossible_intfToStmts_Newable(%s)" ma.loc.AsString let attrs = Attr.External.new_ :: attrs |> List.rev ext attrs comments (rename "make") ty target ) @@ -1421,9 +1431,12 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured match s.scopeRev with | self :: sr -> let attrs = scopeToAttr { s with scopeRev = sr } attrs - self, attrs - | [] -> failwithf "impossible_intfToStmts_Callable(%s)" ma.loc.AsString - let attrs = Attr.External.val_ :: attrs |> List.rev + self, Attr.External.val_ :: attrs + | [] -> + match s.jsModule with + | Some m -> m, Attr.External.module_ None :: attrs + | None -> failwithf "impossible_intfToStmts_Callable(%s)" ma.loc.AsString + let attrs = attrs |> List.rev ext attrs comments (rename "apply") ty target ) | Constructor _ -> failwith "impossible_emitStructuredDefinition_Pattern_intfToModule_Constructor" // because interface! @@ -1477,7 +1490,11 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | TypeAlias ta -> let ctx = ctx |> Context.ofChildNamespace ta.name let items = - emitTypeAliases emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target) + emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target) (fun x -> + let a = Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target |> TypeDefText + if x.isOverload then a |> conditional { onTypes = false; onIntf = true; onImpl = true } |> List.singleton + else a |> List.singleton + ) let typeReferences = getKnownTypes ctx ta.target let node = {| StructuredTextNode.empty with items = items; typeReferences = typeReferences; comments = comments |} current @@ -1640,7 +1657,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) match ctx |> Context.getExportTypeOfName [name] with | None | Some (ExportType.Child _) -> name :: flags.scopeRev - | Some ExportType.CommonJS + | Some ExportType.CommonJS -> [] | Some (ExportType.ES6 None) -> [name] | Some ExportType.ES6Default -> ["default"] | Some (ExportType.ES6 (Some name)) -> [name] @@ -1664,20 +1681,38 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) let items = let currentScope : CurrentScope = !!flags + + let emitEnumCase (e: {| name: string; ty: text; comments: Comment list |}) = + let moduleName = Naming.moduleName e.name + let types = + tprintf "module %s : " moduleName +@ "{ type t = " + e.ty +@ " }" + let attrs = scopeToAttr currentScope [Attr.External.val_] + let content = [ + Statement.open_ moduleName + str "type t = t"; str "type t0 = t" + Statement.external attrs "value" (str "t") e.name + ] + let m = {| name = moduleName; origName = e.name; content = content; comments = emitComments e.comments |} + {| types = types; intf = Statement.moduleSig m; impl = Statement.moduleVal m |} + let rec f = function | Conditional (i, c) -> c, snd (f i) - | ImportText t -> { EmitCondition.all with onTypes = false }, Choice1Of4 t - | TypeDefText t -> EmitCondition.all, Choice2Of4 t - | Binding b -> { EmitCondition.all with onTypes = false }, Choice3Of4 (b renamer currentScope) - | Comment c -> { EmitCondition.all with onTypes = false }, Choice4Of4 c + | ImportText t -> { EmitCondition.all with onTypes = false }, Choice1Of5 t + | TypeDefText t -> EmitCondition.all, Choice2Of5 t + | Binding b -> { EmitCondition.all with onTypes = false }, Choice3Of5 (b renamer currentScope) + | EnumCaseText e -> EmitCondition.all, Choice4Of5 (emitEnumCase e) + | Comment c -> { EmitCondition.all with onTypes = false }, Choice5Of5 c match st.value with None -> [] | Some v -> v.items |> List.map f let imports = - items |> List.choose (function (_, Choice1Of4 t) -> Some t | _ -> None) + items |> List.choose (function (_, Choice1Of5 t) -> Some t | _ -> None) let types = let items = - items |> List.choose (function (c, Choice2Of4 t) when c.onTypes -> Some t | _ -> None) + items |> List.choose (function + | c, Choice2Of5 t when c.onTypes -> Some t + | _, Choice4Of5 e -> Some e.types + | _ -> None) let children = children |> List.filter (fun (_, _, c) -> c.types |> List.isEmpty |> not) @@ -1693,24 +1728,23 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) let children = children |> List.filter (fun (_, _, c) -> c.intf |> List.isEmpty |> not) - |> List.map (fun (k, openTypesModule, c) -> - let content = - if openTypesModule then - tprintf "open %s" k.name :: c.imports @ c.intf - else - c.imports @ c.intf + |> List.map (fun (k, _, c) -> + let content = c.imports @ c.intf {| k with content = content; comments = c.comments |}) - |> ModuleEmitter.signature ctx st + |> Statement.moduleSigRec let typeDefs = - items |> List.choose (function (c, Choice2Of4 t) when c.onIntf -> Some t | _ -> None) + items |> List.choose (function + | c, Choice2Of5 t when c.onIntf -> Some t + | _, Choice4Of5 e -> Some e.intf + | _ -> None) [ yield! children yield! typeDefs for cond, item in items do if cond.onIntf then match item with - | Choice3Of4 b -> yield! Binding.emitForInterface b - | Choice4Of4 c -> yield c + | Choice3Of5 b -> yield! Binding.emitForInterface b + | Choice5Of5 c -> yield c | _ -> () yield! exports ] @@ -1722,21 +1756,24 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) |> List.map (fun (k, openTypesModule, c) -> let content = if openTypesModule then - tprintf "open %s" k.name :: c.imports @ c.intf + Statement.open_ k.name :: c.imports @ c.impl else - c.imports @ c.intf + c.imports @ c.impl {| k with content = content; comments = c.comments |}) - |> ModuleEmitter.signature ctx st + |> ModuleEmitter.structure ctx st let typeDefs = - items |> List.choose (function (c, Choice2Of4 t) when c.onImpl -> Some t | _ -> None) + items |> List.choose (function + | c, Choice2Of5 t when c.onImpl -> Some t + | _, Choice4Of5 e -> Some e.impl + | _ -> None) [ yield! children yield! typeDefs for cond, item in items do if cond.onImpl then match item with - | Choice3Of4 b -> yield! Binding.emitForImplementation b - | Choice4Of4 c -> yield c + | Choice3Of5 b -> yield! Binding.emitForImplementation b + | Choice5Of5 c -> yield c | _ -> () yield! exports ] @@ -1856,7 +1893,7 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: x JsHelper.deriveModuleName info (sources |> List.map (fun s -> s.fileName)) |> JsHelper.InferenceResult.tryUnwrap - |> Option.map log + |> Option.map (Naming.jsModuleNameToReScriptName >> log) |> Option.defaultWith (fun () -> ctx.logger.warnf "* the output file name cannot be inferred. 'output.res' is used instead." "output") diff --git a/test/res/.gitignore b/test/res/.gitignore index 3deb57a7..a22d5752 100644 --- a/test/res/.gitignore +++ b/test/res/.gitignore @@ -3,3 +3,4 @@ /lib/ .bsb.lock .merlin +/src/generated From 8bcbd32f27c3631639e194039bc98996b0fd6cfd Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 9 Mar 2022 19:32:40 +0900 Subject: [PATCH 18/56] [WIP] try to generate compilable stdlib (2) --- src/Targets/ReScript/ReScriptHelper.fs | 2 +- src/Targets/ReScript/Writer.fs | 28 ++++++++++++++++---------- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 0e589b08..fac3fee1 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -107,7 +107,7 @@ module Naming = let keywords = set [ - "and"; "as"; "assert"; "constraint"; "else"; "exception"; "external" + "and"; "as"; "assert"; "constraint"; "else"; "exception"; "external"; "export" "false"; "for"; "if"; "in"; "include"; "lazy"; "let"; "module"; "mutable" "of"; "open"; "private"; "rec"; "switch"; "true"; "try"; "type"; "when"; "while"; "with" ] diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 8a945faf..73ce1ef5 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -222,7 +222,9 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C match l with | LBool true -> Type.true_ | LBool false -> Type.false_ | LString s -> Type.polyVariant [{| name = Choice1Of2 s; value = None; attr = None |}] - | LInt i -> Type.polyVariant [{| name = Choice2Of2 i; value = None; attr = None |}] + | LInt i -> + if i >= 0 then Type.polyVariant [{| name = Choice2Of2 i; value = None; attr = None |}] + else fixme (str "int") "%d" i | LFloat f -> fixme (str "float") "float literal %f" f | Intersection i -> let flags = { flags with needParen = true } |> EmitTypeFlags.ofChild @@ -312,7 +314,7 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte | _ when f.isVariadic -> variadicFallback () | External.Root (_, _) -> Type.curriedArrow (args ()) (retTy flags) | External.Argument _ -> paren ("@uncurry " @+ Type.curriedArrow (args ()) (retTy flags)) - | _ -> Type.uncurriedArrow (args ()) (retTy flags) |> paren + | _ -> Type.curriedArrow (args ()) (retTy flags) |> paren and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (u: UnionType) : text = // TODO: more classification @@ -648,6 +650,9 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let args = str self :: (args |> List.map (fun arg -> arg.ml)) Term.curriedArrow args (Term.raw body) + let scopeToAttrIf isStatic s attrs = + if isStatic then scopeToAttr s attrs else attrs + match m with | Constructor ft -> let ty, attrs = extFunc { args = ft.args; isVariadic = ft.isVariadic; returnType = selfTy; loc = ft.loc } @@ -685,7 +690,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ft = { ft with args = Choice2Of2 PolymorphicThis :: ft.args } let ty, attr = extFunc ft ty, Attr.External.send :: attr - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) + binding (fun rename s -> ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) | Getter fl | Field (fl, ReadOnly) -> let origName = fl.name let name = @@ -713,7 +718,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: else fl.value extFunc { isVariadic = false; args = args; returnType = ret; loc = ma.loc } let attrs = Attr.External.get_ :: attrs - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) + binding (fun rename _ -> ext attrs comments (rename name |> Naming.valueName) ty origName) | Setter fl | Field (fl, WriteOnly) -> let origName = fl.name if ma.isStatic then @@ -736,7 +741,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ty, attrs = extFunc { isVariadic = false; args = args; returnType = Prim Void; loc = ma.loc } ty, Attr.External.set_ :: attrs - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) + binding (fun rename s -> ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) | Field (fl, Mutable) -> List.concat [ emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Getter fl) @@ -747,14 +752,14 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let args = Choice2Of2 PolymorphicThis :: removeLabels ft.args extFunc { ft with args = args } let attrs = Attr.External.get_index :: attrs - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename "get") ty "") + binding (fun rename _ -> ext attrs comments (rename "get") ty "") | Indexer (ft, WriteOnly) -> let ty, attrs = let args = Choice2Of2 PolymorphicThis :: removeLabels ft.args @ [Choice2Of2 ft.returnType] let ret = Prim Void extFunc { ft with args = args; returnType = ret } let attrs = Attr.External.set_index :: attrs - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename "set") ty "") + binding (fun rename _ -> ext attrs comments (rename "set") ty "") | Indexer (ft, Mutable) -> List.concat [ emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Indexer (ft, ReadOnly)) @@ -1047,7 +1052,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c if innerCtx.options.subtyping |> List.contains Subtyping.CastFunction then let inline func ft = func flags overrideFunc innerCtx ft for parent in c.implements do - let ty = func { isVariadic = false; args = [Choice2Of2 selfTy]; returnType = parent; loc = UnknownLocation } + let ty = Type.curriedArrow [selfTyText] (emitType_ innerCtx parent) let parentName = getHumanReadableName innerCtx parent yield! binding (fun rename _ -> cast [] (rename $"as{parentName}") ty) ] @@ -1517,7 +1522,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] let createModule () = let items = intfToStmts intf (ctx |> Context.ofChildNamespace value.name) emitTypeFlags overrideFunc - {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name |} + {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name; openTypesModule = false |} if knownTypesInMembers |> Set.contains (KnownType.Ident (ctx |> Context.getFullName [intfName])) then fallback current else @@ -1554,7 +1559,8 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured (set {| StructuredTextNode.empty with items = items - scope = Scope.Path value.name |}) + scope = Scope.Path value.name + openTypesModule = false |}) |> addExport value.name Kind.OfClass (if value.isConst then "const" else "let") |> inTrie [value.name] (addAnonymousInterfaceExcluding [intf]) | Ident (i & { loc = loc }) & Dummy tyargs @@ -1570,7 +1576,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] let createModule () = let items = intfToStmts intf ctx emitTypeFlags overrideFunc - {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name |} + {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name; openTypesModule = false |} current |> inTrie [name] (set (createModule ())) |> addExport name Kind.OfClass (if value.isConst then "const" else "let") From e397f45bc4714ea5d7e011060fb28e7f9789a1b2 Mon Sep 17 00:00:00 2001 From: cannorin Date: Fri, 18 Mar 2022 16:44:59 +0900 Subject: [PATCH 19/56] Make typescript.res/resi compilable --- build/build.fs | 3 +- dist_rescript/src/Ts__min.res | 1 - src/Targets/ReScript/ReScriptHelper.fs | 18 +-- src/Targets/ReScript/Writer.fs | 172 +++++++++++++++---------- 4 files changed, 116 insertions(+), 78 deletions(-) diff --git a/build/build.fs b/build/build.fs index 22cd6a0d..4674f426 100644 --- a/build/build.fs +++ b/build/build.fs @@ -153,7 +153,7 @@ module Test = let clean () = !! $"{outputDir}/*" - ++ $"{srcGeneratedDir}/*.res" + ++ $"{srcGeneratedDir}/generated/*.res" ++ $"{srcGeneratedDir}/generated/*.resi" |> Seq.iter Shell.rm @@ -191,6 +191,7 @@ module Test = package let build () = + Shell.mkdir srcGeneratedDir for file in outputDir |> Shell.copyRecursiveTo true srcGeneratedDir do printfn "* copied to %s" file // inDirectory testDir <| fun () -> dune "build" diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/Ts__min.res index 2ef4730c..d54efb32 100644 --- a/dist_rescript/src/Ts__min.res +++ b/dist_rescript/src/Ts__min.res @@ -35,7 +35,6 @@ type intrinsic<'a> = private 'a type null<+'a> = Js.null<'a> type null' = null type undefined<+'a> = Js.undefined<'a> -type undefined' = undefined type nullable<+'a> = Js.nullable<'a> module Union = { diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index fac3fee1..34232770 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -192,14 +192,14 @@ module Kind = module Type = /// non-primitive types defined in the standard library let predefinedTypes = - let typedArray name = name, sprintf "Js.TypedArray2.%s.t" name + let typedArray name = name, (sprintf "Js.TypedArray2.%s.t" name, 0) Map.ofList [ - "RegExp", "Js.Re.t" - "Date", "Js.Date.t" - "Promise", "Js.Promise.t" (* arity 1 *) - "Array", "Js.Array.t" (* arity 1*) - "ArrayLike", "Js.TypedArray2.array_like" (* arity 1 *) - "ArrayBuffer", "Js.TypedArray2.array_buffer" + "RegExp", ("Js.Re.t", 0) + "Date", ("Js.Date.t", 0) + "Promise", ("Js.Promise.t", 1) + "Array", ("Js.Array.t", 1) + "ArrayLike", ("Js.TypedArray2.array_like", 1) + "ArrayBuffer", ("Js.TypedArray2.array_buffer", 0) typedArray "DataView" typedArray "Int8Array" typedArray "Uint8Array" @@ -314,7 +314,7 @@ module Type = let undefined_or t = app (str "undefined") [t] let null_or_undefined_or t = app (str "nullable") [t] let null_ = str "null'" - let undefined = str "undefined'" + let undefined = str "unit" let intrinsic = app (str "intrinsic") [string] let true_ = str "\\\"true\"" let false_ = str "\\\"false\"" @@ -466,7 +466,7 @@ module Statement = let moduleSigRec1 name (content: text list) = concat newline [ - yield tprintf "module %s : {" name + yield tprintf "module rec %s : {" name yield indent (concat newline content) yield tprintf "} = %s" name ] \ No newline at end of file diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 73ce1ef5..b8b74fa2 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -136,58 +136,77 @@ let anonymousInterfaceToIdentifier (ctx: Context) (a: AnonymousInterface) : text | None -> failwithf "impossible_anonymousInterfaceToIdentifier(%s)" a.loc.AsString let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (ty: Type) : text = - let treatIdent (i: Ident) (tyargs: Type list) (loc: Location) = - let arity = List.length tyargs + let treatBuiltinTypes (i: Ident) (tyargs: Type list) = + let len = List.length tyargs let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.ofChild - let withTyargs ty = - Type.appOpt ty (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) - let origin = - Ident.pickDefinitionWithFullName ctx i (fun fn -> function - | _ when fn.source <> ctx.currentSourceFile -> None - | Definition.Class { typeParams = tps; loc = loc } - | Definition.TypeAlias { typeParams = tps; loc = loc } -> Some (fn, tps, loc) - | Definition.Enum { loc = loc } - | Definition.EnumCase ({ loc = loc }, _) -> Some (fn, [], loc) - | _ -> None - ) - match origin with + match i.name with + | _ when ctx.options.stdlib -> None + | [] | _ :: _ :: _ -> None + | name :: [] -> + match Type.predefinedTypes |> Map.tryFind name with + | Some (ty, arity) when arity = len -> + Type.appOpt (str ty) (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) |> Some + | _ when len = 0 -> + match Type.predefinedDOMTypes.TryGetValue(name) with + | true, ty -> str ty |> Some + | false, _ -> None + | _ -> None + + let treatIdent (i: Ident) (tyargs: Type list) (loc: Location) = + match treatBuiltinTypes i tyargs with + | Some t -> t | None -> - let tyName = - let fallback () = - let tyName = - match ctx.options.safeArity with - | FeatureFlag.Full | FeatureFlag.Consume -> Naming.createTypeNameOfArity arity None "t" - | _ -> "t" - Naming.structured Naming.moduleName i.name + "." + tyName |> str - match i.name with - | [name] -> - match PrimType.FromJSClassName name with - | Some p -> emitTypeImpl flags overrideFunc ctx (Prim p) - | None -> fallback () - | _ -> fallback () - tyName |> withTyargs - | Some (fn, typrms, origLoc) -> - let result name = - let ts = - assignTypeParams fn.name (origLoc ++ loc) typrms tyargs - (fun _ t -> t) - (fun tv -> - match tv.defaultType with - | Some t -> t - | None -> failwithf "error: insufficient type params for type '%s' at %s" (String.concat "." fn.name) loc.AsString) - Type.appOpt (str name) (ts |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) - let fullName = Naming.structured Naming.moduleName fn.name + ".t" - if fn.source <> ctx.currentSourceFile then result fullName - else - match ctx |> Context.getRelativeNameTo fn.name with - | Ok relativeName -> result (Naming.structured Naming.moduleName relativeName + ".t") - | Error [] -> result "t" - | Error diff -> - let fn = String.concat "." fn.name - let selfName = String.concat "." diff - let warnText = $"cannot reference a type {fn} from its sub-namespace {selfName}" - Log.warnf ctx.options "%s at %s" warnText loc.AsString - commentStr warnText + Type.any + let arity = List.length tyargs + let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.ofChild + let withTyargs ty = + Type.appOpt ty (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) + let origin = + Ident.pickDefinitionWithFullName ctx i (fun fn -> function + | _ when fn.source <> ctx.currentSourceFile -> None + | Definition.Class { typeParams = tps; loc = loc } + | Definition.TypeAlias { typeParams = tps; loc = loc } -> Some (fn, tps, loc) + | Definition.Enum { loc = loc } + | Definition.EnumCase ({ loc = loc }, _) -> Some (fn, [], loc) + | _ -> None + ) + match origin with + | None -> + let tyName = + let fallback () = + let tyName = + match ctx.options.safeArity with + | FeatureFlag.Full | FeatureFlag.Consume -> Naming.createTypeNameOfArity arity None "t" + | _ -> "t" + Naming.structured Naming.moduleName i.name + "." + tyName |> str + match i.name with + | [name] -> + match PrimType.FromJSClassName name with + | Some p -> emitTypeImpl flags overrideFunc ctx (Prim p) + | None -> fallback () + | _ -> fallback () + tyName |> withTyargs + | Some (fn, typrms, origLoc) -> + let result name = + let ts = + assignTypeParams fn.name (origLoc ++ loc) typrms tyargs + (fun _ t -> t) + (fun tv -> + match tv.defaultType with + | Some t -> t + | None -> failwithf "error: insufficient type params for type '%s' at %s" (String.concat "." fn.name) loc.AsString) + Type.appOpt (str name) (ts |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) + let fullName = Naming.structured Naming.moduleName fn.name + ".t" + if fn.source <> ctx.currentSourceFile then result fullName + else + match ctx |> Context.getRelativeNameTo fn.name with + | Ok relativeName -> result (Naming.structured Naming.moduleName relativeName + ".t") + | Error [] -> result "t" + | Error diff -> + let fn = String.concat "." fn.name + let selfName = String.concat "." diff + let warnText = $"cannot reference a type {fn} from its sub-namespace {selfName}" + Log.warnf ctx.options "%s at %s" warnText loc.AsString + commentStr warnText + Type.any match overrideFunc flags (emitTypeImpl flags overrideFunc) ctx ty with | Some t -> t @@ -993,7 +1012,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c if not innerCtx.options.stdlib then fallback () else if innerCtx.currentSourceFile = stdlibEsSrc then match Type.predefinedTypes |> Map.tryFind x.name with - | Some t -> Some (str t), [] + | Some (t, _) -> Some (str t), [] | None -> fallback () else if innerCtx.currentSourceFile = stdlibDomSrc then match Type.predefinedDOMTypes.TryGetValue(x.name) with @@ -1234,14 +1253,18 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu |> List.map (fun (n, v) -> n, match v with Some (LInt i) -> i | _ -> failwith "impossible") |> List.sortBy snd |> List.map fst - if (cases |> List.sumBy (fun s -> s.Length)) > 80 then - concat newline [ - yield str "type t =" - for case in cases do - yield indent (tprintf "| %s" case) - ] |> TypeDefText |> appendAritySafety - else - cases |> String.concat " | " |> tprintf "type t = %s" |> TypeDefText |> appendAritySafety + let casesText = + if (cases |> List.sumBy (fun s -> s.Length)) > 80 then + concat newline [ + for case in cases do + yield indent (tprintf "| %s" case) + ] + else cases |> String.concat " | " |> str + [ + yield str "type t = " + casesText |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } + yield str "type t = t = " + casesText |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } + yield! aritySafety + ] | EnumType.Int | EnumType.String | EnumType.PolyVariant -> let cases = distinctCases @@ -1680,9 +1703,10 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) let ctx = ctx |> Context.ofChildNamespace k let result = emitModule flags ctx v let openTypesModule = + let hasTypeDefinitions = result.types |> List.isEmpty |> not v.value - |> Option.map (fun v -> v.openTypesModule) - |> Option.defaultValue (result.types |> List.isEmpty |> not) + |> Option.map (fun v -> hasTypeDefinitions && v.openTypesModule) + |> Option.defaultValue hasTypeDefinitions {| name = name; origName = k |}, openTypesModule, result) let items = @@ -1693,13 +1717,19 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) let types = tprintf "module %s : " moduleName +@ "{ type t = " + e.ty +@ " }" let attrs = scopeToAttr currentScope [Attr.External.val_] - let content = [ - Statement.open_ moduleName - str "type t = t"; str "type t0 = t" - Statement.external attrs "value" (str "t") e.name + let intf = [ + yield str $"type t = {e.ty}" + if ctx.options.safeArity.HasProvide then yield str "type t0 = t" + yield Statement.external attrs "value" (str "t") e.name ] - let m = {| name = moduleName; origName = e.name; content = content; comments = emitComments e.comments |} - {| types = types; intf = Statement.moduleSig m; impl = Statement.moduleVal m |} + let impl = [ + yield Statement.open_ moduleName + yield str "type t = t" + if ctx.options.safeArity.HasProvide then yield str "type t0 = t" + yield Statement.external attrs "value" (str "t") e.name + ] + let m content = {| name = moduleName; origName = e.name; content = content; comments = emitComments e.comments |} + {| types = types; intf = Statement.moduleSig (m intf); impl = Statement.moduleVal (m impl) |} let rec f = function | Conditional (i, c) -> c, snd (f i) @@ -1789,6 +1819,10 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} +let header = [ + str "@@warning(\"-27-33-44\")" +] + let setTyperOptions (ctx: IContext) = ctx.options.inheritArraylike <- true ctx.options.inheritIterable <- true @@ -1859,6 +1893,7 @@ let emitStdlib (input: Input) (ctx: IContext) : Output list = let m = emitModule flags ctx st let res = concat newline [ + yield! header yield! m.comments for o in opens do yield Statement.open_ o yield! m.imports @@ -1867,6 +1902,7 @@ let emitStdlib (input: Input) (ctx: IContext) : Output list = ] let resi = concat newline [ + yield! header yield! m.comments for o in opens do yield Statement.open_ o yield! m.imports @@ -1947,6 +1983,7 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: let res = concat newline [ + yield! header yield! m.comments yield! opens yield! m.imports @@ -1956,6 +1993,7 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: let resi = if ctx.options.resi then concat newline [ + yield! header yield! m.comments yield! opens yield! m.imports From fc203b1a8465fcf80c99eff4912ad19c3a164c73 Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 23 Mar 2022 18:30:28 +0900 Subject: [PATCH 20/56] Make stdlib compilable --- src/Targets/ReScript/ReScriptHelper.fs | 14 +- src/Targets/ReScript/Writer.fs | 399 +++++++++++++++---------- 2 files changed, 245 insertions(+), 168 deletions(-) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 34232770..d92b2831 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -431,10 +431,18 @@ module Statement = attr attrs + tprintf "let %s: " name + typ let external (attrs: text list) name (typ: text) target = - attr attrs + tprintf "external %s: " name + typ + tprintf " = \"%s\"" target - - let typeAlias name tyargs ty = + let result = + attr attrs + tprintf "external %s: " name + typ + tprintf " = \"%s\"" target + if not (Naming.isValidJSIdentifier target) && + [Attr.External.new_; Attr.External.val_] |> List.exists (fun attr -> attrs |> List.contains attr) then + comment result // ReScript doesn't allow exotic names except for get, set, and send. + else if attrs |> List.contains Attr.External.new_ && attrs |> List.contains Attr.ExternalModifier.variadic then + comment result // TODO: remove this once the PR is merged + else result + + let typeAlias isRec name tyargs ty = str "type " + + (if isRec then str "rec " else empty) + (if List.isEmpty tyargs then str name else Type.app (str name) tyargs) +@ " = " + ty diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index b8b74fa2..ae6b46c6 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -17,6 +17,12 @@ let [] stdlibEsSrc = "lib.es.d.ts" let [] stdlibDomSrc = "lib.dom.d.ts" let [] stdlibWebworkerSrc = "lib.webworker.d.ts" +let impossible fmt = + Printf.ksprintf (fun msg -> failwith ("impossible_" + msg)) fmt + +let impossibleNone msgf (x: 'a option) = + match x with None -> failwith ("impossible_" + msgf ()) | Some x -> x + type ScriptTarget = TypeScript.Ts.ScriptTarget type State = {| @@ -41,8 +47,8 @@ type Variance = Covariant | Contravariant | Invariant with | Invariant -> Invariant type Label = - | Case of text - | TagType of text + | Case of text * text list + | TagType of text * text list type [] External = | Root of variadic:bool * nullable:bool @@ -70,7 +76,7 @@ module EmitTypeFlags = avoidTheseArgumentNames = Set.empty } - let ofChild flags = + let noExternal flags = { flags with external = External.None } let ofFuncArg isVariadic flags = { flags with @@ -105,7 +111,12 @@ let classifyExternalFunction flags (f: FuncType) = u.hasNull || u.hasUndefined | _ -> false let flags = { flags with external = External.Root(isVariadic, isNullable) } - {| flags = flags; isVariadic = isVariadic; isNullable = isNullable |} + let needsWorkaround = f.isVariadic && not isVariadic + {| flags = flags; isVariadic = isVariadic; isNullable = isNullable; needsWorkaround = needsWorkaround |} + +let functionNeedsWorkaround (ft: FuncType) = + let c = classifyExternalFunction EmitTypeFlags.defaultValue ft + c.needsWorkaround type TypeEmitter = Context -> Type -> text @@ -131,33 +142,39 @@ let anonymousInterfaceModuleName (ctx: Context) (info: AnonymousInterfaceInfo) = sprintf "AnonymousInterface%d" info.id let anonymousInterfaceToIdentifier (ctx: Context) (a: AnonymousInterface) : text = - match ctx |> Context.bindCurrentSourceInfo (fun i -> i.anonymousInterfacesMap |> Map.tryFind a) with - | Some i -> tprintf "%s.t" (anonymousInterfaceModuleName ctx i) - | None -> failwithf "impossible_anonymousInterfaceToIdentifier(%s)" a.loc.AsString + let i = + ctx + |> Context.bindCurrentSourceInfo (fun i -> i.anonymousInterfacesMap |> Map.tryFind a) + |> impossibleNone (fun () -> sprintf "anonymousInterfaceToIdentifier(%s)" a.loc.AsString) + tprintf "%s.t" (anonymousInterfaceModuleName ctx i) let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (ty: Type) : text = let treatBuiltinTypes (i: Ident) (tyargs: Type list) = - let len = List.length tyargs - let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.ofChild - match i.name with - | _ when ctx.options.stdlib -> None - | [] | _ :: _ :: _ -> None - | name :: [] -> - match Type.predefinedTypes |> Map.tryFind name with - | Some (ty, arity) when arity = len -> - Type.appOpt (str ty) (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) |> Some - | _ when len = 0 -> - match Type.predefinedDOMTypes.TryGetValue(name) with - | true, ty -> str ty |> Some - | false, _ -> None - | _ -> None + if i.fullName |> List.exists (fun fn -> fn.source.Contains("node_modules/typescript/lib/lib.")) then + let len = List.length tyargs + let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.noExternal + match i.name with + | _ when ctx.options.stdlib -> None + | [] | _ :: _ :: _ -> None + | name :: [] -> + match Type.predefinedTypes |> Map.tryFind name with + | Some (ty, arity) when arity = len -> + Type.appOpt (str ty) (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) |> Some + (* // This is not really useful. rescript-webapi uses `Webapi.Dom.ClassName.t` format anyway + | _ when len = 0 -> + match Type.predefinedDOMTypes.TryGetValue(name) with + | true, ty -> str ty |> Some + | false, _ -> None + *) + | _ -> None + else None let treatIdent (i: Ident) (tyargs: Type list) (loc: Location) = match treatBuiltinTypes i tyargs with | Some t -> t | None -> let arity = List.length tyargs - let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.ofChild + let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.noExternal let withTyargs ty = Type.appOpt ty (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) let origin = @@ -193,7 +210,7 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C (fun tv -> match tv.defaultType with | Some t -> t - | None -> failwithf "error: insufficient type params for type '%s' at %s" (String.concat "." fn.name) loc.AsString) + | None -> ctx.logger.errorf "error: insufficient type params for type '%s' at %s" (String.concat "." fn.name) loc.AsString) Type.appOpt (str name) (ts |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) let fullName = Naming.structured Naming.moduleName fn.name + ".t" if fn.source <> ctx.currentSourceFile then result fullName @@ -219,7 +236,7 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C | _ when flags.external = External.Argument true -> commentStr (sprintf "FIXME: type '%s' cannot be used for variadic argument" (Type.pp ty)) + Type.app Type.array [Type.any] | App (t, ts, loc) -> - let flags = flags |> EmitTypeFlags.ofChild + let flags = flags |> EmitTypeFlags.noExternal let emit t ts = Type.appOpt (emitTypeImpl flags overrideFunc ctx t) (List.map (emitTypeImpl { flags with needParen = true } overrideFunc ctx) ts) match t with @@ -246,7 +263,7 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C else fixme (str "int") "%d" i | LFloat f -> fixme (str "float") "float literal %f" f | Intersection i -> - let flags = { flags with needParen = true } |> EmitTypeFlags.ofChild + let flags = { flags with needParen = true } |> EmitTypeFlags.noExternal Type.intersection (i.types |> List.distinct |> List.map (emitTypeImpl flags overrideFunc ctx)) | Union u -> emitUnion flags overrideFunc ctx u | AnonymousInterface a -> anonymousInterfaceToIdentifier ctx a @@ -256,12 +273,12 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C match ts.types with | [] -> Type.void_ | [t] -> emitTypeImpl flags overrideFunc ctx t.value - | ts -> Type.tuple (ts |> List.map (fun x -> emitTypeImpl (flags |> EmitTypeFlags.ofChild) overrideFunc ctx x.value)) + | ts -> Type.tuple (ts |> List.map (fun x -> emitTypeImpl (flags |> EmitTypeFlags.noExternal) overrideFunc ctx x.value)) | Func (f, [], _) -> emitFuncType flags overrideFunc ctx false f | NewableFunc (f, [], _) -> emitFuncType flags overrideFunc ctx true f - | Erased (_, loc, origText) -> failwithf "impossible_emitTypeImpl_erased: %s (%s)" loc.AsString origText - | Func (_, _ :: _, loc) -> failwithf "impossible_emitTypeImpl_Func_poly: %s (%s)" loc.AsString (Type.pp ty) - | NewableFunc (_, _, loc) -> failwithf "impossible_emitTypeImpl_NewableFunc_poly: %s (%s)" loc.AsString (Type.pp ty) + | Erased (_, loc, origText) -> impossible "emitTypeImpl_erased: %s (%s)" loc.AsString origText + | Func (_, _ :: _, loc) -> impossible "emitTypeImpl_Func_poly: %s (%s)" loc.AsString (Type.pp ty) + | NewableFunc (_, _, loc) -> impossible "emitTypeImpl_NewableFunc_poly: %s (%s)" loc.AsString (Type.pp ty) | UnknownType msgo -> match msgo with | None -> fixme Type.any "unknown type" @@ -278,9 +295,9 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte else x let variadicFallback () = assert f.isVariadic - let retTy = retTy (EmitTypeFlags.ofChild flags) + let retTy = retTy (EmitTypeFlags.noExternal flags) let args = - let flags = { flags with needParen = true } |> EmitTypeFlags.ofChild + let flags = { flags with needParen = true } |> EmitTypeFlags.noExternal f.args |> List.map (function | Choice1Of2 x -> let t = emitTypeImpl flags overrideFunc ctx x.value @@ -289,13 +306,13 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte let args, variadic = match List.rev args with | v :: rest -> List.rev rest, v - | [] -> failwith "impossible_emitFuncType_empty_variadic_function" + | [] -> impossible "emitFuncType_empty_variadic_function" if isNewable then Type.newableVariadic args variadic retTy |> paren else Type.variadic args variadic retTy |> paren let newableFallback () = - let retTy = retTy (EmitTypeFlags.ofChild flags) + let retTy = retTy (EmitTypeFlags.noExternal flags) let args = - let flags = { flags with needParen = true } |> EmitTypeFlags.ofChild + let flags = { flags with needParen = true } |> EmitTypeFlags.noExternal f.args |> List.map (function | Choice1Of2 x -> let t = emitTypeImpl flags overrideFunc ctx x.value @@ -339,7 +356,7 @@ and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) // TODO: more classification let u = ResolvedUnion.checkNullOrUndefined u let rest = - let rest = u.rest |> List.map (emitTypeImpl (EmitTypeFlags.ofChild flags) overrideFunc ctx) + let rest = u.rest |> List.map (emitTypeImpl (EmitTypeFlags.noExternal flags) overrideFunc ctx) if List.isEmpty rest then Type.never else Type.union rest match u.hasNull, u.hasUndefined with @@ -360,26 +377,27 @@ and emitLabelsBody (ctx: Context) labels = else empty let rec go firstCaseEmitted acc = function | [] -> acc - | Case c :: rest -> + | Case (c, args) :: rest -> + let text = + match args with + | [] -> "#" @+ c + | _ -> "#" @+ c + between "(" ")" (concat (str ", ") args) if firstCaseEmitted then - go firstCaseEmitted (acc + str " | " + c) rest + go firstCaseEmitted (acc + str " | " + text) rest else - go true (acc + c) rest - | TagType t :: rest -> + go true (acc + text) rest + | TagType (t, args) :: rest -> + let text = Type.appOpt t args if firstCaseEmitted then - go firstCaseEmitted (acc + tag (" | " @+ t)) rest + go firstCaseEmitted (acc + tag (" | " @+ text)) rest else - go ctx.options.inheritWithTags.HasConsume (acc + tag t) rest + go ctx.options.inheritWithTags.HasConsume (acc + tag text) rest go false empty labels and getLabelsFromInheritingTypes (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (inheritingTypes: Set) = let emitType_ = emitTypeImpl flags overrideFunc - let emitCase name args = - match args with - | [] -> str (Naming.constructorName name) - | [arg] -> tprintf "%s(" (Naming.constructorName name) + arg +@ ")" - | _ -> Naming.constructorName name @+ Type.tuple args - let emitTagType name args = + let createCase name args = Case (str (Naming.constructorName name), args) + let createTagType name args = let arity = List.length args let tagTypeName = if ctx.options.safeArity.HasConsume then @@ -388,18 +406,18 @@ and getLabelsFromInheritingTypes (flags: EmitTypeFlags) (overrideFunc: OverrideF "tags" let ty = Naming.structured Naming.moduleName name + "." + tagTypeName let args = args |> List.map (emitType_ ctx) - Type.appOpt (str ty) args + TagType (str ty, args) [ for e in inheritingTypes do match e with | InheritingType.KnownIdent i -> - yield str "#" + emitCase i.fullName.name (i.tyargs |> List.map (emitType_ ctx)) |> Case + yield createCase i.fullName.name (i.tyargs |> List.map (emitType_ ctx)) | InheritingType.UnknownIdent i -> - yield emitTagType i.name i.tyargs |> TagType + yield createTagType i.name i.tyargs | InheritingType.Prim (p, ts) -> match p.AsJSClassName with | Some name -> - yield str "#" + emitCase [name] (ts |> List.map (emitType_ ctx)) |> Case + yield createCase [name] (ts |> List.map (emitType_ ctx)) | None -> () | InheritingType.Other _ -> () ] @@ -530,7 +548,7 @@ module StructuredTextNode = let mergeScope s1 s2 = match s1, s2 with | Scope.Default, s | s, Scope.Default -> s - | _, _ -> failwithf "impossible_mergeScope(%A, %A)" s1 s2 + | _, _ -> impossible "mergeScope(%A, %A)" s1 s2 {| scope = mergeScope a.scope b.scope items = List.append a.items b.items comments = List.append a.comments b.comments @@ -585,7 +603,7 @@ module StructuredText = |> WeakTrie.toList |> List.map (function | [x] -> k, x - | xs -> failwithf "impossible_StructuredText_getDependencyGraphOfChildren_refs(%s): %A" (ctx |> Context.getFullNameString [k]) xs) + | xs -> impossible "StructuredText_getDependencyGraphOfChildren_refs(%s): %A" (ctx |> Context.getFullNameString [k]) xs) refs :: state) [] |> List.rev |> List.concat @@ -614,16 +632,30 @@ let scopeToAttr (s: CurrentScope) attr = | sr, Some m -> Attr.External.module_ (Some m) :: Attr.External.scope (List.rev sr) :: attr +let tryBindToCurrentScope (s: CurrentScope) attr = + match s.scopeRev, s.jsModule with + | [], None -> None + | [], Some m -> Some {| self = m; attr = Attr.External.module_ None :: attr |} + | s :: [], None -> Some {| self = s; attr = attr |} + | s :: [], Some m -> Some {| self = s; attr = Attr.External.module_ (Some m) :: attr |} + | s :: sr, None -> Some {| self = s; attr = Attr.External.scope (List.rev sr) :: attr |} + | s :: sr, Some m -> Some {| self = s; attr = Attr.External.module_ (Some m) :: Attr.External.scope (List.rev sr) :: attr |} + let func flags overrideFunc ctx (ft: FuncType) = Func (ft, [], ft.loc) |> emitTypeImpl flags overrideFunc ctx +let newableFunc flags overrideFunc ctx (ft: FuncType) = + NewableFunc (ft, [], ft.loc) |> emitTypeImpl flags overrideFunc ctx + let extFunc flags overrideFunc ctx (ft: FuncType) = let c = classifyExternalFunction flags ft let ty = func c.flags overrideFunc ctx ft - let attr = [ - if c.isNullable then yield Attr.ExternalModifier.return_nullable - if c.isVariadic then yield Attr.ExternalModifier.variadic - ] + let attr = + if c.needsWorkaround then None + else Some [ + if c.isNullable then yield Attr.ExternalModifier.return_nullable + if c.isVariadic then yield Attr.ExternalModifier.variadic + ] ty, attr let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: bool) (ma: MemberAttribute) m = @@ -634,8 +666,9 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let inline extFunc ft = extFunc flags overrideFunc ctx ft let inline func ft = func flags overrideFunc ctx ft + let inline newableFunc ft = newableFunc flags overrideFunc ctx ft - let generateCallable isNewable (args: Choice list) = + let createRawCall memberName isVariadic isNewable (args: Choice list) = let used = args |> List.choose (function Choice1Of2 f -> Some f.name | Choice2Of2 _ -> None) |> Set.ofList @@ -644,7 +677,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: else rename (s + "_") let self = rename "t" let args = - let rec createArgs index isOptional acc = function + let rec go index isOptional acc = function | [] -> if isOptional then let name = rename "unit" @@ -653,18 +686,28 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: List.rev acc | Choice2Of2 _ :: rest -> let name = sprintf "arg%d" index |> rename - createArgs (index+1) false ({| ml = str name; js = name; used = true |} :: acc) rest + go (index+1) false ({| ml = str name; js = name; used = true |} :: acc) rest | Choice1Of2 { name = name; isOptional = isOptional } :: rest -> let ml = if isOptional then sprintf "~%s=?" name else "~" + name let js = name |> String.replace "'" "$p" - createArgs (index+1) isOptional ({| ml = str ml; js = js; used = true |} :: acc) rest - createArgs 1 false [] args + go (index+1) isOptional ({| ml = str ml; js = js; used = true |} :: acc) rest + go 1 false [] args let body = let args = - args |> List.filter (fun arg -> arg.used) - |> List.map (fun arg -> arg.js) - |> String.concat ", " - let body = sprintf "%s(%s)" self args + let args = + args |> List.filter (fun arg -> arg.used) |> List.map (fun arg -> arg.js) + if not isVariadic then String.concat ", " args + else + match List.rev args with + | [] -> impossible "emitMembers_createValue" + | last :: [] -> $"...{last}" + | last :: rest -> sprintf "%s, ...%s" (rest |> List.rev |> String.concat ", ") last + let body = + match memberName with + | Some m -> + if Naming.isValidJSIdentifier m then sprintf "%s.%s(%s)" self m args + else sprintf "%s[\"%s\"](%s)" self m args + | None -> sprintf "%s(%s)" self args if isNewable then "new " + body else body let args = str self :: (args |> List.map (fun arg -> arg.ml)) Term.curriedArrow args (Term.raw body) @@ -674,42 +717,51 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: match m with | Constructor ft -> - let ty, attrs = extFunc { args = ft.args; isVariadic = ft.isVariadic; returnType = selfTy; loc = ft.loc } + let ty, attrs = + let ft = { args = ft.args; isVariadic = ft.isVariadic; returnType = selfTy; loc = ft.loc } + match extFunc ft with + | ty, Some attrs -> ty, Attr.External.new_ :: attrs + | _, None -> + newableFunc { args = ft.args; isVariadic = ft.isVariadic; returnType = selfTy; loc = ft.loc }, + Attr.External.val_ :: [] binding (fun rename s -> let target, attrs = if isExportDefaultClass || List.isEmpty s.scopeRev then match s.jsModule with - | Some m -> m, Attr.External.module_ None :: attrs - | None -> failwithf "impossible_emitMembers_Constructor_ExportDefaultClass(%s)" ma.loc.AsString + | Some m -> m, Attr.External.module_ None :: Attr.External.new_ :: attrs + | None -> impossible "emitMembers_Constructor_ExportDefaultClass(%s)" ma.loc.AsString else - match s.scopeRev with - | self :: sr -> - let attrs = scopeToAttr { s with scopeRev = sr } attrs - self, attrs - | [] -> failwithf "impossible_emitMembers_Constructor(%s)" ma.loc.AsString - let attrs = Attr.External.new_ :: attrs |> List.rev + match tryBindToCurrentScope s attrs with + | None -> impossible "emitMembers_Constructor(%s)" ma.loc.AsString + | Some x -> x.self, x.attr + let attrs = attrs |> List.rev ext attrs comments (rename "make") ty target ) | Newable (ft, _typrm) -> - let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args } - let value = generateCallable true ft.args + let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args; isVariadic = false } + let value = createRawCall None ft.isVariadic true ft.args binding (fun rename _ -> let_ [] comments (rename "make") ty value) | Callable (ft, _typrm) -> - let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args } - let value = generateCallable false ft.args + let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args; isVariadic = false } + let value = createRawCall None ft.isVariadic false ft.args binding (fun rename _ -> let_ [] comments (rename "apply") ty value) | Field ({ name = name; value = Func (ft, _typrm, _) }, _) | Method (name, ft, _typrm) -> let origName = name - let ty, attrs = - if ma.isStatic then - let ty, attr = extFunc ft - ty, Attr.External.val_ :: attr - else - let ft = { ft with args = Choice2Of2 PolymorphicThis :: ft.args } - let ty, attr = extFunc ft - ty, Attr.External.send :: attr - binding (fun rename s -> ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) + let ext ty attrs = + binding (fun rename s -> ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) + if ma.isStatic then + match extFunc ft with + | ty, Some attr -> ext ty (Attr.External.val_ :: attr) + | ty, None -> ext ty (Attr.External.val_ :: []) + else + let ft = { ft with args = Choice2Of2 PolymorphicThis :: ft.args } + match extFunc ft with + | ty, Some attr -> ext ty (Attr.External.send :: attr) + | _, None -> + let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args; isVariadic = false } + let value = createRawCall (Some name) ft.isVariadic false ft.args + binding (fun rename _ -> let_ [] comments (rename name |> Naming.valueName) ty value) | Getter fl | Field (fl, ReadOnly) -> let origName = fl.name let name = @@ -735,8 +787,8 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ret = if fl.isOptional then Union { types = [fl.value; Prim Undefined] } else fl.value - extFunc { isVariadic = false; args = args; returnType = ret; loc = ma.loc } - let attrs = Attr.External.get_ :: attrs + let ty, attrs = extFunc { isVariadic = false; args = args; returnType = ret; loc = ma.loc } + ty, Attr.External.get_ :: impossibleNone (fun () -> "emitMembers_Getter") attrs binding (fun rename _ -> ext attrs comments (rename name |> Naming.valueName) ty origName) | Setter fl | Field (fl, WriteOnly) -> let origName = fl.name @@ -759,7 +811,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: else [Choice2Of2 PolymorphicThis; Choice2Of2 fl.value] let ty, attrs = extFunc { isVariadic = false; args = args; returnType = Prim Void; loc = ma.loc } - ty, Attr.External.set_ :: attrs + ty, Attr.External.set_ :: impossibleNone (fun () -> "emitMembers_Setter") attrs binding (fun rename s -> ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) | Field (fl, Mutable) -> List.concat [ @@ -769,15 +821,15 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: | Indexer (ft, ReadOnly) -> let ty, attrs = let args = Choice2Of2 PolymorphicThis :: removeLabels ft.args - extFunc { ft with args = args } - let attrs = Attr.External.get_index :: attrs + extFunc { ft with args = args; isVariadic = false } + let attrs = Attr.External.get_index :: impossibleNone (fun () -> "emitMembers_Indexer_Read") attrs binding (fun rename _ -> ext attrs comments (rename "get") ty "") | Indexer (ft, WriteOnly) -> let ty, attrs = let args = Choice2Of2 PolymorphicThis :: removeLabels ft.args @ [Choice2Of2 ft.returnType] let ret = Prim Void - extFunc { ft with args = args; returnType = ret } - let attrs = Attr.External.set_index :: attrs + extFunc { ft with args = args; returnType = ret; isVariadic = false } + let attrs = Attr.External.set_index :: impossibleNone (fun () -> "emitMembers_Indexer_Write") attrs binding (fun rename _ -> ext attrs comments (rename "set") ty "") | Indexer (ft, Mutable) -> List.concat [ @@ -787,7 +839,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: | SymbolIndexer (symbol, ft, _) -> let c = let ft = func ft - tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol |> comment + tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol binding (fun _ _ -> unknownBinding comments (Some c)) | UnknownMember msgo -> binding (fun _ _ -> unknownBinding comments (msgo |> Option.map str)) @@ -817,23 +869,23 @@ let emitTypeAliasesImpl for tyarg in tyargs' do yield tyarg for t in typrms |> List.skip arity do match t.defaultType with - | None -> failwith "impossible_emitTypeAliases" + | None -> impossible "emitTypeAliases" | Some t -> yield emitType_ ctx t ] yield! lines {| name = name; tyargs = List.zip typrms' tyargs'; target = target; isOverload = true |} ] -let emitTypeAliases flags overrideFunc ctx (typrms: TypeParam list) target = +let emitTypeAliases flags overrideFunc ctx (typrms: TypeParam list) target isRec = let emitType = emitTypeImpl flags emitTypeAliasesImpl "t" flags overrideFunc ctx typrms target ( - fun x -> [Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target |> TypeDefText] + fun x -> [Statement.typeAlias (isRec && not x.isOverload) x.name (x.tyargs |> List.map snd) x.target |> TypeDefText] ) -let emitTypeAlias flags overrideFunc ctx (typrms: TypeParam list) target = +let emitTypeAlias flags overrideFunc ctx (typrms: TypeParam list) target isRec = let emitType = emitTypeImpl flags emitTypeAliasesImpl "t" flags overrideFunc ctx typrms target ( fun x -> - if not x.isOverload then [Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target |> TypeDefText] + if not x.isOverload then [Statement.typeAlias isRec x.name (x.tyargs |> List.map snd) x.target |> TypeDefText] else [] ) @@ -890,7 +942,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | Choice2Of2 Anonymous -> let ai = c.MapName (fun _ -> Anonymous) match ctx |> Context.bindCurrentSourceInfo (fun info -> info.anonymousInterfacesMap |> Map.tryFind ai) with - | None -> failwith "impossible_emitClass_unknown_anonymousInterface" + | None -> impossible "emitClass_unknown_anonymousInterface" | Some i -> let selfTy = if List.isEmpty c.typeParams then AnonymousInterface ai @@ -984,7 +1036,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let alias = emitTypeAliasesImpl "tags" flags overrideFunc innerCtx c.typeParams (emitLabels innerCtx labels) - (fun x -> [Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target]) + (fun x -> [Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target]) |> concat newline alias|> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some else None @@ -996,7 +1048,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c |> function Choice1Of2 xs -> xs | Choice2Of2 (_, x) -> [x] |> emitLabelsBody innerCtx |> between "[> " " ]" - Statement.typeAlias "this" + Statement.typeAlias false "this" (str "'tags" :: str "'base" :: typrms) (Type.intf (str "'tags") (Some (str "'base")) +@ " constraint 'tags = " + tags) |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some @@ -1012,7 +1064,11 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c if not innerCtx.options.stdlib then fallback () else if innerCtx.currentSourceFile = stdlibEsSrc then match Type.predefinedTypes |> Map.tryFind x.name with - | Some (t, _) -> Some (str t), [] + | Some (t, arity) -> + match c.typeParams |> matchArity arity with + | None -> fallback () + | Some typrms -> + Some (Type.appOpt (str t) (typrms |> List.map (fun tp -> tprintf "'%s" tp.name))), [] | None -> fallback () else if innerCtx.currentSourceFile = stdlibDomSrc then match Type.predefinedDOMTypes.TryGetValue(x.name) with @@ -1021,7 +1077,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c else fallback () let typeDefinition = - let fallback = str "private any" + let fallback = {| ty = str "private any"; isRec = false |} let getSelfTyText (c: Class) = match c.name with | Name name -> @@ -1031,7 +1087,12 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c getLabelsOfFullName flags overrideFunc innerCtx (innerCtx |> Context.getFullName []) c.typeParams if List.isEmpty labels then fallback else - Type.intf (emitLabels innerCtx labels) baseType + let isRec = + labels |> List.exists (function + | Case (_, args) | TagType (_, args) -> + args |> List.contains (str "t") + ) + {| ty = Type.intf (emitLabels innerCtx labels) baseType; isRec = isRec |} else fallback | ExportDefaultUnnamedClass -> let labels = @@ -1040,23 +1101,23 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c |> getLabelsFromInheritingTypes flags overrideFunc innerCtx if List.isEmpty labels then fallback else - Type.intf (emitLabels innerCtx labels) baseType + {| ty = Type.intf (emitLabels innerCtx labels) baseType; isRec = false |} let selfTyText = match kind with | ClassKind.NormalClass x -> getSelfTyText x.orig | ClassKind.ExportDefaultClass x -> getSelfTyText x.orig | ClassKind.AnonymousInterface _ -> fallback let onTypes = - emitTypeAlias flags overrideFunc innerCtx c.typeParams selfTyText + emitTypeAlias flags overrideFunc innerCtx c.typeParams selfTyText.ty selfTyText.isRec |> List.map (conditional { EmitCondition.empty with onTypes = true }) let onIntf = - emitTypeAliases flags overrideFunc innerCtx c.typeParams selfTyText + emitTypeAliases flags overrideFunc innerCtx c.typeParams selfTyText.ty selfTyText.isRec |> List.map (conditional { EmitCondition.empty with onIntf = true }) let onImpl = let origTyText = let tyargs = c.typeParams |> List.map (fun x -> tprintf "'%s" x.name) Type.appOpt (str "t") tyargs - emitTypeAliases flags overrideFunc innerCtx c.typeParams origTyText + emitTypeAliases flags overrideFunc innerCtx c.typeParams origTyText false |> List.map (conditional { EmitCondition.empty with onImpl = true }) List.concat [onTypes; onIntf; onImpl] @@ -1180,7 +1241,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu let duplicateCases = e.cases |> List.filter (fun c' -> c.value = c'.value) match duplicateCases with - | [] -> failwith "impossible_enumCaseToIdentifier" + | [] -> impossible "enumCaseToIdentifier" | [c'] -> assert (c = c') Naming.constructorName [c.name] @@ -1207,7 +1268,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu | [EnumType.Int] -> let isClean = enumValues - |> List.map (function Some (LInt i) -> i | _ -> failwith "impossible") + |> List.map (function Some (LInt i) -> i | _ -> impossible "emitEnum_Int") |> Seq.sort |> Seq.mapi ((=)) |> Seq.forall id @@ -1220,7 +1281,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu let aritySafety = if ctx.options.safeArity.HasProvide then - Statement.typeAlias "t_0" [] (str "t") + Statement.typeAlias false "t_0" [] (str "t") |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> List.singleton @@ -1239,7 +1300,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu match c.value with | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} - | _ -> failwith "impossible" + | _ -> impossible "emitEnum_child_PolyVariant" Type.polyVariant [case] | _ -> str "private t" EnumCaseText {| name = c.name; ty = ty; comments = c.comments |} @@ -1250,7 +1311,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu | EnumType.CleanInt -> let cases = distinctCases - |> List.map (fun (n, v) -> n, match v with Some (LInt i) -> i | _ -> failwith "impossible") + |> List.map (fun (n, v) -> n, match v with Some (LInt i) -> i | _ -> impossible "emitEnum_parentNode_CleanInt") |> List.sortBy snd |> List.map fst let casesText = @@ -1272,14 +1333,14 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu |> List.map (function | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} - | _ -> failwith "impossible") - Statement.typeAlias "t" [] (Type.polyVariant cases) |> TypeDefText |> appendAritySafety - | EnumType.Boolean -> Statement.typeAlias "t" [] (str "private bool") |> TypeDefText |> appendAritySafety + | _ -> impossible "emitEnum_parentNode_PolyVariant") + Statement.typeAlias false "t" [] (Type.polyVariant cases) |> TypeDefText |> appendAritySafety + | EnumType.Boolean -> Statement.typeAlias false "t" [] (str "private bool") |> TypeDefText |> appendAritySafety | EnumType.Float | EnumType.Number -> ctx.logger.warnf "an enum type '%s' contains a case with float or negative value, which is not supported in ReScript at %s" e.name e.loc.AsString [ yield commentStr (sprintf "FIXME: float/negative enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } - yield Statement.typeAlias "t" [] (str "private float") |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } + yield Statement.typeAlias false "t" [] (str "private float") |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } yield! aritySafety ] @@ -1287,7 +1348,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu ctx.logger.warnf "a heterogeneous enum '%s' is not supported at %s" e.name e.loc.AsString [ yield commentStr (sprintf "FIXME: heterogeneous enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } - yield Statement.typeAlias "t" [] (str "private any") |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } + yield Statement.typeAlias false "t" [] (str "private any") |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } yield! aritySafety ] @@ -1303,7 +1364,7 @@ let private createExternalForValue (ctx: Context) (rename: string -> string) (s: ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty name let jsModule () = match s.jsModule with - | None -> failwith "impossible_createExternalForValue" + | None -> impossible "createExternalForValue" | Some jsModule -> jsModule match ctx |> Context.getExportTypeOfName [name] with | None | Some (ExportType.Child _) | Some (ExportType.ES6 None) -> fallback () @@ -1314,26 +1375,33 @@ let private createExternalForValue (ctx: Context) (rename: string -> string) (s: | Some (ExportType.ES6 (Some renameAs)) -> ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty renameAs -let emitVariable flags overrideFunc ctx (v: Variable) = - let emitType = emitTypeImpl flags - let emitType_ = emitType overrideFunc - let inline extFunc ft = extFunc flags overrideFunc ctx ft - let ty, attr = - match v.typ with - | Func (ft, _, _) -> - let ty, attr = extFunc ft - ty, Attr.External.val_ :: attr - | _ -> emitType_ ctx v.typ, [Attr.External.val_] - let comments = emitComments v.comments - binding (fun rename s -> createExternalForValue ctx rename s attr comments v.name ty) - -let emitFunction flags overrideFunc ctx (f: Function) = - let emitType = emitTypeImpl flags - let emitType_ = emitType overrideFunc - let inline extFunc ft = extFunc flags overrideFunc ctx ft - let ty, attr = extFunc f.typ - let comments = emitComments f.comments - binding (fun rename s -> createExternalForValue ctx rename s (Attr.External.val_ :: attr) comments f.name ty) +let rec emitFunction flags overrideFunc ctx (f: Function) = + if functionNeedsWorkaround f.typ then + emitVariable flags overrideFunc ctx + { accessibility = f.accessibility; comments = f.comments; isExported = f.isExported; + loc = f.loc; name = f.name; isConst = true; typ = Func (f.typ, [], f.loc) } + else + let emitType = emitTypeImpl flags + let emitType_ = emitType overrideFunc + let inline extFunc ft = extFunc flags overrideFunc ctx ft + let ty, attr = extFunc f.typ + let attr = attr |> impossibleNone (fun () -> "emitFunction") + let comments = emitComments f.comments + binding (fun rename s -> createExternalForValue ctx rename s (Attr.External.val_ :: attr) comments f.name ty) + +and emitVariable flags overrideFunc ctx (v: Variable) = + match v.typ with + | Func (ft, tps, _) when not (functionNeedsWorkaround ft) -> + emitFunction flags overrideFunc ctx + { accessibility = v.accessibility; comments = v.comments; isExported = v.isExported; + loc = v.loc; name = v.name; typ = ft; typeParams = tps } + | _ -> + let emitType = emitTypeImpl flags + let emitType_ = emitType overrideFunc + let inline extFunc ft = extFunc flags overrideFunc ctx ft + let ty, attr = emitType_ ctx v.typ, [Attr.External.val_] + let comments = emitComments v.comments + binding (fun rename s -> createExternalForValue ctx rename s attr comments v.name ty) let emitImport (ctx: Context) (i: Import) : StructuredTextItem list = let emitImportClause (c: ImportClause) = @@ -1413,6 +1481,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let emitType_ = emitTypeImpl flags overrideFunc let inline extFunc ft = extFunc flags overrideFunc ctx ft let inline func ft = func flags overrideFunc ctx ft + let inline newableFunc ft = newableFunc flags overrideFunc ctx ft let emitAsVariable name typ isConst (memberAttr: MemberAttribute) = let v = { name = name; typ = typ; @@ -1436,38 +1505,34 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Method (name, ft, tps) -> yield! emitAsFunction name ft tps ma | Newable (ft, _tps) -> - let ty, attrs = extFunc ft + let ty, attrs = + match extFunc ft with + | ty, Some attrs -> ty, Attr.External.new_ :: attrs + | _, None -> newableFunc ft, Attr.External.val_ :: [] yield! binding (fun rename s -> let target, attrs = - match s.scopeRev with - | self :: sr -> - let attrs = scopeToAttr { s with scopeRev = sr } attrs - self, attrs - | [] -> - match s.jsModule with - | Some m -> m, Attr.External.module_ None :: attrs - | None -> failwithf "impossible_intfToStmts_Newable(%s)" ma.loc.AsString - let attrs = Attr.External.new_ :: attrs |> List.rev + match tryBindToCurrentScope s attrs with + | Some x -> x.self, x.attr + | None -> impossible "intfToStmts_Newable(%s)" ma.loc.AsString + let attrs = attrs |> List.rev ext attrs comments (rename "make") ty target ) | Callable (ft, _tps) -> - let ty, attrs = extFunc ft + let ty, attrs = + match extFunc ft with + | ty, Some attrs -> ty, Attr.External.new_ :: attrs + | _, None -> func ft, Attr.External.val_ :: [] yield! binding (fun rename s -> let target, attrs = - match s.scopeRev with - | self :: sr -> - let attrs = scopeToAttr { s with scopeRev = sr } attrs - self, Attr.External.val_ :: attrs - | [] -> - match s.jsModule with - | Some m -> m, Attr.External.module_ None :: attrs - | None -> failwithf "impossible_intfToStmts_Callable(%s)" ma.loc.AsString + match tryBindToCurrentScope s attrs with + | Some x -> x.self, x.attr + | None -> impossible "intfToStmts_Callable(%s)" ma.loc.AsString let attrs = attrs |> List.rev ext attrs comments (rename "apply") ty target ) - | Constructor _ -> failwith "impossible_emitStructuredDefinition_Pattern_intfToModule_Constructor" // because interface! + | Constructor _ -> impossible "emitStructuredDefinition_Pattern_intfToModule_Constructor" // because interface! | Indexer (ft, _) -> let ty = func ft yield! binding (fun _ _ -> unknownBinding comments (Some ("unsupported indexer of type: " @+ ty))) @@ -1517,9 +1582,13 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured emitEnum emitTypeFlags OverrideFunc.noOverride ctx current e | TypeAlias ta -> let ctx = ctx |> Context.ofChildNamespace ta.name + let isRec = + ta.target + |> getKnownTypes ctx + |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) let items = emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target) (fun x -> - let a = Statement.typeAlias x.name (x.tyargs |> List.map snd) x.target |> TypeDefText + let a = Statement.typeAlias (isRec && not x.isOverload) x.name (x.tyargs |> List.map snd) x.target |> TypeDefText if x.isOverload then a |> conditional { onTypes = false; onIntf = true; onImpl = true } |> List.singleton else a |> List.singleton ) @@ -1820,7 +1889,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} let header = [ - str "@@warning(\"-27-33-44\")" + str "@@warning(\"-27-32-33-44\")" ] let setTyperOptions (ctx: IContext) = @@ -1949,7 +2018,7 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: let sources, mergedFileName = match sources with - | [] -> failwith "impossible_emitImpl (empty sources)" + | [] -> impossible "emitImpl (empty sources)" | [src] -> [src], src.fileName | _ -> [mergeSources "input.d.ts" sources], "input.d.ts" From e54cb12cc3cdf46d1540336f4f809c72855f080a Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 23 Mar 2022 21:30:21 +0900 Subject: [PATCH 21/56] Add all inherited members to class --- src/Targets/ReScript/ReScriptHelper.fs | 2 +- src/Targets/ReScript/Writer.fs | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index d92b2831..0a7c1087 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -422,7 +422,7 @@ let private moduleSigImpl (prefix: string) (isRec: bool) (m: TextModule) = module Statement = let attr attrs = if List.isEmpty attrs then empty - else concat (str " ") attrs + newline + else concat (str " ") attrs +@ " " let let_ (attrs: text list) name typ value = attr attrs + tprintf "let %s: " name + typ +@ " = " + value diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index ae6b46c6..b0b603b9 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -766,7 +766,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let origName = fl.name let name = match m with - | Getter _ -> "get" + Naming.upperFirst fl.name + | Getter _ -> "get_" + fl.name | _ -> fl.name let fl = if fl.value <> Prim Void then fl @@ -798,7 +798,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: else let name = match m with - | Setter _ -> "set" + Naming.upperFirst fl.name + | Setter _ -> "set_" + fl.name | _ -> fl.name let fl = if fl.value <> Prim Void then fl @@ -1899,6 +1899,7 @@ let setTyperOptions (ctx: IContext) = ctx.options.replaceAliasToFunction <- false ctx.options.replaceNewableFunction <- false ctx.options.replaceRankNFunction <- true + ctx.options.addAllParentMembersToClass <- true let emitTypes (types: text list) : text list = [ From 3e27d0763afec45e85a52a3803fe0931c800787d Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 30 Mar 2022 19:05:45 +0900 Subject: [PATCH 22/56] Implement emitExportModule --- src/Targets/ReScript/Writer.fs | 68 ++++++++++++++++++++++++++++++++-- 1 file changed, 64 insertions(+), 4 deletions(-) diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index b0b603b9..e3be7e96 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -1739,6 +1739,10 @@ type EmitModuleResult = {| comments: text list |} +module EmitModuleResult = + let empty : EmitModuleResult = + {| imports = []; types = []; impl = []; intf = []; comments = [] |} + let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) : EmitModuleResult = let renamer = new OverloadRenamer() let children = @@ -1826,8 +1830,9 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) children @ items let exports = - // TODO - [] + st.value + |> Option.map (fun m -> m.exports |> emitExportModule ctx) + |> Option.defaultValue EmitModuleResult.empty let intf = let children = @@ -1851,7 +1856,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) | Choice3Of5 b -> yield! Binding.emitForInterface b | Choice5Of5 c -> yield c | _ -> () - yield! exports + // yield! exports.intf ] let impl = @@ -1880,7 +1885,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) | Choice3Of5 b -> yield! Binding.emitForImplementation b | Choice5Of5 c -> yield c | _ -> () - yield! exports + // yield! exports.impl ] let comments = @@ -1888,6 +1893,61 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} +and emitExportModule (ctx: Context) (exports: ExportItem list) : EmitModuleResult = + let emitComment comments origText = [ + let hasDocComment = not (List.isEmpty comments) + yield commentStr origText |> TypeDefText + if hasDocComment then + yield comments |> emitComments |> concat newline |> comment |> TypeDefText + ] + + let emitModuleAlias name (i: Ident) = + if i.kind |> Option.map Kind.generatesReScriptModule |> Option.defaultValue false then + [ Statement.moduleAlias + (name |> Naming.moduleNameReserved) + (i.name |> Naming.structured Naming.moduleName) |> TypeDefText ] + else [] + + let addItems items (acc: StructuredText) = + acc |> Trie.setOrUpdate {| StructuredTextNode.empty with items = items |} StructuredTextNode.union + + let setItems path items (acc: StructuredText) = + acc |> Trie.addOrUpdate path {| StructuredTextNode.empty with items = items |} StructuredTextNode.union + + let rec go isFirst (acc: StructuredText) (exports: ExportItem list) = + match exports with + | [] -> acc + | ExportItem.DefaultUnnamedClass node :: rest -> + go false (acc |> Trie.addOrUpdate ["Export"; "Default"] node StructuredTextNode.union) rest + | ExportItem.Export export :: rest -> + let clauses = export.clauses |> List.map fst + let rec go' acc = function + | [] -> acc + | NamespaceExport _ :: rest -> go' acc rest + | CommonJsExport i :: rest -> + go' (acc |> addItems (emitModuleAlias "Export" i)) rest + | ES6DefaultExport e :: rest -> + go' (acc |> setItems ["Export"] (emitModuleAlias "Default" e)) rest + | ES6Export e :: rest -> + let name = e.renameAs |> Option.defaultValue (e.target.name |> List.last) + go' (acc |> setItems ["Export"] (emitModuleAlias name e.target)) rest + let acc = + let generatesExportModule = + clauses |> List.exists (function ES6Export _ | ES6DefaultExport _ -> true | _ -> false) + if generatesExportModule then + acc |> setItems ["Export"] (emitComment export.comments export.origText) + else + acc |> addItems (emitComment export.comments export.origText) + go false (go' acc clauses) rest + | ExportItem.ReExport export :: rest -> + // TODO + let acc = + acc |> setItems ["Export"] (emitComment export.comments export.origText) + go isFirst acc rest + + let st = go true Trie.empty exports + st |> emitModule {| isReservedModule = true; jsModule = None; scopeRev = [] |} ctx + let header = [ str "@@warning(\"-27-32-33-44\")" ] From 33b0dd93996e555c1a299c167bdca56b7e8a3ae6 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 5 Apr 2022 20:07:18 +0900 Subject: [PATCH 23/56] Fix a bug when emitting exports for enum types --- src/Targets/ReScript/Writer.fs | 40 ++++++++++++---------------------- 1 file changed, 14 insertions(+), 26 deletions(-) diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index e3be7e96..42f5cee8 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -1316,7 +1316,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu |> List.map fst let casesText = if (cases |> List.sumBy (fun s -> s.Length)) > 80 then - concat newline [ + newline + concat newline [ for case in cases do yield indent (tprintf "| %s" case) ] @@ -1354,10 +1354,12 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu ] let items = items @ List.map child e.cases let comments = e.comments |> emitComments - let exports = getExportFromStatement ctx e.name Kind.OfEnum "enum" (Enum e) - {| StructuredTextNode.empty with items = items; comments = comments; exports = Option.toList exports |} + {| StructuredTextNode.empty with items = items; comments = comments |} - current |> add [e.name] parentNode + let exports = getExportFromStatement ctx e.name Kind.OfEnum "enum" (Enum e) + current + |> add [e.name] parentNode + |> set {| StructuredTextNode.empty with exports = Option.toList exports |} let private createExternalForValue (ctx: Context) (rename: string -> string) (s: CurrentScope) attr comments name ty = let fallback () = @@ -1776,10 +1778,12 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) let ctx = ctx |> Context.ofChildNamespace k let result = emitModule flags ctx v let openTypesModule = - let hasTypeDefinitions = result.types |> List.isEmpty |> not - v.value - |> Option.map (fun v -> hasTypeDefinitions && v.openTypesModule) - |> Option.defaultValue hasTypeDefinitions + if flags.isReservedModule then false + else + let hasTypeDefinitions = result.types |> List.isEmpty |> not + v.value + |> Option.map (fun v -> hasTypeDefinitions && v.openTypesModule) + |> Option.defaultValue hasTypeDefinitions {| name = name; origName = k |}, openTypesModule, result) let items = @@ -1856,7 +1860,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) | Choice3Of5 b -> yield! Binding.emitForInterface b | Choice5Of5 c -> yield c | _ -> () - // yield! exports.intf + yield! exports.intf ] let impl = @@ -1885,7 +1889,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) | Choice3Of5 b -> yield! Binding.emitForImplementation b | Choice5Of5 c -> yield c | _ -> () - // yield! exports.impl + yield! exports.impl ] let comments = @@ -1894,13 +1898,6 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} and emitExportModule (ctx: Context) (exports: ExportItem list) : EmitModuleResult = - let emitComment comments origText = [ - let hasDocComment = not (List.isEmpty comments) - yield commentStr origText |> TypeDefText - if hasDocComment then - yield comments |> emitComments |> concat newline |> comment |> TypeDefText - ] - let emitModuleAlias name (i: Ident) = if i.kind |> Option.map Kind.generatesReScriptModule |> Option.defaultValue false then [ Statement.moduleAlias @@ -1931,18 +1928,9 @@ and emitExportModule (ctx: Context) (exports: ExportItem list) : EmitModuleResul | ES6Export e :: rest -> let name = e.renameAs |> Option.defaultValue (e.target.name |> List.last) go' (acc |> setItems ["Export"] (emitModuleAlias name e.target)) rest - let acc = - let generatesExportModule = - clauses |> List.exists (function ES6Export _ | ES6DefaultExport _ -> true | _ -> false) - if generatesExportModule then - acc |> setItems ["Export"] (emitComment export.comments export.origText) - else - acc |> addItems (emitComment export.comments export.origText) go false (go' acc clauses) rest | ExportItem.ReExport export :: rest -> // TODO - let acc = - acc |> setItems ["Export"] (emitComment export.comments export.origText) go isFirst acc rest let st = go true Trie.empty exports From eca05e47dac807d2fbc5d4aabacbfcf73bbc5414 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 9 May 2022 16:25:26 +0900 Subject: [PATCH 24/56] Update yarn.lock --- yarn.lock | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yarn.lock b/yarn.lock index c39655d6..d1ebfbc3 100644 --- a/yarn.lock +++ b/yarn.lock @@ -2732,7 +2732,7 @@ requires-port@^1.0.0: resolved "https://registry.yarnpkg.com/requires-port/-/requires-port-1.0.0.tgz#925d2601d39ac485e091cf0da5c6e694dc3dcaff" integrity sha1-kl0mAdOaxIXgkc8NpcbmlNw9yv8= -rescript@9.1.4: +rescript@^9.1.4: version "9.1.4" resolved "https://registry.yarnpkg.com/rescript/-/rescript-9.1.4.tgz#1eb126f98d6c16942c0bf0df67c050198e580515" integrity sha512-aXANK4IqecJzdnDpJUsU6pxMViCR5ogAxzuqS0mOr8TloMnzAjJFu63fjD6LCkWrKAhlMkFFzQvVQYaAaVkFXw== From 800ad35267a241964a931bcabb492b401bd7de79 Mon Sep 17 00:00:00 2001 From: cannorin Date: Thu, 26 May 2022 15:40:38 +0900 Subject: [PATCH 25/56] Rebase to v2 --- src/Targets/ReScript/ReScriptHelper.fs | 2 +- src/Targets/ReScript/Writer.fs | 20 ++++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 0a7c1087..f4408e6b 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -97,7 +97,7 @@ module Attr = module Naming = let removeInvalidChars (s: string) = - s.ToCharArray() + s.Trim('"').ToCharArray() |> Array.map (fun c -> if Char.isAlphabetOrDigit c || c = '_' || c = '\'' then c else '_') |> System.String diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 42f5cee8..3cb43f34 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -1556,23 +1556,23 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let addAnonymousInterfaceExcluding ais current = addAnonymousInterfaceExcludingWithKnownTypes (knownTypes ()) ais current match s with - | Module m -> + | Namespace m -> let module' = - let scope = - if m.isNamespace then Scope.Default - else Scope.Module m.name - let node = {| StructuredTextNode.empty with comments = comments; scope = scope |} + let node = {| StructuredTextNode.empty with comments = comments; scope = Scope.Default |} let module' = current |> getTrie [m.name] |> set node let ctx = ctx |> Context.ofChildNamespace m.name m.statements |> List.fold (folder ctx) module' let current = current |> setTrie [m.name] module' match module'.value with | None -> current - | Some _ -> - let kind = - if m.isNamespace then Kind.OfNamespace - else Kind.OfModule - current |> addExport m.name kind (if m.isNamespace then "namespace" else "module") + | Some _ -> current |> addExport m.name Kind.OfNamespace "namespace" + | AmbientModule m -> + let module' = + let node = {| StructuredTextNode.empty with comments = comments; scope = Scope.Module m.name.unquoted |} + let module' = current |> getTrie [m.name.orig] |> set node + let ctx = ctx |> Context.ofChildNamespace m.name.orig + m.statements |> List.fold (folder ctx) module' + current |> setTrie [m.name.orig] module' | Global m -> current |> inTrie ["global"] (fun g -> let node = {| StructuredTextNode.empty with scope = Scope.Global |} From bb60b8089672cb2a47768fe6a7444361d8ec9522 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 29 Aug 2022 17:22:27 +0900 Subject: [PATCH 26/56] Upgrade to rescript 10.0 --- build/build.fs | 2 +- package.json | 2 +- test/res/.gitignore | 1 + test/res/src/main.res | 3 +++ yarn.lock | 8 ++++---- 5 files changed, 10 insertions(+), 6 deletions(-) create mode 100644 test/res/src/main.res diff --git a/build/build.fs b/build/build.fs index 4674f426..6c2a978d 100644 --- a/build/build.fs +++ b/build/build.fs @@ -149,7 +149,7 @@ module Test = let testDir = testDir "res" let outputDir = outputDir "test_res" let srcDir = testDir "src" - let srcGeneratedDir = testDir "src" "generated" + let srcGeneratedDir = srcDir "generated" let clean () = !! $"{outputDir}/*" diff --git a/package.json b/package.json index e1e9daea..7111c385 100644 --- a/package.json +++ b/package.json @@ -43,7 +43,7 @@ "cdk8s": "^2.2.41", "monaco-editor": "0.40.0", "react-player": "2.12.0", - "rescript": "^9.1.4", + "rescript": "^10.0.0", "ts2fable": "0.8.0-build.723", "webpack": "5.88.0", "webpack-cli": "5.1.0", diff --git a/test/res/.gitignore b/test/res/.gitignore index a22d5752..3bc4f81c 100644 --- a/test/res/.gitignore +++ b/test/res/.gitignore @@ -4,3 +4,4 @@ .bsb.lock .merlin /src/generated +*.bs.js diff --git a/test/res/src/main.res b/test/res/src/main.res new file mode 100644 index 00000000..e14b7498 --- /dev/null +++ b/test/res/src/main.res @@ -0,0 +1,3 @@ +open Ts + +Dom.ConsoleStatic.log([]) \ No newline at end of file diff --git a/yarn.lock b/yarn.lock index d1ebfbc3..efaa8b5b 100644 --- a/yarn.lock +++ b/yarn.lock @@ -2732,10 +2732,10 @@ requires-port@^1.0.0: resolved "https://registry.yarnpkg.com/requires-port/-/requires-port-1.0.0.tgz#925d2601d39ac485e091cf0da5c6e694dc3dcaff" integrity sha1-kl0mAdOaxIXgkc8NpcbmlNw9yv8= -rescript@^9.1.4: - version "9.1.4" - resolved "https://registry.yarnpkg.com/rescript/-/rescript-9.1.4.tgz#1eb126f98d6c16942c0bf0df67c050198e580515" - integrity sha512-aXANK4IqecJzdnDpJUsU6pxMViCR5ogAxzuqS0mOr8TloMnzAjJFu63fjD6LCkWrKAhlMkFFzQvVQYaAaVkFXw== +rescript@^10.0.0: + version "10.0.0" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-10.0.0.tgz#8460bc6f7d94bc580eac02d7c7efdf0a470916b8" + integrity sha512-LhNg/4+0j8NvoFeslgAeYLlzUwkq6kR6l6v8BnZ61VDTxopK2l96uT1lq5lv1aMxzMDynvE2qnX0zalre+6XxA== resolve-cwd@^3.0.0: version "3.0.0" From 682595b9354b6369947108cd76d6b132601d4ace Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 29 Aug 2022 20:19:33 +0900 Subject: [PATCH 27/56] Make it compile --- dist_rescript/src/Ts__min.res | 3 +- src/Targets/ReScript/ReScriptHelper.fs | 1 + src/Targets/ReScript/Writer.fs | 134 ++++++++++--------------- test/res/package.json | 4 +- test/res/yarn.lock | 16 +-- 5 files changed, 67 insertions(+), 91 deletions(-) diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/Ts__min.res index d54efb32..2ae1aa3d 100644 --- a/dist_rescript/src/Ts__min.res +++ b/dist_rescript/src/Ts__min.res @@ -27,11 +27,12 @@ type untyped_object = Js.Types.obj_val type untyped_function = Js.Types.function_val type symbol = Js.Types.symbol type regexp = Js.Re.t -type bigint +type bigint = Js.Types.bigint_val type \"true" = private bool type \"false" = private bool type intrinsic<'a> = private 'a +type id<'a> = 'a type null<+'a> = Js.null<'a> type null' = null type undefined<+'a> = Js.undefined<'a> diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index f4408e6b..d455397f 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -296,6 +296,7 @@ module Type = let array = str "array" let readonlyArray = str "array" let option t = app (str "option") [t] + let id t = app (str "id") [t] // JS types // ES5 diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 3cb43f34..d5802f01 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -17,11 +17,8 @@ let [] stdlibEsSrc = "lib.es.d.ts" let [] stdlibDomSrc = "lib.dom.d.ts" let [] stdlibWebworkerSrc = "lib.webworker.d.ts" -let impossible fmt = - Printf.ksprintf (fun msg -> failwith ("impossible_" + msg)) fmt - let impossibleNone msgf (x: 'a option) = - match x with None -> failwith ("impossible_" + msgf ()) | Some x -> x + match x with None -> failwith ("impossible (not None): " + msgf ()) | Some x -> x type ScriptTarget = TypeScript.Ts.ScriptTarget @@ -350,6 +347,7 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte | _ when f.isVariadic -> variadicFallback () | External.Root (_, _) -> Type.curriedArrow (args ()) (retTy flags) | External.Argument _ -> paren ("@uncurry " @+ Type.curriedArrow (args ()) (retTy flags)) + | External.Return _ -> Type.curriedArrow (args ()) (retTy flags) |> Type.id | _ -> Type.curriedArrow (args ()) (retTy flags) |> paren and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (u: UnionType) : text = @@ -532,8 +530,6 @@ and StructuredTextNode = {| comments: text list exports: ExportItem list openTypesModule: bool - /// Used to emit module signatures recursively. - typeReferences: Set anonymousInterfaces: Set |} @@ -543,7 +539,7 @@ let inline conditional cond x = Conditional (x, cond) module StructuredTextNode = let empty : StructuredTextNode = - {| scope = Scope.Default; items = []; comments = []; exports = []; typeReferences = Set.empty; anonymousInterfaces = Set.empty; openTypesModule = true |} + {| scope = Scope.Default; items = []; comments = []; exports = []; anonymousInterfaces = Set.empty; openTypesModule = true |} let union (a: StructuredTextNode) (b: StructuredTextNode) : StructuredTextNode = let mergeScope s1 s2 = match s1, s2 with @@ -554,7 +550,6 @@ module StructuredTextNode = comments = List.append a.comments b.comments exports = List.append a.exports b.exports openTypesModule = a.openTypesModule || b.openTypesModule - typeReferences = Set.union a.typeReferences b.typeReferences anonymousInterfaces = Set.union a.anonymousInterfaces b.anonymousInterfaces |} module StructuredText = @@ -567,53 +562,6 @@ module StructuredText = ] go x - let rec getReferences (ctx: Context) (x: StructuredText) : WeakTrie = - match ctx.state.referencesCache.TryGetValue(ctx.currentNamespace) with - | true, ts -> ts - | false, _ -> - let fn = ctx.currentNamespace - let trie = - x.value - |> Option.map (fun v -> - v.typeReferences - |> Set.fold (fun state -> function - | KnownType.Ident fn when fn.source = ctx.currentSourceFile -> state |> WeakTrie.add fn.name - | KnownType.AnonymousInterface (_, i) -> - state |> WeakTrie.add (i.namespace_ @ [anonymousInterfaceModuleName ctx i]) - | _ -> state - ) WeakTrie.empty) - |> Option.defaultValue WeakTrie.empty - let trie = - x.children - |> Map.fold (fun state k child -> - WeakTrie.union state (getReferences (ctx |> Context.ofChildNamespace k) child)) trie - |> WeakTrie.remove fn - ctx.state.referencesCache.[fn] <- trie - trie - - let getDependenciesOfChildren (ctx: Context) (x: StructuredText) : (string * string) list = - let parent = ctx.currentNamespace - x.children - |> Map.fold (fun state k child -> - let refs = - getReferences (ctx |> Context.ofChildNamespace k) child - |> WeakTrie.getSubTrie parent - |> Option.defaultValue WeakTrie.empty - |> WeakTrie.ofDepth 1 - |> WeakTrie.toList - |> List.map (function - | [x] -> k, x - | xs -> impossible "StructuredText_getDependencyGraphOfChildren_refs(%s): %A" (ctx |> Context.getFullNameString [k]) xs) - refs :: state) [] - |> List.rev - |> List.concat - - let calculateSCCOfChildren (ctx: Context) (x: StructuredText) : string list list = - let g = - let deps = getDependenciesOfChildren ctx x - Graph.ofEdges deps - Graph.stronglyConnectedComponents g (x.children |> Map.toList |> List.map fst) - let removeLabels (xs: Choice list) = xs |> List.map (function Choice2Of2 t -> Choice2Of2 t | Choice1Of2 fl -> Choice2Of2 fl.value) @@ -963,9 +911,6 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let dummy = c.MapName(fun _ -> ExportDefaultUnnamedClass) Statement.getKnownTypes ctx [Class dummy] |> Set.union additionalKnownTypes - let typeReferences = - c.implements |> List.map (getKnownTypes ctx) |> Set.unionMany - let isAnonymous, isExportDefaultClass = match kind with | ClassKind.AnonymousInterface _ -> true, false @@ -1177,7 +1122,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c yield! castFunctions ] - {| StructuredTextNode.empty with items = items; comments = comments; scope = scope; typeReferences = typeReferences |} + {| StructuredTextNode.empty with items = items; comments = comments; scope = scope |} let export = match kind with @@ -1585,8 +1530,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | TypeAlias ta -> let ctx = ctx |> Context.ofChildNamespace ta.name let isRec = - ta.target - |> getKnownTypes ctx + knownTypes () |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) let items = emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target) (fun x -> @@ -1594,8 +1538,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured if x.isOverload then a |> conditional { onTypes = false; onIntf = true; onImpl = true } |> List.singleton else a |> List.singleton ) - let typeReferences = getKnownTypes ctx ta.target - let node = {| StructuredTextNode.empty with items = items; typeReferences = typeReferences; comments = comments |} + let node = {| StructuredTextNode.empty with items = items; comments = comments |} current |> inTrie [ta.name] (set node) |> addExport ta.name Kind.OfTypeAlias "type" @@ -1708,21 +1651,6 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured stmts |> List.fold (folder rootCtx) Trie.empty -module ModuleEmitter = - let signature (ctx: Context) (st: StructuredText) = - if Map.count st.children < 3 then - Statement.moduleSigRec - else - let scc = StructuredText.calculateSCCOfChildren ctx st - fun (modules: TextModule list) -> - let modules = modules |> List.fold (fun state x -> state |> Map.add x.origName x) Map.empty - scc - |> List.map (fun group -> - group |> List.choose (fun name -> modules |> Map.tryFind name) |> Statement.moduleSigRec) - |> List.concat - - let structure (_: Context) (_: StructuredText) = Statement.moduleValMany - type EmitModuleFlags = {| /// The module being emitted is a reserved one (e.g. `Export`) isReservedModule: bool @@ -1830,7 +1758,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) children |> List.filter (fun (_, _, c) -> c.types |> List.isEmpty |> not) |> List.map (fun (k, _, c) -> {| k with content = c.imports @ c.types; comments = [] |}) - |> ModuleEmitter.signature ctx st + |> Statement.moduleSigRec children @ items let exports = @@ -1874,7 +1802,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) else c.imports @ c.impl {| k with content = content; comments = c.comments |}) - |> ModuleEmitter.structure ctx st + |> Statement.moduleValMany let typeDefs = items |> List.choose (function | c, Choice2Of5 t when c.onImpl -> Some t @@ -2036,6 +1964,49 @@ let emitStdlib (input: Input) (ctx: IContext) : Output list = createOutput "Ts__dom" ["Ts__min"; "Ts__es"] (writerCtx domSrc domCtx) domSrc createOutput "Ts__webworker" ["Ts__min"; "Ts__es"] (writerCtx webworkerSrc webworkerCtx) webworkerSrc ] +let emitReferenceTypeDirectives (ctx: Context) (src: SourceFile) : text list = + let refs = + src.references + |> List.choose (function TypeReference r -> Some r | _ -> None) + if List.isEmpty refs then [] + else + let comments = + refs + |> List.map (sprintf "") + |> List.map commentStr + let openRefs = + refs + |> List.map Naming.jsModuleNameToReScriptModuleName + |> List.map Statement.open_ + empty :: comments @ openRefs + +let emitReferenceFileDirectives (ctx: Context) (src: SourceFile) : text list = + let refs = + src.references + |> List.choose (function FileReference r -> Some r | _ -> None) + if List.isEmpty refs then [] + else + // if the referenced file is included in the input files, skip emitting it + let validRefs = + refs + |> List.choose (fun ref -> + let relativePath = Path.join [Path.dirname src.fileName; ref] + if ctx.state.fileNames |> List.contains relativePath |> not then + Some {| path = ref; relativePath = relativePath |} + else None) + let comments = + refs + |> List.map (sprintf "") + |> List.map commentStr + let openRefs = + validRefs + |> List.choose (fun x -> + JsHelper.deriveModuleName (Result.toOption ctx.state.info) [x.relativePath] + |> JsHelper.InferenceResult.tryUnwrap + |> Option.map Naming.jsModuleNameToReScriptModuleName) + |> List.map Statement.open_ + empty :: comments @ openRefs + let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: IContext) = let moduleName = match ctx.options.name with @@ -2097,6 +2068,9 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: let opens = [ yield Statement.open_ "Ts" yield Statement.open_ "Ts.Dom" + for src in sources do + yield! emitReferenceTypeDirectives ctx src + yield! emitReferenceFileDirectives ctx src ] let res = diff --git a/test/res/package.json b/test/res/package.json index 0feac795..6b44ab53 100644 --- a/test/res/package.json +++ b/test/res/package.json @@ -12,8 +12,8 @@ "author": "", "license": "MIT", "dependencies": { - "rescript": "9.1.4", - "typescript": "4.6.2", + "rescript": "10.0.0", + "typescript": "4.8.0", "yargs": "17.3.1", "react-player": "2.9.0" } diff --git a/test/res/yarn.lock b/test/res/yarn.lock index 23cfa1c5..285d7863 100644 --- a/test/res/yarn.lock +++ b/test/res/yarn.lock @@ -122,10 +122,10 @@ require-directory@^2.1.1: resolved "https://registry.yarnpkg.com/require-directory/-/require-directory-2.1.1.tgz#8c64ad5fd30dab1c976e2344ffe7f792a6a6df42" integrity sha1-jGStX9MNqxyXbiNE/+f3kqam30I= -rescript@9.1.4: - version "9.1.4" - resolved "https://registry.yarnpkg.com/rescript/-/rescript-9.1.4.tgz#1eb126f98d6c16942c0bf0df67c050198e580515" - integrity sha512-aXANK4IqecJzdnDpJUsU6pxMViCR5ogAxzuqS0mOr8TloMnzAjJFu63fjD6LCkWrKAhlMkFFzQvVQYaAaVkFXw== +rescript@10.0.0: + version "10.0.0" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-10.0.0.tgz#8460bc6f7d94bc580eac02d7c7efdf0a470916b8" + integrity sha512-LhNg/4+0j8NvoFeslgAeYLlzUwkq6kR6l6v8BnZ61VDTxopK2l96uT1lq5lv1aMxzMDynvE2qnX0zalre+6XxA== string-width@^4.1.0, string-width@^4.2.0, string-width@^4.2.3: version "4.2.3" @@ -143,10 +143,10 @@ strip-ansi@^6.0.0, strip-ansi@^6.0.1: dependencies: ansi-regex "^5.0.1" -typescript@4.6.2: - version "4.6.2" - resolved "https://registry.yarnpkg.com/typescript/-/typescript-4.6.2.tgz#fe12d2727b708f4eef40f51598b3398baa9611d4" - integrity sha512-HM/hFigTBHZhLXshn9sN37H085+hQGeJHJ/X7LpBWLID/fbc2acUMfU+lGD98X81sKP+pFa9f0DZmCwB9GnbAg== +typescript@4.8.0: + version "4.8.2" + resolved "https://registry.yarnpkg.com/typescript/-/typescript-4.8.2.tgz#e3b33d5ccfb5914e4eeab6699cf208adee3fd790" + integrity sha512-C0I1UsrrDHo2fYI5oaCGbSejwX4ch+9Y5jTQELvovfmFkK3HHSZJB8MSJcWLmCUBzQBchCrZ9rMRV6GuNrvGtw== wrap-ansi@^7.0.0: version "7.0.0" From 267640247a07842336f7f5d25399e3dfe1709a80 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 29 Aug 2022 22:04:49 +0900 Subject: [PATCH 28/56] Add rescript compile test --- build/build.fs | 1 - test/res/package.json | 8 +- test/res/yarn.lock | 167 ++++++++++++++++++++++++------------------ 3 files changed, 99 insertions(+), 77 deletions(-) diff --git a/build/build.fs b/build/build.fs index 6c2a978d..361d4ae7 100644 --- a/build/build.fs +++ b/build/build.fs @@ -86,7 +86,6 @@ let setup () = "Prepare" ?=> "BuildForTest" - ?=> "TestComplete" ?=> "BuildForPublish" ==> "Build" diff --git a/test/res/package.json b/test/res/package.json index 6b44ab53..c45b2177 100644 --- a/test/res/package.json +++ b/test/res/package.json @@ -11,10 +11,10 @@ ], "author": "", "license": "MIT", + "devDependencies": { + "@ocsigen/ts2ocaml": "link:../../" + }, "dependencies": { - "rescript": "10.0.0", - "typescript": "4.8.0", - "yargs": "17.3.1", - "react-player": "2.9.0" + "rescript": "^10.0.0" } } diff --git a/test/res/yarn.lock b/test/res/yarn.lock index 285d7863..ddfd35d7 100644 --- a/test/res/yarn.lock +++ b/test/res/yarn.lock @@ -2,11 +2,43 @@ # yarn lockfile v1 +"@babel/code-frame@^7.18.6": + version "7.18.6" + resolved "https://registry.yarnpkg.com/@babel/code-frame/-/code-frame-7.18.6.tgz#3b25d38c89600baa2dcc219edfa88a74eb2c427a" + integrity sha512-TDCmlK5eOvH+eH7cdAFlNXeVJqWIQ7gW9tY1GJIpUtFb6CmjVyq2VM3u71bOyR8CRihcCgMUYoDNyLXao3+70Q== + dependencies: + "@babel/highlight" "^7.18.6" + +"@babel/helper-validator-identifier@^7.18.6": + version "7.18.6" + resolved "https://registry.yarnpkg.com/@babel/helper-validator-identifier/-/helper-validator-identifier-7.18.6.tgz#9c97e30d31b2b8c72a1d08984f2ca9b574d7a076" + integrity sha512-MmetCkz9ej86nJQV+sFCxoGGrUbU3q02kgLciwkrt9QqEB7cP39oKEY0PakknEO0Gu20SskMRi+AYZ3b1TpN9g== + +"@babel/highlight@^7.18.6": + version "7.18.6" + resolved "https://registry.yarnpkg.com/@babel/highlight/-/highlight-7.18.6.tgz#81158601e93e2563795adcbfbdf5d64be3f2ecdf" + integrity sha512-u7stbOuYjaPezCuLj29hNW1v64M2Md2qupEKP1fHc7WdOA3DgLh37suiSrZYY7haUB7iBeQZ9P1uiRF359do3g== + dependencies: + "@babel/helper-validator-identifier" "^7.18.6" + chalk "^2.0.0" + js-tokens "^4.0.0" + +"@ocsigen/ts2ocaml@link:../..": + version "0.0.0" + uid "" + ansi-regex@^5.0.1: version "5.0.1" resolved "https://registry.yarnpkg.com/ansi-regex/-/ansi-regex-5.0.1.tgz#082cb2c89c9fe8659a311a53bd6a4dc5301db304" integrity sha512-quJQXlTSUGL2LH9SUXo8VwsY4soanhgo6LNSm84E1LBcE8s3O0wpdiRzyR9z/ZZJMlMWv37qOOb9pdJlMUEKFQ== +ansi-styles@^3.2.1: + version "3.2.1" + resolved "https://registry.yarnpkg.com/ansi-styles/-/ansi-styles-3.2.1.tgz#41fbb20243e50b12be0f04b8dedbf07520ce841d" + integrity sha512-VT0ZI6kZRdTh8YyJw3SMbYm/u+NqfsAxEpWO0Pf9sq8/e94WxxOpPKx9FR1FlyCtOVDNOQ+8ntlqFxiRc+r5qA== + dependencies: + color-convert "^1.9.0" + ansi-styles@^4.0.0: version "4.3.0" resolved "https://registry.yarnpkg.com/ansi-styles/-/ansi-styles-4.3.0.tgz#edd803628ae71c04c85ae7a0906edad34b648937" @@ -14,6 +46,25 @@ ansi-styles@^4.0.0: dependencies: color-convert "^2.0.1" +browser-or-node@^2.0.0: + version "2.0.0" + resolved "https://registry.yarnpkg.com/browser-or-node/-/browser-or-node-2.0.0.tgz#808ea90282a670931cdc0ea98166538a50dd0d89" + integrity sha512-3Lrks/Okgof+/cRguUNG+qRXSeq79SO3hY4QrXJayJofwJwHiGC0qi99uDjsfTwULUFSr1OGVsBkdIkygKjTUA== + +chalk@^2.0.0: + version "2.4.2" + resolved "https://registry.yarnpkg.com/chalk/-/chalk-2.4.2.tgz#cd42541677a54333cf541a49108c1432b44c9424" + integrity sha512-Mti+f9lpJNcwF4tWV8/OrTTtF1gZi+f8FqlyAdouralcFWFQWF2+NgCHShjkCb+IFBLq9buZwE1xckQU4peSuQ== + dependencies: + ansi-styles "^3.2.1" + escape-string-regexp "^1.0.5" + supports-color "^5.3.0" + +chalk@^5.0.1: + version "5.0.1" + resolved "https://registry.yarnpkg.com/chalk/-/chalk-5.0.1.tgz#ca57d71e82bb534a296df63bbacc4a1c22b2a4b6" + integrity sha512-Fo07WOYGqMfCWHOzSXOt2CxDbC6skS/jO9ynEcmpANMoPrD+W1r1K6Vx7iNm+AQmETU1Xr2t+n8nzkV9t6xh3w== + cliui@^7.0.2: version "7.0.4" resolved "https://registry.yarnpkg.com/cliui/-/cliui-7.0.4.tgz#a0265ee655476fc807aea9df3df8df7783808b4f" @@ -23,6 +74,13 @@ cliui@^7.0.2: strip-ansi "^6.0.0" wrap-ansi "^7.0.0" +color-convert@^1.9.0: + version "1.9.3" + resolved "https://registry.yarnpkg.com/color-convert/-/color-convert-1.9.3.tgz#bb71850690e1f136567de629d2d5471deda4c1e8" + integrity sha512-QfAUtd+vFdAtFQcC8CCyYt1fYWxSqAiK2cSD6zDB8N3cpsEBAvRxp9zOGg6G/SHHJYAT88/az/IuDGALsNVbGg== + dependencies: + color-name "1.1.3" + color-convert@^2.0.1: version "2.0.1" resolved "https://registry.yarnpkg.com/color-convert/-/color-convert-2.0.1.tgz#72d3a68d598c9bdb3af2ad1e84f21d896abd4de3" @@ -30,16 +88,16 @@ color-convert@^2.0.1: dependencies: color-name "~1.1.4" +color-name@1.1.3: + version "1.1.3" + resolved "https://registry.yarnpkg.com/color-name/-/color-name-1.1.3.tgz#a7d0558bd89c42f795dd42328f740831ca53bc25" + integrity sha512-72fSenhMw2HZMTVHeCA9KCmpEIbzWiQsjN+BHcBbS9vr1mtt+vJjPdksIBNUmKAW8TFUDPJK5SUU3QhE9NEXDw== + color-name@~1.1.4: version "1.1.4" resolved "https://registry.yarnpkg.com/color-name/-/color-name-1.1.4.tgz#c2a09a87acbde69543de6f63fa3995c826c536a2" integrity sha512-dOy+3AuW3a2wNbZHIuMZpTcgjGuLU/uBL/ubcZF9OXbDo8ff4O8yVp5Bf0efS8uEoYo5q4Fx7dY9OgQGXgAsQA== -deepmerge@^4.0.0: - version "4.2.2" - resolved "https://registry.yarnpkg.com/deepmerge/-/deepmerge-4.2.2.tgz#44d2ea3679b8f4d4ffba33f03d865fc1e7bf4955" - integrity sha512-FJ3UgI4gIl+PHZm53knsuSFpE+nESMr7M4v9QcgB7S63Kj/6WqMiFQJpBBYz1Pt+66bZpP3Q7Lye0Oo9MPKEdg== - emoji-regex@^8.0.0: version "8.0.0" resolved "https://registry.yarnpkg.com/emoji-regex/-/emoji-regex-8.0.0.tgz#e818fd69ce5ccfcb404594f842963bf53164cc37" @@ -50,79 +108,37 @@ escalade@^3.1.1: resolved "https://registry.yarnpkg.com/escalade/-/escalade-3.1.1.tgz#d8cfdc7000965c5a0174b4a82eaa5c0552742e40" integrity sha512-k0er2gUkLf8O0zKJiAhmkTnJlTvINGv7ygDNPbeIsX/TJjGJZHuh9B2UxbsaEkmlEo9MfhrSzmhIlhRlI2GXnw== +escape-string-regexp@^1.0.5: + version "1.0.5" + resolved "https://registry.yarnpkg.com/escape-string-regexp/-/escape-string-regexp-1.0.5.tgz#1b61c0562190a8dff6ae3bb2cf0200ca130b86d4" + integrity sha512-vbRorB5FUQWvla16U8R/qgaFIya2qGzwDrNmCZuYKrbdSUMG6I1ZCGQRefkRVhuOkIGVne7BQ35DSfo1qvJqFg== + get-caller-file@^2.0.5: version "2.0.5" resolved "https://registry.yarnpkg.com/get-caller-file/-/get-caller-file-2.0.5.tgz#4f94412a82db32f36e3b0b9741f8a97feb031f7e" integrity sha512-DyFP3BM/3YHTQOCUL/w0OZHR0lpKeGrxotcHWcqNEdnltqFwXVfhEBQ94eIo34AfQpo0rGki4cyIiftY06h2Fg== +has-flag@^3.0.0: + version "3.0.0" + resolved "https://registry.yarnpkg.com/has-flag/-/has-flag-3.0.0.tgz#b5d454dc2199ae225699f3467e5a07f3b955bafd" + integrity sha512-sKJf1+ceQBr4SMkvQnBDNDtf4TXpVhVGateu0t918bl30FnbE2m4vNLX+VWe/dpjlb+HugGYzW7uQXH98HPEYw== + is-fullwidth-code-point@^3.0.0: version "3.0.0" resolved "https://registry.yarnpkg.com/is-fullwidth-code-point/-/is-fullwidth-code-point-3.0.0.tgz#f116f8064fe90b3f7844a38997c0b75051269f1d" integrity sha512-zymm5+u+sCsSWyD9qNaejV3DFvhCKclKdizYaJUuHA83RLjb7nSuGnddCHGv0hk+KY7BMAlsWeK4Ueg6EV6XQg== -"js-tokens@^3.0.0 || ^4.0.0": +js-tokens@^4.0.0: version "4.0.0" resolved "https://registry.yarnpkg.com/js-tokens/-/js-tokens-4.0.0.tgz#19203fb59991df98e3a287050d4647cdeaf32499" integrity sha512-RdJUflcE3cUzKiMqQgsCu06FPu9UdIJO0beYbPhHN4k6apgJtifcoCtT9bcxOpYBtpD2kCM6Sbzg4CausW/PKQ== -load-script@^1.0.0: - version "1.0.0" - resolved "https://registry.yarnpkg.com/load-script/-/load-script-1.0.0.tgz#0491939e0bee5643ee494a7e3da3d2bac70c6ca4" - integrity sha1-BJGTngvuVkPuSUp+PaPSuscMbKQ= - -loose-envify@^1.4.0: - version "1.4.0" - resolved "https://registry.yarnpkg.com/loose-envify/-/loose-envify-1.4.0.tgz#71ee51fa7be4caec1a63839f7e682d8132d30caf" - integrity sha512-lyuxPGr/Wfhrlem2CL/UcnUc1zcqKAImBDzukY7Y5F/yQiNdko6+fRLevlw1HgMySw7f611UIY408EtxRSoK3Q== - dependencies: - js-tokens "^3.0.0 || ^4.0.0" - -memoize-one@^5.1.1: - version "5.2.1" - resolved "https://registry.yarnpkg.com/memoize-one/-/memoize-one-5.2.1.tgz#8337aa3c4335581839ec01c3d594090cebe8f00e" - integrity sha512-zYiwtZUcYyXKo/np96AGZAckk+FWWsUdJ3cHGGmld7+AhvcWmQyGCYUh1hc4Q/pkOhb65dQR/pqCyK0cOaHz4Q== - -object-assign@^4.1.1: - version "4.1.1" - resolved "https://registry.yarnpkg.com/object-assign/-/object-assign-4.1.1.tgz#2109adc7965887cfc05cbbd442cac8bfbb360863" - integrity sha1-IQmtx5ZYh8/AXLvUQsrIv7s2CGM= - -prop-types@^15.7.2: - version "15.8.1" - resolved "https://registry.yarnpkg.com/prop-types/-/prop-types-15.8.1.tgz#67d87bf1a694f48435cf332c24af10214a3140b5" - integrity sha512-oj87CgZICdulUohogVAR7AjlC0327U4el4L6eAvOqCeudMDVU0NThNaV+b9Df4dXgSP1gXMTnPdhfe/2qDH5cg== - dependencies: - loose-envify "^1.4.0" - object-assign "^4.1.1" - react-is "^16.13.1" - -react-fast-compare@^3.0.1: - version "3.2.0" - resolved "https://registry.yarnpkg.com/react-fast-compare/-/react-fast-compare-3.2.0.tgz#641a9da81b6a6320f270e89724fb45a0b39e43bb" - integrity sha512-rtGImPZ0YyLrscKI9xTpV8psd6I8VAtjKCzQDlzyDvqJA8XOW78TXYQwNRNd8g8JZnDu8q9Fu/1v4HPAVwVdHA== - -react-is@^16.13.1: - version "16.13.1" - resolved "https://registry.yarnpkg.com/react-is/-/react-is-16.13.1.tgz#789729a4dc36de2999dc156dd6c1d9c18cea56a4" - integrity sha512-24e6ynE2H+OKt4kqsOvNd8kBpV65zoxbA4BVsEOB3ARVWQki/DHzaUoC5KuON/BiccDaCCTZBuOcfZs70kR8bQ== - -react-player@2.9.0: - version "2.9.0" - resolved "https://registry.yarnpkg.com/react-player/-/react-player-2.9.0.tgz#ef7fe7073434087565f00ff219824e1e02c4b046" - integrity sha512-jNUkTfMmUhwPPAktAdIqiBcVUKsFKrVGH6Ocutj6535CNfM91yrvWxHg6fvIX8Y/fjYUPoejddwh7qboNV9vGA== - dependencies: - deepmerge "^4.0.0" - load-script "^1.0.0" - memoize-one "^5.1.1" - prop-types "^15.7.2" - react-fast-compare "^3.0.1" - require-directory@^2.1.1: version "2.1.1" resolved "https://registry.yarnpkg.com/require-directory/-/require-directory-2.1.1.tgz#8c64ad5fd30dab1c976e2344ffe7f792a6a6df42" - integrity sha1-jGStX9MNqxyXbiNE/+f3kqam30I= + integrity sha512-fGxEI7+wsG9xrvdjsrlmL22OMTTiHRwAMroiEeMgq8gzoLC/PQr7RsRDSTLUg/bZAZtF+TVIkHc6/4RIKrui+Q== -rescript@10.0.0: +rescript@^10.0.0: version "10.0.0" resolved "https://registry.yarnpkg.com/rescript/-/rescript-10.0.0.tgz#8460bc6f7d94bc580eac02d7c7efdf0a470916b8" integrity sha512-LhNg/4+0j8NvoFeslgAeYLlzUwkq6kR6l6v8BnZ61VDTxopK2l96uT1lq5lv1aMxzMDynvE2qnX0zalre+6XxA== @@ -143,10 +159,17 @@ strip-ansi@^6.0.0, strip-ansi@^6.0.1: dependencies: ansi-regex "^5.0.1" -typescript@4.8.0: - version "4.8.2" - resolved "https://registry.yarnpkg.com/typescript/-/typescript-4.8.2.tgz#e3b33d5ccfb5914e4eeab6699cf208adee3fd790" - integrity sha512-C0I1UsrrDHo2fYI5oaCGbSejwX4ch+9Y5jTQELvovfmFkK3HHSZJB8MSJcWLmCUBzQBchCrZ9rMRV6GuNrvGtw== +supports-color@^5.3.0: + version "5.5.0" + resolved "https://registry.yarnpkg.com/supports-color/-/supports-color-5.5.0.tgz#e2e69a44ac8772f78a1ec0b35b689df6530efc8f" + integrity sha512-QjVjwdXIt408MIiAqCX4oUKsgU2EqAGzs2Ppkm4aQYbjm+ZEWEcW4SfFNTr4uMNZma0ey4f5lgLrkB0aX0QMow== + dependencies: + has-flag "^3.0.0" + +typescript@4.7: + version "4.7.4" + resolved "https://registry.yarnpkg.com/typescript/-/typescript-4.7.4.tgz#1a88596d1cf47d59507a1bcdfb5b9dfe4d488235" + integrity sha512-C0WQT0gezHuw6AdY1M2jxUO83Rjf0HP7Sk1DtXj6j1EwkQNZrHAg2XPWlq62oqEhYvONq5pkC2Y9oPljWToLmQ== wrap-ansi@^7.0.0: version "7.0.0" @@ -163,14 +186,14 @@ y18n@^5.0.5: integrity sha512-0pfFzegeDWJHJIAmTLRP2DwHjdF5s7jo9tuztdQxAhINCdvS+3nGINqPd00AphqJR/0LhANUS6/+7SCb98YOfA== yargs-parser@^21.0.0: - version "21.0.1" - resolved "https://registry.yarnpkg.com/yargs-parser/-/yargs-parser-21.0.1.tgz#0267f286c877a4f0f728fceb6f8a3e4cb95c6e35" - integrity sha512-9BK1jFpLzJROCI5TzwZL/TU4gqjK5xiHV/RfWLOahrjAko/e4DJkRDZQXfvqAsiZzzYhgAzbgz6lg48jcm4GLg== - -yargs@17.3.1: - version "17.3.1" - resolved "https://registry.yarnpkg.com/yargs/-/yargs-17.3.1.tgz#da56b28f32e2fd45aefb402ed9c26f42be4c07b9" - integrity sha512-WUANQeVgjLbNsEmGk20f+nlHgOqzRFpiGWVaBrYGYIGANIIu3lWjoyi0fNlFmJkvfhCZ6BXINe7/W2O2bV4iaA== + version "21.1.1" + resolved "https://registry.yarnpkg.com/yargs-parser/-/yargs-parser-21.1.1.tgz#9096bceebf990d21bb31fa9516e0ede294a77d35" + integrity sha512-tVpsJW7DdjecAiFpbIB1e3qxIQsE6NoPc5/eTdrbbIC4h0LVsWhnoa3g+m2HclBIujHzsxZ4VJVA+GUuc2/LBw== + +yargs@17.5.1: + version "17.5.1" + resolved "https://registry.yarnpkg.com/yargs/-/yargs-17.5.1.tgz#e109900cab6fcb7fd44b1d8249166feb0b36e58e" + integrity sha512-t6YAJcxDkNX7NFYiVtKvWUz8l+PaKTLiL63mJYWR2GnHq2gjEWISzsLp9wg3aY36dY1j+gfIEL3pIF+XlJJfbA== dependencies: cliui "^7.0.2" escalade "^3.1.1" From d36fb011d1d483a54d1c9f28e4c84b3c7e675849 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 29 Aug 2022 22:09:57 +0900 Subject: [PATCH 29/56] Split CI --- .github/workflows/ci.yml | 47 +++++++++++++++++++++++++++++++++++----- build/build.fs | 15 ++++++++----- 2 files changed, 52 insertions(+), 10 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0a89c531..2f5d5112 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -2,13 +2,13 @@ name: CI on: push: - branches: [main] + branches: [main,v2] pull_request: - branches: [main] + branches: [main,v2] workflow_dispatch: jobs: - build: + build-jsoo: strategy: fail-fast: false matrix: @@ -56,12 +56,49 @@ jobs: run: opam install . --deps-only - name: Build and test the project - run: bash fake test + run: bash fake TestJsoo + + build-res: + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + dotnet: + - 5.0.x + node-version: + - 16.x + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Use .NET ${{ matrix.dotnet }} + uses: actions/setup-dotnet@v1 + with: + dotnet-version: ${{ matrix.dotnet }} + + - name: Use Node.js ${{ matrix.node-version }} + uses: actions/setup-node@v2 + with: + node-version: ${{ matrix.node-version }} + cache: yarn + + - name: Install .NET Dependencies + run: | + dotnet restore + dotnet tool restore + + - name: Run FAKE + run: bash fake TestRes auto-merge: name: Auto-Merge PRs by Dependabot needs: - - build + - build-jsoo + - build-res runs-on: ubuntu-latest permissions: pull-requests: write diff --git a/build/build.fs b/build/build.fs index 361d4ae7..dd48ab10 100644 --- a/build/build.fs +++ b/build/build.fs @@ -27,8 +27,9 @@ let run cmd dir args = failwithf "Error while running '%s' with args: %s " cmd args let platformTool tool = - ProcessUtils.tryFindFileOnPath tool - |> function Some t -> t | _ -> failwithf "%s not found" tool + lazy + ProcessUtils.tryFindFileOnPath tool + |> function Some t -> t | _ -> failwithf "%s not found" tool let dotnetExec cmd args = let result = DotNet.exec id cmd args @@ -36,8 +37,8 @@ let dotnetExec cmd args = failwithf "Error while running 'dotnet %s %s'" cmd args let opamTool = platformTool "opam" -let opam args = run opamTool "./" args -let dune args = run opamTool "./" (sprintf "exec -- dune %s" args) +let opam args = run opamTool.Value "./" args +let dune args = run opamTool.Value "./" (sprintf "exec -- dune %s" args) // Build targets @@ -193,7 +194,9 @@ module Test = Shell.mkdir srcGeneratedDir for file in outputDir |> Shell.copyRecursiveTo true srcGeneratedDir do printfn "* copied to %s" file - // inDirectory testDir <| fun () -> dune "build" + inDirectory testDir <| fun () -> + Yarn.install id + Yarn.exec "rescript" id let setup () = Target.create "TestJsooClean" <| fun _ -> Jsoo.clean () @@ -206,6 +209,7 @@ module Test = ==> "TestJsooGenerateBindings" ==> "TestJsooBuild" ==> "TestJsoo" + ==> "Test" Target.create "TestResClean" <| fun _ -> Test.Res.clean () Target.create "TestResGenerateBindings" <| fun _ -> Test.Res.generateBindings () @@ -217,6 +221,7 @@ module Test = ==> "TestResGenerateBindings" ==> "TestResBuild" ==> "TestRes" + ==> "Test" // Publish targets From 53061b8af3b2f96aab343857bb490e42220a9a05 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 30 Aug 2022 20:31:53 +0900 Subject: [PATCH 30/56] Fix property parsing (for res) --- build/build.fs | 6 ++-- src/Targets/ReScript/ReScriptHelper.fs | 2 -- src/Targets/ReScript/Writer.fs | 50 +++++++++++++------------- 3 files changed, 29 insertions(+), 29 deletions(-) diff --git a/build/build.fs b/build/build.fs index dd48ab10..7eee51f3 100644 --- a/build/build.fs +++ b/build/build.fs @@ -211,9 +211,9 @@ module Test = ==> "TestJsoo" ==> "Test" - Target.create "TestResClean" <| fun _ -> Test.Res.clean () - Target.create "TestResGenerateBindings" <| fun _ -> Test.Res.generateBindings () - Target.create "TestResBuild" <| fun _ -> Test.Res.build () + Target.create "TestResClean" <| fun _ -> Res.clean () + Target.create "TestResGenerateBindings" <| fun _ -> Res.generateBindings () + Target.create "TestResBuild" <| fun _ -> Res.build () Target.create "TestRes" ignore "BuildForTest" diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index d455397f..c39598ec 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -437,8 +437,6 @@ module Statement = if not (Naming.isValidJSIdentifier target) && [Attr.External.new_; Attr.External.val_] |> List.exists (fun attr -> attrs |> List.contains attr) then comment result // ReScript doesn't allow exotic names except for get, set, and send. - else if attrs |> List.contains Attr.External.new_ && attrs |> List.contains Attr.ExternalModifier.variadic then - comment result // TODO: remove this once the PR is merged else result let typeAlias isRec name tyargs ty = diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index d5802f01..0340ce8d 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -467,11 +467,12 @@ module Binding = let builder name (fields: {| isOptional: bool; name: string; value: text |} list) (thisType: text) = let args = fields + |> List.distinctBy (fun x -> x.name) |> List.map (fun f -> let name = f.name |> Naming.valueName let suffix = if f.isOptional then "=?" else "" - tprintf "~%s: " name + f.value +@ suffix) + tprintf "~%s:" name + f.value +@ suffix) let args = match List.tryLast fields with | None -> args @@ -606,6 +607,20 @@ let extFunc flags overrideFunc ctx (ft: FuncType) = ] ty, attr +let extValue flags overrideFunc ctx (t: Type) = + let isNullable = + match t with + | Union u -> + let u = ResolvedUnion.checkNullOrUndefined u + u.hasNull || u.hasUndefined + | _ -> false + let flags = { flags with external = External.Return isNullable } + let attr = + if isNullable then [Attr.ExternalModifier.return_nullable] + else [] + let ty = emitTypeImpl flags overrideFunc ctx t + ty, attr + let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: bool) (ma: MemberAttribute) m = let flags = { flags with simplifyContravariantUnion = true } let emitType_ = emitTypeImpl flags overrideFunc @@ -613,6 +628,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let comments = emitComments ma.comments let inline extFunc ft = extFunc flags overrideFunc ctx ft + let inline extValue t = extValue flags overrideFunc ctx t let inline func ft = func flags overrideFunc ctx ft let inline newableFunc ft = newableFunc flags overrideFunc ctx ft @@ -693,7 +709,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args; isVariadic = false } let value = createRawCall None ft.isVariadic false ft.args binding (fun rename _ -> let_ [] comments (rename "apply") ty value) - | Field ({ name = name; value = Func (ft, _typrm, _) }, _) + | Field ({ name = name; value = Func (ft, _typrm, _); isOptional = false }, _) | Method (name, ft, _typrm) -> let origName = name let ext ty attrs = @@ -716,26 +732,16 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: match m with | Getter _ -> "get_" + fl.name | _ -> fl.name - let fl = - if fl.value <> Prim Void then fl - else - ctx.logger.warnf "the field/getter '%s' at %s has type 'void' and treated as 'undefined'" fl.name ma.loc.AsString - { fl with value = Prim Undefined } + let ty = Member.getActualTypeOfFieldLike fl if ma.isStatic then let ty, attrs = - let ty = emitType_ ctx fl.value - if fl.isOptional then - Type.option ty, [Attr.External.val_; Attr.ExternalModifier.return_nullable] - else - ty, [Attr.External.val_] + let ty, attrs = extValue ty + ty, Attr.External.val_ :: attrs binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) else let ty, attrs = let args = [Choice2Of2 PolymorphicThis] - let ret = - if fl.isOptional then Union { types = [fl.value; Prim Undefined] } - else fl.value - let ty, attrs = extFunc { isVariadic = false; args = args; returnType = ret; loc = ma.loc } + let ty, attrs = extFunc { isVariadic = false; args = args; returnType = ty; loc = ma.loc } ty, Attr.External.get_ :: impossibleNone (fun () -> "emitMembers_Getter") attrs binding (fun rename _ -> ext attrs comments (rename name |> Naming.valueName) ty origName) | Setter fl | Field (fl, WriteOnly) -> @@ -748,15 +754,11 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: match m with | Setter _ -> "set_" + fl.name | _ -> fl.name - let fl = - if fl.value <> Prim Void then fl - else - ctx.logger.warnf "the field/setter '%s' at %s has type 'void' and treated as 'undefined'" fl.name ma.loc.AsString - { fl with value = Prim Undefined } let ty, attrs = + let ty = Member.getActualTypeOfFieldLike fl let args = - if ma.isStatic then [Choice2Of2 fl.value] - else [Choice2Of2 PolymorphicThis; Choice2Of2 fl.value] + if ma.isStatic then [Choice2Of2 ty] + else [Choice2Of2 PolymorphicThis; Choice2Of2 ty] let ty, attrs = extFunc { isVariadic = false; args = args; returnType = Prim Void; loc = ma.loc } ty, Attr.External.set_ :: impossibleNone (fun () -> "emitMembers_Setter") attrs @@ -998,6 +1000,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c (Type.intf (str "'tags") (Some (str "'base")) +@ " constraint 'tags = " + tags) |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some else None + // " this resets the weird syntax highlighting let baseType, baseTypeDefinition = let fallback () = @@ -1345,7 +1348,6 @@ and emitVariable flags overrideFunc ctx (v: Variable) = | _ -> let emitType = emitTypeImpl flags let emitType_ = emitType overrideFunc - let inline extFunc ft = extFunc flags overrideFunc ctx ft let ty, attr = emitType_ ctx v.typ, [Attr.External.val_] let comments = emitComments v.comments binding (fun rename s -> createExternalForValue ctx rename s attr comments v.name ty) From de4a2f7033c9c9d682e879e3d962d27541b734a2 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 30 Aug 2022 23:58:35 +0900 Subject: [PATCH 31/56] Improve QoL (1) * more compact definitions * trying to minimize dependency to the generated stdlib --- build/build.fs | 7 +- dist_rescript/src/Ts.res | 5 - .../src/{Ts__min.res => ts2ocaml.res} | 89 ++++++++---------- src/Targets/ReScript/Common.fs | 2 +- src/Targets/ReScript/ReScriptHelper.fs | 94 ++++++++++++------- src/Targets/ReScript/Target.fs | 2 +- src/Targets/ReScript/Writer.fs | 54 +++++------ test/res/src/Ts.res | 5 - test/res/src/main.res | 4 +- 9 files changed, 135 insertions(+), 127 deletions(-) delete mode 100644 dist_rescript/src/Ts.res rename dist_rescript/src/{Ts__min.res => ts2ocaml.res} (78%) delete mode 100644 test/res/src/Ts.res diff --git a/build/build.fs b/build/build.fs index 7eee51f3..cbd1c682 100644 --- a/build/build.fs +++ b/build/build.fs @@ -118,7 +118,7 @@ module Test = let packages = [ // "full" package involving a lot of inheritance - "full", !! "node_modules/typescript/lib/typescript.d.ts", []; + "full", !! "node_modules/typescript/lib/typescript.d.ts", ["--safe-arity=off"]; // "full" packages involving a lot of dependencies (which includes some "safe" packages) "safe", !! "node_modules/@types/scheduler/tracing.d.ts", []; @@ -153,8 +153,9 @@ module Test = let clean () = !! $"{outputDir}/*" - ++ $"{srcGeneratedDir}/generated/*.res" - ++ $"{srcGeneratedDir}/generated/*.resi" + ++ $"{srcGeneratedDir}/*.res" + ++ $"{srcGeneratedDir}/*.resi" + ++ $"{srcGeneratedDir}/*.bs.js" |> Seq.iter Shell.rm let generateBindings () = diff --git a/dist_rescript/src/Ts.res b/dist_rescript/src/Ts.res deleted file mode 100644 index 097097b7..00000000 --- a/dist_rescript/src/Ts.res +++ /dev/null @@ -1,5 +0,0 @@ -include Ts__min -include Ts__es - -module Dom = Ts__dom -module WebWorker = Ts__webworker \ No newline at end of file diff --git a/dist_rescript/src/Ts__min.res b/dist_rescript/src/ts2ocaml.res similarity index 78% rename from dist_rescript/src/Ts__min.res rename to dist_rescript/src/ts2ocaml.res index 2ae1aa3d..6162778a 100644 --- a/dist_rescript/src/Ts__min.res +++ b/dist_rescript/src/ts2ocaml.res @@ -1,42 +1,32 @@ @@warning("-27") -type never - +@unboxed type never = { absurd : 'a. 'a } module Never = { type t = never - exception Never - let absurd : t => 'a = x => raise(Never) + external absurd : t => 'a = "%identity" } @unboxed type rec any = Any('a): any -external any : 'a => any = "%identity" - module Any = { type t = any + external upcast : 'a => t = "%identity" external unsafeCast : t => 'a = "%identity" } -type unknown - +@unboxed type rec unknown = Unknown('a): unknown module Unknown = { type t = unknown + external upcast : 'a => t = "%identity" external unsafeCast : t => 'a = "%identity" } -type untyped_object = Js.Types.obj_val -type untyped_function = Js.Types.function_val +type true_ = bool +type false_ = bool type symbol = Js.Types.symbol -type regexp = Js.Re.t -type bigint = Js.Types.bigint_val -type \"true" = private bool -type \"false" = private bool -type intrinsic<'a> = private 'a - -type id<'a> = 'a -type null<+'a> = Js.null<'a> -type null' = null -type undefined<+'a> = Js.undefined<'a> -type nullable<+'a> = Js.nullable<'a> +type bigint = Js.Bigint.t +type intrinsic = private string +type untypedObject = any +type untypedFunction = any module Union = { type container<+'cases> @@ -110,14 +100,14 @@ module Primitive = { } })(x)`) - external fromNull: null<'a> => t<[> #Null | #Other('a) ]> = "%identity" - external toNull: t<[< #Null | #Other('a) ]> => null<'a> = "%identity" + external fromNull: Js.null<'a> => t<[> #Null | #Other('a) ]> = "%identity" + external toNull: t<[< #Null | #Other('a) ]> => Js.null<'a> = "%identity" - external fromUndefined: undefined<'a> => t<[> #Undefined | #Other('a) ]> = "%identity" - external toUndefined: t<[< #Undefined | #Other('a) ]> => undefined<'a> = "%identity" + external fromUndefined: Js.undefined<'a> => t<[> #Undefined | #Other('a) ]> = "%identity" + external toUndefined: t<[< #Undefined | #Other('a) ]> => Js.undefined<'a> = "%identity" - external fromNullable: nullable<'a> => t<[> #Null | #Undefined | #Other('a) ]> = "%identity" - external toNullable: t<[< #Null | #Undefined | #Other('a) ]> => nullable<'a> = "%identity" + external fromNullable: Js.nullable<'a> => t<[> #Null | #Undefined | #Other('a) ]> = "%identity" + external toNullable: t<[< #Null | #Undefined | #Other('a) ]> => Js.nullable<'a> = "%identity" let classify: t<[< cases<'other>] as 'cases> => 'cases = x => switch (Js.typeof(x)) { @@ -134,26 +124,6 @@ module Primitive = { } module Interop = { - let apply0 = (it: 'Function) => %raw(`it()`) - let apply1 = (it: 'Function, arg0) => %raw(`it(arg0)`) - let apply2 = (it: 'Function, arg0, arg1) => %raw(`it(arg0, arg1)`) - let apply3 = (it: 'Function, arg0, arg1, arg2) => %raw(`it(arg0, arg1, arg2)`) - let apply4 = (it: 'Function, arg0, arg1, arg2, arg3) => %raw(`it(arg0, arg1, arg2, arg3)`) - let apply5 = (it: 'Function, arg0, arg1, arg2, arg3, arg4) => %raw(`it(arg0, arg1, arg2, arg3, arg4)`) - let apply6 = (it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5)`) - let apply7 = (it: 'Function, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) - let applyN = (it: 'Function, args: 'args) => %raw(`it(...args)`) - - let applyNewable0 = (it: 'Newable) => %raw(`new it()`) - let applyNewable1 = (it: 'Newable, arg0) => %raw(`new it(arg0)`) - let applyNewable2 = (it: 'Newable, arg0, arg1) => %raw(`new it(arg0, arg1)`) - let applyNewable3 = (it: 'Newable, arg0, arg1, arg2) => %raw(`new it(arg0, arg1, arg2)`) - let applyNewable4 = (it: 'Newable, arg0, arg1, arg2, arg3) => %raw(`new it(arg0, arg1, arg2, arg3)`) - let applyNewable5 = (it: 'Newable, arg0, arg1, arg2, arg3, arg4) => %raw(`new it(arg0, arg1, arg2, arg3, arg4)`) - let applyNewable6 = (it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5)`) - let applyNewable7 = (it: 'Newable, arg0, arg1, arg2, arg3, arg4, arg5, arg6) => %raw(`new it(arg0, arg1, arg2, arg3, arg4, arg5, arg6)`) - let applyNewableN = (it: 'Newable, args: 'args) => %raw(`new it(...args)`) - module PolyVariant = { let name = (it: 'PolyVariant) : 'name => %raw(`it.NAME`) let value = (it: 'PolyVariant) : 'value => %raw(`it.VAL`) @@ -228,4 +198,27 @@ module NewableVariadic = { let apply0 = (f0: t0<'variadic, 't>, variadic: 'variadic) : 't => %raw(`new f0(...variadic)`) let apply1 = (f1: t1<'arg1, 'variadic, 't>, arg1: 'arg1, variadic: 'variadic) : 't => %raw(`new f1(arg1, ...variadic)`) let applyN = (fn: tn<'args, 'variadic, 't>, args: 'args, variadic: 'variadic) : 't => %raw(`new fn(...args, ...variadic)`) -} \ No newline at end of file +} + +/* +type partial<'t> = 't +type required<'t> = 't +type readonly<'t> = 't +type pick<'t, 'keys> = 't +type record<'keys, 't> = Js.Dict.t<'t> +type exclude<'t, 'u> = 't +type extract<'t, 'u> = 't +type omit<'t, 'keys> = 't +type nonNullable<'t> = 't +type parameters<'t> = any +type constructorParameters<'t> = any +type returnType<'t> = any +type instanceType<'t> = any +type thisParameterType<'t> = any +type omitThisParameter<'t> = any +type thisType<'t> = any +type uppercase<'s> = intrinsic +type lowercase<'s> = intrinsic +type capitalize<'s> = intrinsic +type uncapitalize<'s> = intrinsic +*/ \ No newline at end of file diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 340edd4c..8177106a 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -247,4 +247,4 @@ type Output = { res: text } -let [] stdlib: string = jsNative \ No newline at end of file +let [] stdlib: string = jsNative \ No newline at end of file diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index c39598ec..9235cb3d 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -190,27 +190,48 @@ module Kind = [] module Type = + let tsUtilityTypes = [ + "Partial", 1; "Required", 1; "Readonly", 1; + "Record", 2; "Pick", 2; "Omit", 2; "Exclude", 2; "Extract", 2; + "NonNullable", 1; + "Parameters", 1; "ConstructorParameters", 1; "ReturnType", 1; "InstanceType", 1; + "ThisParameterType", 1; "OmitThisParameter", 1; "ThisType", 1; + "Uppercase", 1; "Lowercase", 1; "Capitalize", 1; "Uncapitalize", 1; + ] + /// non-primitive types defined in the standard library let predefinedTypes = - let typedArray name = name, (sprintf "Js.TypedArray2.%s.t" name, 0) - Map.ofList [ + let builtins = [ "RegExp", ("Js.Re.t", 0) "Date", ("Js.Date.t", 0) "Promise", ("Js.Promise.t", 1) + "PromiseLike", ("Js.Promise.t", 1) "Array", ("Js.Array.t", 1) "ArrayLike", ("Js.TypedArray2.array_like", 1) "ArrayBuffer", ("Js.TypedArray2.array_buffer", 0) - typedArray "DataView" - typedArray "Int8Array" - typedArray "Uint8Array" - typedArray "Uint8ClampedArray" - typedArray "Int16Array" - typedArray "Uint16Array" - typedArray "Int32Array" - typedArray "Uint32Array" - typedArray "Float32Array" - typedArray "Float64Array" + "Error", ("Js.Exn.t", 0) ] + let typedArrays = + let typedArray name = name, (sprintf "Js.TypedArray2.%s.t" name, 0) + [ + typedArray "DataView" + typedArray "Int8Array" + typedArray "Uint8Array" + typedArray "Uint8ClampedArray" + typedArray "Int16Array" + typedArray "Uint16Array" + typedArray "Int32Array" + typedArray "Uint32Array" + typedArray "Float32Array" + typedArray "Float64Array" + ] + (* + let utilities = + tsUtilityTypes |> List.map (fun (name, arity) -> + name, (Naming.lowerFirst name, arity) + ) + *) + Map.ofList (builtins @ typedArrays) /// non-primitive DOM types defined in the standard library /// @@ -219,8 +240,8 @@ module Type = let types = Source.dom |> String.splitManyThenRemoveEmptyEntries ["\n"; "\r"] - |> Array.filter (fun s -> s.StartsWith("type ") && s.Contains("=")) - |> Array.choose (fun s -> s |> String.replace "type " "" |> String.split " = " |> Array.tryHead) + |> Array.filter (fun s -> s.StartsWith("type ")) + |> Array.choose (fun s -> s |> String.replace "type " "" |> String.splitMany [" = "; " (*"] |> Array.tryHead) |> Array.filter (fun s -> s.Length > 0 && s.ToCharArray() |> Array.forall Char.isAlphabet) |> Array.map (fun s -> Naming.upperFirst s, "Dom." + s) let ignoreCase = @@ -296,29 +317,28 @@ module Type = let array = str "array" let readonlyArray = str "array" let option t = app (str "option") [t] - let id t = app (str "id") [t] // JS types // ES5 - let object = str "untyped_object" - let function_ = str "untyped_function" + let object = str "untypedObject" + let function_ = str "untypedFunction" let symbol = str "symbol" - let regexp = str "regexp" + let regexp = str "Js.Re.t" // ES2020 - let bigint = str "bigint" + let bigint = str "Js.Bigint.t" // TS types let never = str "never" let any = str "any" let unknown = str "unknown" - let null_or t = app (str "null") [t] - let undefined_or t = app (str "undefined") [t] - let null_or_undefined_or t = app (str "nullable") [t] - let null_ = str "null'" + let null_or t = app (str "Js.null") [t] + let undefined_or t = app (str "option") [t] + let null_or_undefined_or t = app (str "Js.nullable") [t] + let null_ = str "Js.null" let undefined = str "unit" - let intrinsic = app (str "intrinsic") [string] - let true_ = str "\\\"true\"" - let false_ = str "\\\"false\"" + let intrinsic = str "intrinsic" + let true_ = str "true_" + let false_ = str "false_" // our types let intf tags baseTy = @@ -409,7 +429,7 @@ let private moduleSigImplLines (prefix: string) (isRec: bool) (m: TextModule) = yield head +@ " }" else // make it one liner if possible - if m.content |> List.forall (isMultiLine >> not) && (m.content |> List.sumBy Text.length) < 80 then + if m.content |> List.forall (isMultiLine >> not) && (m.content |> List.sumBy Text.length) < 60 then yield head +@ " " + (concat (str "; ") m.content) +@ " }" else yield head @@ -439,11 +459,14 @@ module Statement = comment result // ReScript doesn't allow exotic names except for get, set, and send. else result - let typeAlias isRec name tyargs ty = - str "type " - + (if isRec then str "rec " else empty) - + (if List.isEmpty tyargs then str name else Type.app (str name) tyargs) - +@ " = " + ty + let typeAlias isRec name tyargs tyOpt = + let lhs = + str "type " + + (if isRec then str "rec " else empty) + + (if List.isEmpty tyargs then str name else Type.app (str name) tyargs) + match tyOpt with + | None -> lhs + | Some ty -> lhs +@ " = " + ty let include_ name = tprintf "include %s" name let open_ name = tprintf "open %s" name @@ -457,7 +480,12 @@ module Statement = | [] -> [] | [m] -> [moduleSig m] | m :: ms -> - moduleSigImpl "module" true m :: (ms |> List.map (moduleSigImpl "and" false)) + let content = moduleSigImpl "module" true m :: (ms |> List.map (moduleSigImpl "and" false)) + // make it one liner if possible + if content |> List.forall (isMultiLine >> not) && (content |> List.sumBy Text.length) < 60 then + [content |> concat (str " ")] + else + [content |> concat newline] let moduleSigNonRec (ms: TextModule list) = ms |> List.map moduleSig diff --git a/src/Targets/ReScript/Target.fs b/src/Targets/ReScript/Target.fs index 2b532d72..aadcaeaa 100644 --- a/src/Targets/ReScript/Target.fs +++ b/src/Targets/ReScript/Target.fs @@ -33,7 +33,7 @@ let private run (input: Input) (ctx: IContext) = let results = let result = if ctx.options.createMinimalStdlib then - [{ baseName = "Ts__min"; res = Text.str stdlib; resi = None }] + [{ baseName = "ts2ocaml"; res = Text.str stdlib; resi = None }] else [] if List.isEmpty input.sources then result else if ctx.options.stdlib then diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 0340ce8d..7f6aea58 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -147,7 +147,7 @@ let anonymousInterfaceToIdentifier (ctx: Context) (a: AnonymousInterface) : text let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (ty: Type) : text = let treatBuiltinTypes (i: Ident) (tyargs: Type list) = - if i.fullName |> List.exists (fun fn -> fn.source.Contains("node_modules/typescript/lib/lib.")) then + if i.fullName |> List.exists (fun fn -> fn.source.Contains("node_modules/typescript/lib/lib")) then let len = List.length tyargs let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.noExternal match i.name with @@ -157,12 +157,10 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C match Type.predefinedTypes |> Map.tryFind name with | Some (ty, arity) when arity = len -> Type.appOpt (str ty) (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) |> Some - (* // This is not really useful. rescript-webapi uses `Webapi.Dom.ClassName.t` format anyway | _ when len = 0 -> match Type.predefinedDOMTypes.TryGetValue(name) with | true, ty -> str ty |> Some | false, _ -> None - *) | _ -> None else None @@ -347,7 +345,7 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte | _ when f.isVariadic -> variadicFallback () | External.Root (_, _) -> Type.curriedArrow (args ()) (retTy flags) | External.Argument _ -> paren ("@uncurry " @+ Type.curriedArrow (args ()) (retTy flags)) - | External.Return _ -> Type.curriedArrow (args ()) (retTy flags) |> Type.id + | External.Return _ -> Type.uncurriedArrow (args ()) (retTy flags) | _ -> Type.curriedArrow (args ()) (retTy flags) |> paren and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (u: UnionType) : text = @@ -799,8 +797,8 @@ let emitTypeAliasesImpl flags overrideFunc (ctx: Context) (typrms: TypeParam list) - (target: text) - (lines: {| name: string; tyargs:(TypeParam * text) list; target: text; isOverload: bool |} -> 'a list) = + (target: text option) + (lines: {| name: string; tyargs:(TypeParam * text) list; target: text option; isOverload: bool |} -> 'a list) = let emitType_ = emitTypeImpl flags overrideFunc let tyargs = typrms |> List.map (fun x -> tprintf "'%s" x.name) [ @@ -822,7 +820,7 @@ let emitTypeAliasesImpl | None -> impossible "emitTypeAliases" | Some t -> yield emitType_ ctx t ] - yield! lines {| name = name; tyargs = List.zip typrms' tyargs'; target = target; isOverload = true |} + yield! lines {| name = name; tyargs = List.zip typrms' tyargs'; target = Some target; isOverload = true |} ] let emitTypeAliases flags overrideFunc ctx (typrms: TypeParam list) target isRec = @@ -982,7 +980,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c if useTags && innerCtx.options.inheritWithTags.HasProvide then let alias = emitTypeAliasesImpl - "tags" flags overrideFunc innerCtx c.typeParams (emitLabels innerCtx labels) + "tags" flags overrideFunc innerCtx c.typeParams (emitLabels innerCtx labels |> Some) (fun x -> [Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target]) |> concat newline alias|> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some @@ -997,7 +995,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c |> between "[> " " ]" Statement.typeAlias false "this" (str "'tags" :: str "'base" :: typrms) - (Type.intf (str "'tags") (Some (str "'base")) +@ " constraint 'tags = " + tags) + (Type.intf (str "'tags") (Some (str "'base")) +@ " constraint 'tags = " + tags |> Some) |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some else None // " this resets the weird syntax highlighting @@ -1025,7 +1023,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c else fallback () let typeDefinition = - let fallback = {| ty = str "private any"; isRec = false |} + let fallback = {| ty = None; isRec = false |} let getSelfTyText (c: Class) = match c.name with | Name name -> @@ -1040,7 +1038,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | Case (_, args) | TagType (_, args) -> args |> List.contains (str "t") ) - {| ty = Type.intf (emitLabels innerCtx labels) baseType; isRec = isRec |} + {| ty = Type.intf (emitLabels innerCtx labels) baseType |> Some; isRec = isRec |} else fallback | ExportDefaultUnnamedClass -> let labels = @@ -1049,7 +1047,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c |> getLabelsFromInheritingTypes flags overrideFunc innerCtx if List.isEmpty labels then fallback else - {| ty = Type.intf (emitLabels innerCtx labels) baseType; isRec = false |} + {| ty = Type.intf (emitLabels innerCtx labels) baseType |> Some; isRec = false |} let selfTyText = match kind with | ClassKind.NormalClass x -> getSelfTyText x.orig @@ -1065,7 +1063,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let origTyText = let tyargs = c.typeParams |> List.map (fun x -> tprintf "'%s" x.name) Type.appOpt (str "t") tyargs - emitTypeAliases flags overrideFunc innerCtx c.typeParams origTyText false + emitTypeAliases flags overrideFunc innerCtx c.typeParams (Some origTyText) false |> List.map (conditional { EmitCondition.empty with onImpl = true }) List.concat [onTypes; onIntf; onImpl] @@ -1229,7 +1227,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu let aritySafety = if ctx.options.safeArity.HasProvide then - Statement.typeAlias false "t_0" [] (str "t") + Statement.typeAlias false "t_0" [] (str "t" |> Some) |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> List.singleton @@ -1282,13 +1280,13 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} | _ -> impossible "emitEnum_parentNode_PolyVariant") - Statement.typeAlias false "t" [] (Type.polyVariant cases) |> TypeDefText |> appendAritySafety - | EnumType.Boolean -> Statement.typeAlias false "t" [] (str "private bool") |> TypeDefText |> appendAritySafety + Statement.typeAlias false "t" [] (Type.polyVariant cases |> Some) |> TypeDefText |> appendAritySafety + | EnumType.Boolean -> Statement.typeAlias false "t" [] (str "private bool" |> Some) |> TypeDefText |> appendAritySafety | EnumType.Float | EnumType.Number -> ctx.logger.warnf "an enum type '%s' contains a case with float or negative value, which is not supported in ReScript at %s" e.name e.loc.AsString [ yield commentStr (sprintf "FIXME: float/negative enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } - yield Statement.typeAlias false "t" [] (str "private float") |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } + yield Statement.typeAlias false "t" [] (str "private float" |> Some) |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } yield! aritySafety ] @@ -1296,7 +1294,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu ctx.logger.warnf "a heterogeneous enum '%s' is not supported at %s" e.name e.loc.AsString [ yield commentStr (sprintf "FIXME: heterogeneous enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } - yield Statement.typeAlias false "t" [] (str "private any") |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } + yield Statement.typeAlias false "t" [] None |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } yield! aritySafety ] @@ -1535,7 +1533,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured knownTypes () |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) let items = - emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target) (fun x -> + emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target |> Some) (fun x -> let a = Statement.typeAlias (isRec && not x.isOverload) x.name (x.tyargs |> List.map snd) x.target |> TypeDefText if x.isOverload then a |> conditional { onTypes = false; onIntf = true; onImpl = true } |> List.singleton else a |> List.singleton @@ -1896,17 +1894,17 @@ let emitStdlib (input: Input) (ctx: IContext) : Output list = let domSrc = srcs |> List.filter (fun src -> src.fileName.Contains("lib.dom") && src.fileName.EndsWith(".d.ts")) - |> mergeSources "lib.dom.d.ts" + |> mergeSources stdlibDomSrc let webworkerSrc = srcs |> List.filter (fun src -> src.fileName.Contains("lib.webworker") && src.fileName.EndsWith(".d.ts")) - |> mergeSources "lib.webworker.d.ts" + |> mergeSources stdlibWebworkerSrc |> fun src -> let statements = src.statements |> Statement.mapIdent (fun i -> i |> Ident.mapSource (fun path -> // webworker does not depend on DOM but fullnames can still refer to it - if path.Contains("lib.dom") && src.fileName.EndsWith(".d.ts") then "lib.webworker.d.ts" + if path.Contains("lib.dom") && src.fileName.EndsWith(".d.ts") then stdlibWebworkerSrc else path ) ) @@ -1959,12 +1957,12 @@ let emitStdlib (input: Input) (ctx: IContext) : Output list = { baseName = baseName; resi = Some resi; res = res } let minLib = - { baseName = "Ts__min"; resi = None; res = str stdlib } + { baseName = "ts2ocaml"; resi = None; res = str stdlib } [ minLib - createOutput "Ts__es" ["Ts__min"] (writerCtx esSrc esCtx) esSrc - createOutput "Ts__dom" ["Ts__min"; "Ts__es"] (writerCtx domSrc domCtx) domSrc - createOutput "Ts__webworker" ["Ts__min"; "Ts__es"] (writerCtx webworkerSrc webworkerCtx) webworkerSrc ] + createOutput "ts2ocaml_es" ["Ts2ocaml"] (writerCtx esSrc esCtx) esSrc + createOutput "ts2ocaml_dom" ["Ts2ocaml"; "Ts2ocaml_es"] (writerCtx domSrc domCtx) domSrc + createOutput "ts2ocaml_webworker" ["Ts2ocaml"; "Ts2ocaml_es"] (writerCtx webworkerSrc webworkerCtx) webworkerSrc ] let emitReferenceTypeDirectives (ctx: Context) (src: SourceFile) : text list = let refs = @@ -2068,8 +2066,8 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: let m = emitModule flags ctx structuredText let opens = [ - yield Statement.open_ "Ts" - yield Statement.open_ "Ts.Dom" + yield Statement.open_ "Ts2ocaml" + yield Statement.open_ "Ts2ocaml_es" for src in sources do yield! emitReferenceTypeDirectives ctx src yield! emitReferenceFileDirectives ctx src diff --git a/test/res/src/Ts.res b/test/res/src/Ts.res deleted file mode 100644 index 097097b7..00000000 --- a/test/res/src/Ts.res +++ /dev/null @@ -1,5 +0,0 @@ -include Ts__min -include Ts__es - -module Dom = Ts__dom -module WebWorker = Ts__webworker \ No newline at end of file diff --git a/test/res/src/main.res b/test/res/src/main.res index e14b7498..91483271 100644 --- a/test/res/src/main.res +++ b/test/res/src/main.res @@ -1,3 +1 @@ -open Ts - -Dom.ConsoleStatic.log([]) \ No newline at end of file +open Ts2ocaml From 6d54734aa9f576c30b63d2f1cc44cb84518aa41a Mon Sep 17 00:00:00 2001 From: cannorin Date: Thu, 1 Sep 2022 20:25:39 +0900 Subject: [PATCH 32/56] Improve QoL (2) - trying to cut off the dependency to ts2ocaml_es --- dist_rescript/src/ts2ocaml.res | 43 +++++++++++++------------- src/Targets/ReScript/ReScriptHelper.fs | 17 +++++----- src/Targets/ReScript/Writer.fs | 29 +++++++++-------- test/res/bsconfig.json | 7 +---- test/res/src/main.res | 6 ++++ test/res/src/placeholders/Iterable.res | 1 + test/res/src/placeholders/Map.res | 1 + test/res/src/placeholders/Set.res | 1 + test/res/src/placeholders/WeakMap.res | 1 + test/res/src/placeholders/WeakSet.res | 1 + 10 files changed, 57 insertions(+), 50 deletions(-) create mode 100644 test/res/src/placeholders/Iterable.res create mode 100644 test/res/src/placeholders/Map.res create mode 100644 test/res/src/placeholders/Set.res create mode 100644 test/res/src/placeholders/WeakMap.res create mode 100644 test/res/src/placeholders/WeakSet.res diff --git a/dist_rescript/src/ts2ocaml.res b/dist_rescript/src/ts2ocaml.res index 6162778a..5edbc745 100644 --- a/dist_rescript/src/ts2ocaml.res +++ b/dist_rescript/src/ts2ocaml.res @@ -200,25 +200,24 @@ module NewableVariadic = { let applyN = (fn: tn<'args, 'variadic, 't>, args: 'args, variadic: 'variadic) : 't => %raw(`new fn(...args, ...variadic)`) } -/* -type partial<'t> = 't -type required<'t> = 't -type readonly<'t> = 't -type pick<'t, 'keys> = 't -type record<'keys, 't> = Js.Dict.t<'t> -type exclude<'t, 'u> = 't -type extract<'t, 'u> = 't -type omit<'t, 'keys> = 't -type nonNullable<'t> = 't -type parameters<'t> = any -type constructorParameters<'t> = any -type returnType<'t> = any -type instanceType<'t> = any -type thisParameterType<'t> = any -type omitThisParameter<'t> = any -type thisType<'t> = any -type uppercase<'s> = intrinsic -type lowercase<'s> = intrinsic -type capitalize<'s> = intrinsic -type uncapitalize<'s> = intrinsic -*/ \ No newline at end of file +// utility type fallbacks +module Partial = { type t<'a> = 'a } +module Required = { type t<'a> = 'a } +module Readonly = { type t<'a> = 'a } +module Pick = { type t<'a, 'keys> = 'a } +module Record = { type t<'keys, 'a> = Js.Dict.t<'a> } +module Exclude = { type t<'a, 'b> = 'a } +module Extract = { type t<'a, 'b> = 'a } +module Omit = { type t<'a, 'keys> = 'a } +module NonNullable = { type t<'a> = 'a } +module Parameters = { type t<'a> } +module ConstructorParameters = { type t<'a> } +module ReturnType = { type t<'a> } +module InstanceType = { type t<'a> } +module ThisParameterType = { type t<'a> } +module OmitThisParameter = { type t<'a> } +module ThisType = { type t<'a> } +module Uppercase = { type t<'s> = private intrinsic } +module Lowercase = { type t<'s> = private intrinsic } +module Capitalize = { type t<'s> = private intrinsic } +module Uncapitalize = { type t<'s> = private intrinsic } \ No newline at end of file diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 9235cb3d..89821985 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -202,17 +202,16 @@ module Type = /// non-primitive types defined in the standard library let predefinedTypes = let builtins = [ - "RegExp", ("Js.Re.t", 0) - "Date", ("Js.Date.t", 0) - "Promise", ("Js.Promise.t", 1) - "PromiseLike", ("Js.Promise.t", 1) - "Array", ("Js.Array.t", 1) - "ArrayLike", ("Js.TypedArray2.array_like", 1) - "ArrayBuffer", ("Js.TypedArray2.array_buffer", 0) - "Error", ("Js.Exn.t", 0) + "RegExp", ("Re.t", 0) + "PromiseLike", ("Promise.t", 1) + "Array", ("array", 1) + "ArrayLike", ("Array2.array_like", 1) + "ReadonlyArray", ("array", 1) + "ArrayBuffer", ("TypedArray2.ArrayBuffer.t", 0) + "Error", ("Exn.t", 0) ] let typedArrays = - let typedArray name = name, (sprintf "Js.TypedArray2.%s.t" name, 0) + let typedArray name = name, (sprintf "TypedArray2.%s.t" name, 0) [ typedArray "DataView" typedArray "Int8Array" diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 7f6aea58..f1524abd 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -147,21 +147,24 @@ let anonymousInterfaceToIdentifier (ctx: Context) (a: AnonymousInterface) : text let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (ty: Type) : text = let treatBuiltinTypes (i: Ident) (tyargs: Type list) = - if i.fullName |> List.exists (fun fn -> fn.source.Contains("node_modules/typescript/lib/lib")) then + let contains path = i.fullName |> List.exists (fun fn -> fn.source.Contains(path)) + if contains "node_modules/typescript/lib/lib" then let len = List.length tyargs let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.noExternal + let emitWith ty = Type.appOpt (str ty) (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) |> Some match i.name with | _ when ctx.options.stdlib -> None | [] | _ :: _ :: _ -> None - | name :: [] -> + | [name] -> match Type.predefinedTypes |> Map.tryFind name with - | Some (ty, arity) when arity = len -> - Type.appOpt (str ty) (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) |> Some - | _ when len = 0 -> - match Type.predefinedDOMTypes.TryGetValue(name) with - | true, ty -> str ty |> Some - | false, _ -> None - | _ -> None + | Some (ty, arity) when arity = len -> emitWith ty + | _ -> + if contains "lib.es" then emitWith (sprintf "%s.t" name) + else if contains "lib.dom" || contains "lib.webworker" then + match Type.predefinedDOMTypes.TryGetValue(name) with + | true, ty -> emitWith ty + | _, _ -> None + else None else None let treatIdent (i: Ident) (tyargs: Type list) (loc: Location) = @@ -1960,9 +1963,9 @@ let emitStdlib (input: Input) (ctx: IContext) : Output list = { baseName = "ts2ocaml"; resi = None; res = str stdlib } [ minLib - createOutput "ts2ocaml_es" ["Ts2ocaml"] (writerCtx esSrc esCtx) esSrc - createOutput "ts2ocaml_dom" ["Ts2ocaml"; "Ts2ocaml_es"] (writerCtx domSrc domCtx) domSrc - createOutput "ts2ocaml_webworker" ["Ts2ocaml"; "Ts2ocaml_es"] (writerCtx webworkerSrc webworkerCtx) webworkerSrc ] + createOutput "ts2ocaml_es" ["Js"; "Ts2ocaml"] (writerCtx esSrc esCtx) esSrc + createOutput "ts2ocaml_dom" ["Js"; "Ts2ocaml"; "Ts2ocaml_es"] (writerCtx domSrc domCtx) domSrc + createOutput "ts2ocaml_webworker" ["Js"; "Ts2ocaml"; "Ts2ocaml_es"] (writerCtx webworkerSrc webworkerCtx) webworkerSrc ] let emitReferenceTypeDirectives (ctx: Context) (src: SourceFile) : text list = let refs = @@ -2066,8 +2069,8 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: let m = emitModule flags ctx structuredText let opens = [ + yield Statement.open_ "Js" yield Statement.open_ "Ts2ocaml" - yield Statement.open_ "Ts2ocaml_es" for src in sources do yield! emitReferenceTypeDirectives ctx src yield! emitReferenceFileDirectives ctx src diff --git a/test/res/bsconfig.json b/test/res/bsconfig.json index 67357883..38340e3e 100644 --- a/test/res/bsconfig.json +++ b/test/res/bsconfig.json @@ -9,10 +9,5 @@ "module": "commonjs", "in-source": true }, - "suffix": ".bs.js", - "bs-dependencies": [ - ], - "warnings": { - "error" : "+101" - } + "suffix": ".bs.js" } diff --git a/test/res/src/main.res b/test/res/src/main.res index 91483271..165395f2 100644 --- a/test/res/src/main.res +++ b/test/res/src/main.res @@ -1 +1,7 @@ open Ts2ocaml + +let tsVersion = Typescript.Ts.version + +let x = Prop_types.ElementStatic.isRequired + +let y = Scheduler__tracing.__interactionsRef \ No newline at end of file diff --git a/test/res/src/placeholders/Iterable.res b/test/res/src/placeholders/Iterable.res new file mode 100644 index 00000000..9bbaf1d1 --- /dev/null +++ b/test/res/src/placeholders/Iterable.res @@ -0,0 +1 @@ +type t<'a> \ No newline at end of file diff --git a/test/res/src/placeholders/Map.res b/test/res/src/placeholders/Map.res new file mode 100644 index 00000000..77030897 --- /dev/null +++ b/test/res/src/placeholders/Map.res @@ -0,0 +1 @@ +type t<'k, 'v> \ No newline at end of file diff --git a/test/res/src/placeholders/Set.res b/test/res/src/placeholders/Set.res new file mode 100644 index 00000000..9bbaf1d1 --- /dev/null +++ b/test/res/src/placeholders/Set.res @@ -0,0 +1 @@ +type t<'a> \ No newline at end of file diff --git a/test/res/src/placeholders/WeakMap.res b/test/res/src/placeholders/WeakMap.res new file mode 100644 index 00000000..77030897 --- /dev/null +++ b/test/res/src/placeholders/WeakMap.res @@ -0,0 +1 @@ +type t<'k, 'v> \ No newline at end of file diff --git a/test/res/src/placeholders/WeakSet.res b/test/res/src/placeholders/WeakSet.res new file mode 100644 index 00000000..9bbaf1d1 --- /dev/null +++ b/test/res/src/placeholders/WeakSet.res @@ -0,0 +1 @@ +type t<'a> \ No newline at end of file From a6f6124ea639a6a3e358cd58de761711533d3ec4 Mon Sep 17 00:00:00 2001 From: cannorin Date: Fri, 2 Sep 2022 19:38:00 +0900 Subject: [PATCH 33/56] Smart safe arity --- build/build.fs | 2 +- src/Targets/ReScript/Common.fs | 10 ------- src/Targets/ReScript/Writer.fs | 51 +++++++++------------------------- 3 files changed, 14 insertions(+), 49 deletions(-) diff --git a/build/build.fs b/build/build.fs index cbd1c682..e60117aa 100644 --- a/build/build.fs +++ b/build/build.fs @@ -182,7 +182,7 @@ module Test = "safe", !! "node_modules/@types/yargs-parser/index.d.ts", []; "safe", !! "node_modules/@types/yargs/index.d.ts", []; - "minimal", !! "node_modules/@types/vscode/index.d.ts", ["--safe-arity=full"; "--readable-names"]; + "minimal", !! "node_modules/@types/vscode/index.d.ts", ["--readable-names"]; ] for preset, package, additionalOptions in packages do diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 8177106a..02e4c855 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -77,7 +77,6 @@ type Options = abstract numberAsInt: bool with get, set abstract subtyping: Subtyping list with get, set abstract inheritWithTags: FeatureFlag with get, set - abstract safeArity: FeatureFlag with get, set abstract simplify: Simplify list with get, set abstract readableNames: bool with get, set @@ -102,8 +101,6 @@ module Options = opts.simplify <- [Simplify.All] if p = Preset.Safe || p = Preset.Full then - if opts.safeArity = FeatureFlag.Default then - opts.safeArity <- FeatureFlag.Full if subtypingIsDefault then opts.subtyping <- Subtyping.CastFunction :: opts.subtyping @@ -211,17 +208,10 @@ module Options = .group( !^ResizeArray[ - "safe-arity"; "simplify"; "human-readable-anonymous-interface-names"; ], "Code Generator Options:") - .addChoice( - "safe-arity", - FeatureFlag.Values, - (fun (o: Options) -> o.safeArity), - descr="Use `TypeName.t_n` type names to safely use overloaded types from other packages.", - defaultValue=FeatureFlag.Default) .addCommaSeparatedStringSet( "simplify", Simplify.TryParse, diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index f1524abd..f345a0a3 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -189,9 +189,9 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C let tyName = let fallback () = let tyName = - match ctx.options.safeArity with - | FeatureFlag.Full | FeatureFlag.Consume -> Naming.createTypeNameOfArity arity None "t" - | _ -> "t" + if Option.isSome i.misc.maxArity then + Naming.createTypeNameOfArity arity i.misc.maxArity "t" + else "t" Naming.structured Naming.moduleName i.name + "." + tyName |> str match i.name with | [name] -> @@ -396,13 +396,12 @@ and emitLabelsBody (ctx: Context) labels = and getLabelsFromInheritingTypes (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (inheritingTypes: Set) = let emitType_ = emitTypeImpl flags overrideFunc let createCase name args = Case (str (Naming.constructorName name), args) - let createTagType name args = + let createTagType name args maxArity = let arity = List.length args let tagTypeName = - if ctx.options.safeArity.HasConsume then - Naming.createTypeNameOfArity arity None "tags" - else - "tags" + if Option.isSome maxArity then + Naming.createTypeNameOfArity arity maxArity "tags" + else "tags" let ty = Naming.structured Naming.moduleName name + "." + tagTypeName let args = args |> List.map (emitType_ ctx) TagType (str ty, args) @@ -412,7 +411,7 @@ and getLabelsFromInheritingTypes (flags: EmitTypeFlags) (overrideFunc: OverrideF | InheritingType.KnownIdent i -> yield createCase i.fullName.name (i.tyargs |> List.map (emitType_ ctx)) | InheritingType.UnknownIdent i -> - yield createTagType i.name i.tyargs + yield createTagType i.name i.tyargs i.maxArity | InheritingType.Prim (p, ts) -> match p.AsJSClassName with | Some name -> @@ -809,7 +808,7 @@ let emitTypeAliasesImpl let arities = getPossibleArity typrms let maxArity = List.length tyargs for arity in arities |> Set.toSeq |> Seq.sortDescending do - if arity <> maxArity || ctx.options.safeArity.HasProvide then + if arity <> maxArity then let name = Naming.createTypeNameOfArity arity None baseName let tyargs' = List.take arity tyargs let typrms' = List.take arity typrms @@ -856,7 +855,7 @@ let add name node current = current |> Trie.addOrUpdate name node StructuredText let getExportFromStatement (ctx: Context) (name: string) (kind: Kind list) (kindString: string) (s: Statement) : ExportItem option = let fn = ctx |> Context.getFullName [name] - let ident = { name = [name]; fullName = [fn]; kind = Some (Set.ofList kind); parent = None; loc = s.loc } + let ident = { name = [name]; fullName = [fn]; kind = Some (Set.ofList kind); parent = None; loc = s.loc; misc = IdentMiscData.Internal } match s.isExported.AsExport ident with | None -> None | Some clause -> @@ -879,7 +878,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c match c.name with | Choice1Of2 (Name n) -> let k = ctx |> Context.getFullName [n] - let ident = { name = [n]; fullName = [k]; kind = Some (Set.ofList Kind.OfClass); parent = None; loc = UnknownLocation } + let ident = { name = [n]; fullName = [k]; kind = Some (Set.ofList Kind.OfClass); parent = None; loc = UnknownLocation; misc = IdentMiscData.Internal } let selfTy = if List.isEmpty c.typeParams then Ident ident else App (AIdent ident, typrms, UnknownLocation) @@ -928,11 +927,6 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | ClassKind.NormalClass x -> Context.ofChildNamespace x.name | ClassKind.AnonymousInterface x -> Context.ofChildNamespace x.name | ClassKind.ExportDefaultClass _ -> id) - |> Context.mapOptions (fun options -> - if not isAnonymous then options - else - // no need to generate t_n types for anonymous interfaces - ctx.options |> JS.cloneWith (fun o -> o.safeArity <- o.safeArity.WithProvide(false))) let typrms = List.map (fun (tp: TypeParam) -> tprintf "'%s" tp.name) c.typeParams let selfTyText = Type.appOpt (str "t") typrms let currentNamespace = innerCtx |> Context.getFullName [] @@ -1228,19 +1222,6 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu | [EnumType.Int; EnumType.String] -> EnumType.PolyVariant | _ -> EnumType.Heterogeneous - let aritySafety = - if ctx.options.safeArity.HasProvide then - Statement.typeAlias false "t_0" [] (str "t" |> Some) - |> TypeDefText - |> conditional { onIntf = true; onImpl = true; onTypes = false } - |> List.singleton - else [] - let appendAritySafety x = [ - yield x |> conditional { EmitCondition.all with onImpl = false } - yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } - yield! aritySafety - ] - let child (c: EnumCase) = let ty = match enumType with @@ -1273,7 +1254,6 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu [ yield str "type t = " + casesText |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } yield str "type t = t = " + casesText |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } - yield! aritySafety ] | EnumType.Int | EnumType.String | EnumType.PolyVariant -> let cases = @@ -1283,15 +1263,14 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} | _ -> impossible "emitEnum_parentNode_PolyVariant") - Statement.typeAlias false "t" [] (Type.polyVariant cases |> Some) |> TypeDefText |> appendAritySafety - | EnumType.Boolean -> Statement.typeAlias false "t" [] (str "private bool" |> Some) |> TypeDefText |> appendAritySafety + Statement.typeAlias false "t" [] (Type.polyVariant cases |> Some) |> TypeDefText |> List.singleton + | EnumType.Boolean -> Statement.typeAlias false "t" [] (str "private bool" |> Some) |> TypeDefText |> List.singleton | EnumType.Float | EnumType.Number -> ctx.logger.warnf "an enum type '%s' contains a case with float or negative value, which is not supported in ReScript at %s" e.name e.loc.AsString [ yield commentStr (sprintf "FIXME: float/negative enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } yield Statement.typeAlias false "t" [] (str "private float" |> Some) |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } - yield! aritySafety ] | _ -> ctx.logger.warnf "a heterogeneous enum '%s' is not supported at %s" e.name e.loc.AsString @@ -1299,7 +1278,6 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu yield commentStr (sprintf "FIXME: heterogeneous enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } yield Statement.typeAlias false "t" [] None |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } - yield! aritySafety ] let items = items @ List.map child e.cases let comments = e.comments |> emitComments @@ -1727,13 +1705,11 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) let attrs = scopeToAttr currentScope [Attr.External.val_] let intf = [ yield str $"type t = {e.ty}" - if ctx.options.safeArity.HasProvide then yield str "type t0 = t" yield Statement.external attrs "value" (str "t") e.name ] let impl = [ yield Statement.open_ moduleName yield str "type t = t" - if ctx.options.safeArity.HasProvide then yield str "type t0 = t" yield Statement.external attrs "value" (str "t") e.name ] let m content = {| name = moduleName; origName = e.name; content = content; comments = emitComments e.comments |} @@ -1919,7 +1895,6 @@ let emitStdlib (input: Input) (ctx: IContext) : Output list = let opts = ctx.options opts.simplify <- [Simplify.All] opts.inheritWithTags <- FeatureFlag.Full - opts.safeArity <- FeatureFlag.Full opts.subtyping <- [Subtyping.Tag] let flags : EmitModuleFlags = From 01eefd1f9a44e20a59fb2ab9d2ae552c108e68a4 Mon Sep 17 00:00:00 2001 From: cannorin Date: Thu, 15 Sep 2022 19:52:05 +0900 Subject: [PATCH 34/56] Reintroduce SCC sorting --- build/build.fs | 3 +- dist_rescript/src/ts2ocaml.res | 8 +- src/Targets/ReScript/Common.fs | 16 +-- src/Targets/ReScript/ReScriptHelper.fs | 57 +++++--- src/Targets/ReScript/Target.fs | 4 +- src/Targets/ReScript/Writer.fs | 173 ++++++------------------- 6 files changed, 86 insertions(+), 175 deletions(-) diff --git a/build/build.fs b/build/build.fs index e60117aa..df04beff 100644 --- a/build/build.fs +++ b/build/build.fs @@ -164,8 +164,7 @@ module Test = let ts2res args files = Yarn.exec (sprintf "ts2ocaml res %s" (String.concat " " (Seq.append args files))) id - ts2res ["--verbose"; "--nowarn"; "--stdlib"; $"-o {outputDir}"] <| - !! "node_modules/typescript/lib/lib.*.d.ts" + ts2res ["--create-stdlib"; $"-o {outputDir}"] [] let packages = [ // "full" package involving a lot of inheritance diff --git a/dist_rescript/src/ts2ocaml.res b/dist_rescript/src/ts2ocaml.res index 5edbc745..96ef8d18 100644 --- a/dist_rescript/src/ts2ocaml.res +++ b/dist_rescript/src/ts2ocaml.res @@ -79,13 +79,7 @@ module Intersection = { type t8<'t1, 't2, 't3, 't4, 't5, 't6, 't7, 't8> = container<[ #I1('t1) | #I2('t2) | #I3('t3) | #I4('t4) | #I5('t5) | #I6('t6) | #I7('t7) | #I8('t8) ]> } -module Interface = { - @unboxed type t<-'tags, 'base> = { value: 'base } - - let value = (x: t<_, _>) => x.value -} -type intf<-'tags, 'base> = Interface.t<'tags, 'base> -type intf'<-'tags> = intf<'tags, any> +type intf<-'tags> module Primitive = { type cases<'other> = [ #Null | #Undefined | #String(string) | #Number(float) | #Boolean(bool) | #Symbol(symbol) | #BigInt(bigint) | #Other('other) ] diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 02e4c855..a70bc1db 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -65,8 +65,7 @@ type Options = inherit Typer.TyperOptions // general options abstract preset: Preset option with get - abstract createMinimalStdlib: bool with get - abstract stdlib: bool with get // hidden + abstract createStdlib: bool with get // JS options abstract ``module``: ModuleKind with get abstract name: string option with get @@ -122,21 +121,16 @@ module Options = yargs .group( !^ResizeArray[ - "create-minimal-stdlib"; "stdlib"; "preset" + "create-stdlib"; "preset" ], "General Options:" ) .addFlag( - "create-minimal-stdlib", - (fun (o:Options) -> o.createMinimalStdlib), - descr="Create ts2ocaml_min.mli. When this option is used, most of the other options are ignored.", + "create-stdlib", + (fun (o:Options) -> o.createStdlib), + descr="Create ts2ocaml.res.", defaultValue=false ) - .addFlag( - "stdlib", - (fun (o: Options) -> o.stdlib), - descr = "Internal. Used to generate Ts2ocaml.mli from typescript/lib/lib.*.d.ts." - ).hide("stdlib") .addChoice( "preset", Preset.Values, diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 89821985..b5a965b3 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -340,10 +340,7 @@ module Type = let false_ = str "false_" // our types - let intf tags baseTy = - match baseTy with - | Some t -> app (str "intf") [tags; t] - | None -> app (str "intf'") [tags] + let intf tags = app (str "intf") [tags] let prim cases = app (str "prim") [cases] let rec union = function @@ -416,24 +413,26 @@ module Term = type TextModule = {| name: string; origName: string; content: text list; comments: text list |} +let private moduleSigImplBody head oneliner (m: TextModule) = + if List.isEmpty m.content then [ head +@ "{ }" ] + else if oneliner then + [ head +@ "{ " + (concat (str "; ") m.content) +@ " }"] + else [ + yield head + str "{" + yield indent (concat newline m.content) + yield str "}" + ] + let private moduleSigImplLines (prefix: string) (isRec: bool) (m: TextModule) = + let oneliner = + m.content |> List.forall (isMultiLine >> not) && (m.content |> List.sumBy Text.length) < 60 + let head = + tprintf "%s %s%s : " + prefix + (if isRec then "rec " else "") + m.name [ yield! m.comments - let isEmpty = List.isEmpty m.content - let head = - tprintf "%s %s%s : {" - prefix - (if isRec then "rec " else "") - m.name - if isEmpty then - yield head +@ " }" - else - // make it one liner if possible - if m.content |> List.forall (isMultiLine >> not) && (m.content |> List.sumBy Text.length) < 60 then - yield head +@ " " + (concat (str "; ") m.content) +@ " }" - else - yield head - yield indent (concat newline m.content) - yield str "}" ] + yield! moduleSigImplBody head oneliner m ] let private moduleSigImpl (prefix: string) (isRec: bool) (m: TextModule) = moduleSigImplLines prefix isRec m |> concat newline @@ -503,4 +502,20 @@ module Statement = yield tprintf "module rec %s : {" name yield indent (concat newline content) yield tprintf "} = %s" name - ] \ No newline at end of file + ] + + let moduleSCC (dt: DependencyTrie) emitRec emitNonRec (ctx: Typer.TyperContext<_, _>) = + let scc = dt |> Trie.tryFind ctx.currentNamespace |? [] + let sccSet = scc |> List.concat |> Set.ofList + fun (modules: TextModule list) -> + let modulesMap = modules |> List.fold (fun state x -> state |> Map.add x.origName x) Map.empty + let sccModules = + scc + |> List.map (fun group -> + group |> List.choose (fun name -> modulesMap |> Map.tryFind name) |> emitRec) + |> List.concat + let otherModules = + modules + |> List.filter (fun x -> sccSet |> Set.contains x.origName |> not) + |> emitNonRec + sccModules @ otherModules \ No newline at end of file diff --git a/src/Targets/ReScript/Target.fs b/src/Targets/ReScript/Target.fs index aadcaeaa..3bcf2ac2 100644 --- a/src/Targets/ReScript/Target.fs +++ b/src/Targets/ReScript/Target.fs @@ -32,12 +32,10 @@ let private run (input: Input) (ctx: IContext) = let results = let result = - if ctx.options.createMinimalStdlib then + if ctx.options.createStdlib then [{ baseName = "ts2ocaml"; res = Text.str stdlib; resi = None }] else [] if List.isEmpty input.sources then result - else if ctx.options.stdlib then - result @ emitStdlib input ctx else result @ emit input ctx diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index f345a0a3..d8462597 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -13,10 +13,6 @@ open Fable.Core.JsInterop open Targets.ReScript.Common open Targets.ReScript.ReScriptHelper -let [] stdlibEsSrc = "lib.es.d.ts" -let [] stdlibDomSrc = "lib.dom.d.ts" -let [] stdlibWebworkerSrc = "lib.webworker.d.ts" - let impossibleNone msgf (x: 'a option) = match x with None -> failwith ("impossible (not None): " + msgf ()) | Some x -> x @@ -153,7 +149,6 @@ let rec emitTypeImpl (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: C let flagsForArgs = { flags with needParen = true } |> EmitTypeFlags.noExternal let emitWith ty = Type.appOpt (str ty) (tyargs |> List.map (emitTypeImpl flagsForArgs overrideFunc ctx)) |> Some match i.name with - | _ when ctx.options.stdlib -> None | [] | _ :: _ :: _ -> None | [name] -> match Type.predefinedTypes |> Map.tryFind name with @@ -531,6 +526,7 @@ and StructuredTextNode = {| comments: text list exports: ExportItem list openTypesModule: bool + knownTypes: Set anonymousInterfaces: Set |} @@ -540,7 +536,8 @@ let inline conditional cond x = Conditional (x, cond) module StructuredTextNode = let empty : StructuredTextNode = - {| scope = Scope.Default; items = []; comments = []; exports = []; anonymousInterfaces = Set.empty; openTypesModule = true |} + {| scope = Scope.Default; items = []; comments = []; exports = []; knownTypes = Set.empty; anonymousInterfaces = Set.empty; openTypesModule = true |} + let union (a: StructuredTextNode) (b: StructuredTextNode) : StructuredTextNode = let mergeScope s1 s2 = match s1, s2 with @@ -551,8 +548,18 @@ module StructuredTextNode = comments = List.append a.comments b.comments exports = List.append a.exports b.exports openTypesModule = a.openTypesModule || b.openTypesModule + knownTypes = Set.union a.knownTypes b.knownTypes anonymousInterfaces = Set.union a.anonymousInterfaces b.anonymousInterfaces |} + let getReferences (ctx: Context) (v: StructuredTextNode) : WeakTrie = + v.knownTypes + |> Set.fold (fun state -> function + | KnownType.Ident fn when fn.source = ctx.currentSourceFile -> state |> WeakTrie.add fn.name + | KnownType.AnonymousInterface (_, i) -> + state |> WeakTrie.add (i.namespace_ @ [anonymousInterfaceModuleName ctx i]) + | _ -> state + ) WeakTrie.empty + module StructuredText = let pp (x: StructuredText) = let rec go (x: StructuredText) = @@ -949,7 +956,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let polymorphicThis = if useTags then - Type.appOpt (str "this") (str "'tags" :: str "'base" :: typrms) + Type.appOpt (str "this") (str "'tags" :: typrms) else selfTyText @@ -991,34 +998,12 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c |> emitLabelsBody innerCtx |> between "[> " " ]" Statement.typeAlias false "this" - (str "'tags" :: str "'base" :: typrms) - (Type.intf (str "'tags") (Some (str "'base")) +@ " constraint 'tags = " + tags |> Some) + (str "'tags" :: typrms) + (Type.intf (str "'tags") +@ " constraint 'tags = " + tags |> Some) |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some else None // " this resets the weird syntax highlighting - let baseType, baseTypeDefinition = - let fallback () = - // TODO - None, [] - match kind with - | ClassKind.ExportDefaultClass _ | ClassKind.AnonymousInterface _ -> fallback () - | ClassKind.NormalClass x -> - if not innerCtx.options.stdlib then fallback () - else if innerCtx.currentSourceFile = stdlibEsSrc then - match Type.predefinedTypes |> Map.tryFind x.name with - | Some (t, arity) -> - match c.typeParams |> matchArity arity with - | None -> fallback () - | Some typrms -> - Some (Type.appOpt (str t) (typrms |> List.map (fun tp -> tprintf "'%s" tp.name))), [] - | None -> fallback () - else if innerCtx.currentSourceFile = stdlibDomSrc then - match Type.predefinedDOMTypes.TryGetValue(x.name) with - | true, t -> Some (str t), [] - | false, _ -> fallback () - else fallback () - let typeDefinition = let fallback = {| ty = None; isRec = false |} let getSelfTyText (c: Class) = @@ -1035,7 +1020,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | Case (_, args) | TagType (_, args) -> args |> List.contains (str "t") ) - {| ty = Type.intf (emitLabels innerCtx labels) baseType |> Some; isRec = isRec |} + {| ty = Type.intf (emitLabels innerCtx labels) |> Some; isRec = isRec |} else fallback | ExportDefaultUnnamedClass -> let labels = @@ -1044,7 +1029,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c |> getLabelsFromInheritingTypes flags overrideFunc innerCtx if List.isEmpty labels then fallback else - {| ty = Type.intf (emitLabels innerCtx labels) baseType |> Some; isRec = false |} + {| ty = Type.intf (emitLabels innerCtx labels) |> Some; isRec = false |} let selfTyText = match kind with | ClassKind.NormalClass x -> getSelfTyText x.orig @@ -1111,7 +1096,6 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c binding (fun rename _ -> builder (rename "make") fields selfTyText) let items = [ - yield! baseTypeDefinition yield! typeDefinition yield! tagsDefinition |> Option.toList yield! polymorphicThisDefinition |> Option.toList @@ -1120,7 +1104,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c yield! castFunctions ] - {| StructuredTextNode.empty with items = items; comments = comments; scope = scope |} + {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes; scope = scope |} let export = match kind with @@ -1153,7 +1137,7 @@ and addAnonymousInterfaceExcluding emitTypeFlags (ctx: Context) knownTypes ais ( let shouldSkip = current.value |> Option.map (fun v -> v.anonymousInterfaces |> Set.contains a) - |> Option.defaultValue false + |? false if shouldSkip then current else emitClass emitTypeFlags OverrideFunc.noOverride ctx current (a.MapName Choice2Of2) ((fun _ _ _ -> []), Set.empty, None) @@ -1484,7 +1468,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured match s with | Namespace m -> let module' = - let node = {| StructuredTextNode.empty with comments = comments; scope = Scope.Default |} + let node = {| StructuredTextNode.empty with comments = comments; scope = Scope.Default; knownTypes = knownTypes () |} let module' = current |> getTrie [m.name] |> set node let ctx = ctx |> Context.ofChildNamespace m.name m.statements |> List.fold (folder ctx) module' @@ -1494,7 +1478,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Some _ -> current |> addExport m.name Kind.OfNamespace "namespace" | AmbientModule m -> let module' = - let node = {| StructuredTextNode.empty with comments = comments; scope = Scope.Module m.name.unquoted |} + let node = {| StructuredTextNode.empty with comments = comments; scope = Scope.Module m.name.unquoted; knownTypes = knownTypes () |} let module' = current |> getTrie [m.name.orig] |> set node let ctx = ctx |> Context.ofChildNamespace m.name.orig m.statements |> List.fold (folder ctx) module' @@ -1510,16 +1494,16 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured emitEnum emitTypeFlags OverrideFunc.noOverride ctx current e | TypeAlias ta -> let ctx = ctx |> Context.ofChildNamespace ta.name + let knownTypes = knownTypes () let isRec = - knownTypes () - |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) + knownTypes |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) let items = emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target |> Some) (fun x -> let a = Statement.typeAlias (isRec && not x.isOverload) x.name (x.tyargs |> List.map snd) x.target |> TypeDefText if x.isOverload then a |> conditional { onTypes = false; onIntf = true; onImpl = true } |> List.singleton else a |> List.singleton ) - let node = {| StructuredTextNode.empty with items = items; comments = comments |} + let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes |} current |> inTrie [ta.name] (set node) |> addExport ta.name Kind.OfTypeAlias "type" @@ -1540,7 +1524,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] let createModule () = let items = intfToStmts intf (ctx |> Context.ofChildNamespace value.name) emitTypeFlags overrideFunc - {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name; openTypesModule = false |} + {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name; knownTypes = knownTypesInMembers; openTypesModule = false |} if knownTypesInMembers |> Set.contains (KnownType.Ident (ctx |> Context.getFullName [intfName])) then fallback current else @@ -1554,16 +1538,19 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Function func -> let node = {| StructuredTextNode.empty with - items = emitFunction emitTypeFlags overrideFunc ctx func |} + items = emitFunction emitTypeFlags overrideFunc ctx func + knownTypes = knownTypes () |} current |> set node |> addExport func.name Kind.OfValue "function" |> addAnonymousInterface | Variable value -> + let knownTypes = knownTypes () let fallback current = let node = {| StructuredTextNode.empty with - items = emitVariable emitTypeFlags overrideFunc ctx value |} + items = emitVariable emitTypeFlags overrideFunc ctx value + knownTypes = knownTypes |} current |> set node |> addExport value.name Kind.OfValue (if value.isConst then "const" else "let") @@ -1578,6 +1565,8 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured {| StructuredTextNode.empty with items = items scope = Scope.Path value.name + knownTypes = + knownTypes |> Set.filter (function KnownType.AnonymousInterface (ai, _) -> ai.loc <> intf.loc | _ -> true) openTypesModule = false |}) |> addExport value.name Kind.OfClass (if value.isConst then "const" else "let") |> inTrie [value.name] (addAnonymousInterfaceExcluding [intf]) @@ -1594,7 +1583,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypesInMembers = Statement.getKnownTypes ctx [Class intf] let createModule () = let items = intfToStmts intf ctx emitTypeFlags overrideFunc - {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name; openTypesModule = false |} + {| StructuredTextNode.empty with items = items; scope = Scope.Path value.name; knownTypes = knownTypesInMembers; openTypesModule = false |} current |> inTrie [name] (set (createModule ())) |> addExport name Kind.OfClass (if value.isConst then "const" else "let") @@ -1654,7 +1643,7 @@ module EmitModuleResult = let empty : EmitModuleResult = {| imports = []; types = []; impl = []; intf = []; comments = [] |} -let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) : EmitModuleResult = +let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (dt: DependencyTrie) (st: StructuredText) : EmitModuleResult = let renamer = new OverloadRenamer() let children = st.children @@ -1685,7 +1674,7 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) | Scope.Ignore -> flags.scopeRev, flags.jsModule let flags = {| flags with scopeRev = scopeRev; jsModule = jsModule |} let ctx = ctx |> Context.ofChildNamespace k - let result = emitModule flags ctx v + let result = emitModule flags ctx dt v let openTypesModule = if flags.isReservedModule then false else @@ -1737,7 +1726,8 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) children |> List.filter (fun (_, _, c) -> c.types |> List.isEmpty |> not) |> List.map (fun (k, _, c) -> {| k with content = c.imports @ c.types; comments = [] |}) - |> Statement.moduleSigRec + // |> Statement.moduleSigRec + |> Statement.moduleSCC dt Statement.moduleSigRec Statement.moduleSigNonRec ctx children @ items let exports = @@ -1841,7 +1831,7 @@ and emitExportModule (ctx: Context) (exports: ExportItem list) : EmitModuleResul go isFirst acc rest let st = go true Trie.empty exports - st |> emitModule {| isReservedModule = true; jsModule = None; scopeRev = [] |} ctx + st |> emitModule {| isReservedModule = true; jsModule = None; scopeRev = [] |} ctx Trie.empty let header = [ str "@@warning(\"-27-32-33-44\")" @@ -1862,86 +1852,6 @@ let emitTypes (types: text list) : text list = Statement.open_ "Types" ] -let emitStdlib (input: Input) (ctx: IContext) : Output list = - let srcs = input.sources - - ctx.logger.tracef "* looking up the minimal supported ES version for each definition..." - let esSrc = - srcs - |> List.filter (fun src -> src.fileName.Contains("lib.es") && src.fileName.EndsWith(".d.ts")) - |> mergeESLibDefinitions - let domSrc = - srcs - |> List.filter (fun src -> src.fileName.Contains("lib.dom") && src.fileName.EndsWith(".d.ts")) - |> mergeSources stdlibDomSrc - let webworkerSrc = - srcs - |> List.filter (fun src -> src.fileName.Contains("lib.webworker") && src.fileName.EndsWith(".d.ts")) - |> mergeSources stdlibWebworkerSrc - |> fun src -> - let statements = - src.statements |> Statement.mapIdent (fun i -> - i |> Ident.mapSource (fun path -> - // webworker does not depend on DOM but fullnames can still refer to it - if path.Contains("lib.dom") && src.fileName.EndsWith(".d.ts") then stdlibWebworkerSrc - else path - ) - ) - { src with statements = statements } - - ctx.logger.tracef "* running typer..." - - setTyperOptions ctx - let opts = ctx.options - opts.simplify <- [Simplify.All] - opts.inheritWithTags <- FeatureFlag.Full - opts.subtyping <- [Subtyping.Tag] - - let flags : EmitModuleFlags = - {| jsModule = None; scopeRev = []; isReservedModule = false |} - - let esCtx, esSrc = runAll [esSrc] ctx - let domCtx, domSrc = runAll [domSrc] ctx - let webworkerCtx, webworkerSrc = runAll [webworkerSrc] ctx - - let writerCtx (srcs: SourceFile list) ctx = - ctx |> Context.mapOptions (fun _ -> opts) - |> Context.mapState (fun _ -> State.create (srcs |> List.map (fun src -> src.fileName)) (Error None)) - - ctx.logger.tracef "* emitting stdlib..." - - let createOutput (baseName: string) (opens: string list) (ctx: Context) (src: SourceFile list) = - let stmts = src |> List.collect (fun x -> x.statements) - let ctx = ctx |> Context.ofSourceFileRoot (src[0].fileName) - let st = createStructuredText ctx stmts - let m = emitModule flags ctx st - let res = - concat newline [ - yield! header - yield! m.comments - for o in opens do yield Statement.open_ o - yield! m.imports - yield! emitTypes m.types - yield! m.impl - ] - let resi = - concat newline [ - yield! header - yield! m.comments - for o in opens do yield Statement.open_ o - yield! m.imports - yield! m.intf - ] - { baseName = baseName; resi = Some resi; res = res } - - let minLib = - { baseName = "ts2ocaml"; resi = None; res = str stdlib } - - [ minLib - createOutput "ts2ocaml_es" ["Js"; "Ts2ocaml"] (writerCtx esSrc esCtx) esSrc - createOutput "ts2ocaml_dom" ["Js"; "Ts2ocaml"; "Ts2ocaml_es"] (writerCtx domSrc domCtx) domSrc - createOutput "ts2ocaml_webworker" ["Js"; "Ts2ocaml"; "Ts2ocaml_es"] (writerCtx webworkerSrc webworkerCtx) webworkerSrc ] - let emitReferenceTypeDirectives (ctx: Context) (src: SourceFile) : text list = let refs = src.references @@ -2030,7 +1940,7 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: let stmts = sources |> List.collect (fun x -> x.statements) ctx.logger.tracef "* emitting a binding to '%s' for rescript..." moduleName - let structuredText = createStructuredText ctx stmts + let st = createStructuredText ctx stmts let flags : EmitModuleFlags = let jsModule = match ctx.options.``module`` with @@ -2041,7 +1951,8 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: ctx.info |> Map.exists (fun _ v -> v.exportMap |> Trie.isEmpty |> not) if hasExport then Some moduleName else None {| jsModule = jsModule; scopeRev = []; isReservedModule = false |} - let m = emitModule flags ctx structuredText + let dt = DependencyTrie.ofTrie (StructuredTextNode.getReferences ctx) st + let m = emitModule flags ctx dt st let opens = [ yield Statement.open_ "Js" From 77b664c96020eda3a79b0e8f6597452f94566e42 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 3 Oct 2022 19:20:55 +0900 Subject: [PATCH 35/56] Mark recursive modules in DependencyTrie --- lib/DataTypes/Graph.fs | 22 ++++++++++++++++++---- src/Targets/JsOfOCaml/Writer.fs | 2 +- src/Targets/ReScript/ReScriptHelper.fs | 2 +- src/Targets/ReScript/Writer.fs | 1 - 4 files changed, 20 insertions(+), 7 deletions(-) diff --git a/lib/DataTypes/Graph.fs b/lib/DataTypes/Graph.fs index db138e40..03aaec91 100644 --- a/lib/DataTypes/Graph.fs +++ b/lib/DataTypes/Graph.fs @@ -127,7 +127,12 @@ module Graph = #endif result -type DependencyTrie<'k when 'k: comparison> = Trie<'k, 'k list list> +type DependencyTrieInfo<'k> = { + isRecursive: bool + scc: 'k list list +} + +type DependencyTrie<'k when 'k: comparison> = Trie<'k, DependencyTrieInfo<'k>> module DependencyTrie = open Ts2Ml.Extensions @@ -158,8 +163,17 @@ module DependencyTrie = |> List.choose (function [x] -> Some (k, x) | _ -> None (* should be impossible *)) refs :: state) [] |> List.rev |> List.concat - let rec go nsRev (x: Trie<'k, 'v>) : DependencyTrie<'k> = + let rec go isRecursive nsRev (x: Trie<'k, 'v>) : DependencyTrie<'k> = let g = getDeps nsRev x |> Graph.ofEdges let scc = Graph.stronglyConnectedComponents g (x.children |> Map.toList |> List.map fst) - { value = Some scc; children = x.children |> Map.map (fun k child -> go (k :: nsRev) child) } - go [] trie + let isRecursiveMap = + scc + |> List.collect (function + | [] -> [] + | [k] -> [k, false] + | ks -> ks |> List.map (fun k -> k, true)) + |> Map.ofList + { value = Some { scc = scc; isRecursive = isRecursive }; + children = x.children |> Map.map (fun k child -> + go (isRecursiveMap |> Map.tryFind k |? false) (k :: nsRev) child) } + go false [] trie diff --git a/src/Targets/JsOfOCaml/Writer.fs b/src/Targets/JsOfOCaml/Writer.fs index 600e2635..9aabffa9 100644 --- a/src/Targets/JsOfOCaml/Writer.fs +++ b/src/Targets/JsOfOCaml/Writer.fs @@ -1575,7 +1575,7 @@ module ModuleEmitter = let nonRec _ctx modules = moduleSigNonRec modules let recAll _ctx modules = moduleSigRec modules let recOptimized dt (ctx: Context) = - let scc = dt |> Trie.tryFind ctx.currentNamespace |? [] + let scc = dt |> Trie.tryFind ctx.currentNamespace |> Option.map (fun x -> x.scc) |? [] let sccSet = scc |> List.concat |> Set.ofList fun (modules: TextModuleSig list) -> let modulesMap = modules |> List.fold (fun state x -> state |> Map.add x.origName x) Map.empty diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index b5a965b3..30543552 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -505,7 +505,7 @@ module Statement = ] let moduleSCC (dt: DependencyTrie) emitRec emitNonRec (ctx: Typer.TyperContext<_, _>) = - let scc = dt |> Trie.tryFind ctx.currentNamespace |? [] + let scc = dt |> Trie.tryFind ctx.currentNamespace |> Option.map (fun x -> x.scc) |? [] let sccSet = scc |> List.concat |> Set.ofList fun (modules: TextModule list) -> let modulesMap = modules |> List.fold (fun state x -> state |> Map.add x.origName x) Map.empty diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index d8462597..c818dc2c 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -1726,7 +1726,6 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (dt: DependencyTrie List.filter (fun (_, _, c) -> c.types |> List.isEmpty |> not) |> List.map (fun (k, _, c) -> {| k with content = c.imports @ c.types; comments = [] |}) - // |> Statement.moduleSigRec |> Statement.moduleSCC dt Statement.moduleSigRec Statement.moduleSigNonRec ctx children @ items From d914cf2c157e785cfc80efda1d8037d0d32a46c6 Mon Sep 17 00:00:00 2001 From: cannorin Date: Thu, 13 Oct 2022 17:18:23 +0900 Subject: [PATCH 36/56] Separate TypeDefText and TypeAliasText --- src/Targets/ReScript/Writer.fs | 178 ++++++++++++++------------------- 1 file changed, 73 insertions(+), 105 deletions(-) diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index c818dc2c..3e86ea28 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -476,30 +476,24 @@ let builder name (fields: {| isOptional: bool; name: string; value: text |} list Type.curriedArrow args thisType Binding.Ext {| name = name; ty = ty; target = ""; attrs = [Attr.External.obj]; comments = []|} -type EmitCondition = { - /// Emit in the `Types` module - onTypes: bool - /// Emit in `.res` - onImpl: bool - /// Emit in `.resi` - onIntf: bool -} with - static member empty = { onTypes = false; onImpl = false; onIntf = false } - static member all = { onTypes = true; onImpl = true; onIntf = true } - -type StructuredTextItem = +type StructuredTextItemBase<'TypeDef, 'Binding, 'EnumCase> = /// Will always be emitted at the top of the module. | ImportText of text /// Will always be emitted at the next top of the module. - /// - /// In `.res`, the presence of this item makes `open ModuleName` also emitted. - | TypeDefText of text - | Conditional of StructuredTextItem * EmitCondition + | TypeDefText of 'TypeDef + | TypeAliasText of text /// Will be emitted in `.res` and `.resi`, but not in the `Types` module | Comment of text /// Will only be emitted in `.res` (not in `.resi` or in the `Types` module) - | Binding of (OverloadRenamer -> CurrentScope -> Binding) - | EnumCaseText of {| name: string; ty: text; comments: Comment list |} + | Binding of 'Binding + | EnumCaseText of 'EnumCase + +and StructuredTextItem = + StructuredTextItemBase< + {| name: string; tyargs: (TypeParam * text) list; isRec: bool; body: text option; shouldAssert: bool |}, + (OverloadRenamer -> CurrentScope -> Binding), + {| name: string; ty: text; comments: Comment list |} + > and CurrentScope = { jsModule: string option @@ -532,8 +526,6 @@ and StructuredTextNode = {| and StructuredText = Trie -let inline conditional cond x = Conditional (x, cond) - module StructuredTextNode = let empty : StructuredTextNode = {| scope = Scope.Default; items = []; comments = []; exports = []; knownTypes = Set.empty; anonymousInterfaces = Set.empty; openTypesModule = true |} @@ -577,7 +569,7 @@ let emitComments (comments: Comment list) : text list = // TODO [] -let inline binding (f: (string -> string) -> CurrentScope -> Binding) = +let inline binding (f: (string -> string) -> CurrentScope -> Binding) : StructuredTextItem list = [Binding (fun renamer scope -> f (renamer.Rename "value") scope)] let scopeToAttr (s: CurrentScope) attr = @@ -832,20 +824,6 @@ let emitTypeAliasesImpl yield! lines {| name = name; tyargs = List.zip typrms' tyargs'; target = Some target; isOverload = true |} ] -let emitTypeAliases flags overrideFunc ctx (typrms: TypeParam list) target isRec = - let emitType = emitTypeImpl flags - emitTypeAliasesImpl "t" flags overrideFunc ctx typrms target ( - fun x -> [Statement.typeAlias (isRec && not x.isOverload) x.name (x.tyargs |> List.map snd) x.target |> TypeDefText] - ) - -let emitTypeAlias flags overrideFunc ctx (typrms: TypeParam list) target isRec = - let emitType = emitTypeImpl flags - emitTypeAliasesImpl "t" flags overrideFunc ctx typrms target ( - fun x -> - if not x.isOverload then [Statement.typeAlias isRec x.name (x.tyargs |> List.map snd) x.target |> TypeDefText] - else [] - ) - let getTrie name current = current |> Trie.getSubTrie name |> Option.defaultValue Trie.empty let setTrie name trie current = @@ -987,7 +965,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c "tags" flags overrideFunc innerCtx c.typeParams (emitLabels innerCtx labels |> Some) (fun x -> [Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target]) |> concat newline - alias|> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some + alias|> TypeAliasText |> Some else None let polymorphicThisDefinition = @@ -1000,7 +978,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c Statement.typeAlias false "this" (str "'tags" :: typrms) (Type.intf (str "'tags") +@ " constraint 'tags = " + tags |> Some) - |> TypeDefText |> conditional { onIntf = true; onImpl = true; onTypes = false } |> Some + |> TypeAliasText |> Some else None // " this resets the weird syntax highlighting @@ -1035,20 +1013,13 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | ClassKind.NormalClass x -> getSelfTyText x.orig | ClassKind.ExportDefaultClass x -> getSelfTyText x.orig | ClassKind.AnonymousInterface _ -> fallback - let onTypes = - emitTypeAlias flags overrideFunc innerCtx c.typeParams selfTyText.ty selfTyText.isRec - |> List.map (conditional { EmitCondition.empty with onTypes = true }) - let onIntf = - emitTypeAliases flags overrideFunc innerCtx c.typeParams selfTyText.ty selfTyText.isRec - |> List.map (conditional { EmitCondition.empty with onIntf = true }) - let onImpl = - let origTyText = - let tyargs = c.typeParams |> List.map (fun x -> tprintf "'%s" x.name) - Type.appOpt (str "t") tyargs - emitTypeAliases flags overrideFunc innerCtx c.typeParams (Some origTyText) false - |> List.map (conditional { EmitCondition.empty with onImpl = true }) - - List.concat [onTypes; onIntf; onImpl] + + emitTypeAliasesImpl "t" flags overrideFunc innerCtx c.typeParams selfTyText.ty (fun x -> + if not x.isOverload then + [TypeDefText {| name = x.name; tyargs = x.tyargs; body = x.target; isRec = selfTyText.isRec; shouldAssert = false |}] + else + [TypeAliasText (Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target)] + ) let castFunctions = [ // add a generic cast function if tag is available @@ -1058,7 +1029,6 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c yield! binding (fun _ _ -> cast [] "castFrom" castTy) if innerCtx.options.subtyping |> List.contains Subtyping.CastFunction then - let inline func ft = func flags overrideFunc innerCtx ft for parent in c.implements do let ty = Type.curriedArrow [selfTyText] (emitType_ innerCtx parent) let parentName = getHumanReadableName innerCtx parent @@ -1235,10 +1205,7 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu yield indent (tprintf "| %s" case) ] else cases |> String.concat " | " |> str - [ - yield str "type t = " + casesText |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } - yield str "type t = t = " + casesText |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } - ] + [TypeDefText {| name = "t"; tyargs = []; isRec = false; body = Some casesText; shouldAssert = true |}] | EnumType.Int | EnumType.String | EnumType.PolyVariant -> let cases = distinctCases @@ -1247,22 +1214,16 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} | _ -> impossible "emitEnum_parentNode_PolyVariant") - Statement.typeAlias false "t" [] (Type.polyVariant cases |> Some) |> TypeDefText |> List.singleton - | EnumType.Boolean -> Statement.typeAlias false "t" [] (str "private bool" |> Some) |> TypeDefText |> List.singleton + [TypeDefText {| name = "t"; tyargs = []; isRec = false; body = (Type.polyVariant cases |> Some); shouldAssert = false |}] + | EnumType.Boolean -> Statement.typeAlias false "t" [] (str "private bool" |> Some) |> TypeAliasText |> List.singleton | EnumType.Float | EnumType.Number -> ctx.logger.warnf "an enum type '%s' contains a case with float or negative value, which is not supported in ReScript at %s" e.name e.loc.AsString - [ - yield commentStr (sprintf "FIXME: float/negative enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } - yield Statement.typeAlias false "t" [] (str "private float" |> Some) |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } - yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } - ] - | _ -> + let def = "private float " @+ commentStr (sprintf "FIXME: float/negative enum (at %s)" e.loc.AsString) + [TypeDefText {| name = "t"; tyargs = []; isRec = false; body = Some def; shouldAssert = false |}] + | EnumType.Heterogeneous | _ -> ctx.logger.warnf "a heterogeneous enum '%s' is not supported at %s" e.name e.loc.AsString - [ - yield commentStr (sprintf "FIXME: heterogeneous enum (at %s)" e.loc.AsString) |> TypeDefText |> conditional { onImpl = true; onIntf = true; onTypes = false } - yield Statement.typeAlias false "t" [] None |> TypeDefText |> conditional { EmitCondition.all with onImpl = false } - yield str "type t = t" |> TypeDefText |> conditional { EmitCondition.empty with onImpl = true } - ] + let def = Type.object +@ " " + commentStr (sprintf "FIXME: heterogeneous enum (at %s)" e.loc.AsString) + [TypeDefText {| name = "t"; tyargs = []; isRec = false; body = Some def; shouldAssert = false |}] let items = items @ List.map child e.cases let comments = e.comments |> emitComments {| StructuredTextNode.empty with items = items; comments = comments |} @@ -1294,8 +1255,6 @@ let rec emitFunction flags overrideFunc ctx (f: Function) = { accessibility = f.accessibility; comments = f.comments; isExported = f.isExported; loc = f.loc; name = f.name; isConst = true; typ = Func (f.typ, [], f.loc) } else - let emitType = emitTypeImpl flags - let emitType_ = emitType overrideFunc let inline extFunc ft = extFunc flags overrideFunc ctx ft let ty, attr = extFunc f.typ let attr = attr |> impossibleNone (fun () -> "emitFunction") @@ -1371,7 +1330,7 @@ let emitImport (ctx: Context) (i: Import) : StructuredTextItem list = |> Option.defaultValue [] | NamespaceImport _ | ES6DefaultImport _ | ES6Import _ -> [] - [ yield! emitComments i.comments |> List.map (ImportText >> conditional { onImpl = true; onIntf = true; onTypes = false }) + [ yield! emitComments i.comments |> List.map ImportText yield commentStr i.origText |> ImportText for c in i.clauses do yield! emitImportClause c] @@ -1384,13 +1343,11 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let emitTypeFlags = EmitTypeFlags.defaultValue let overrideFunc = OverrideFunc.noOverride let emitType = emitTypeImpl emitTypeFlags - let emitType_ = emitType overrideFunc let emitSelfType = emitTypeImpl emitTypeFlags overrideFunc /// convert interface members to appropriate statements let intfToStmts (moduleIntf: Class<_>) ctx flags overrideFunc = let flags = { flags with simplifyContravariantUnion = true } - let emitType_ = emitTypeImpl flags overrideFunc let inline extFunc ft = extFunc flags overrideFunc ctx ft let inline func ft = func flags overrideFunc ctx ft let inline newableFunc ft = newableFunc flags overrideFunc ctx ft @@ -1499,9 +1456,10 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured knownTypes |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) let items = emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target |> Some) (fun x -> - let a = Statement.typeAlias (isRec && not x.isOverload) x.name (x.tyargs |> List.map snd) x.target |> TypeDefText - if x.isOverload then a |> conditional { onTypes = false; onIntf = true; onImpl = true } |> List.singleton - else a |> List.singleton + if not x.isOverload then + [TypeDefText {| name = x.name; tyargs = x.tyargs; body = x.target; isRec = false; shouldAssert = false |}] + else + [TypeAliasText (Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target)] ) let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes |} current @@ -1617,7 +1575,6 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | FloatingComment c -> let cmt = c.comments |> emitComments |> List.map Comment current |> set {| StructuredTextNode.empty with items = Comment empty :: cmt |} - and folder' ctx stmt node = folder ctx node stmt stmts |> List.fold (folder rootCtx) Trie.empty @@ -1704,23 +1661,34 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (dt: DependencyTrie List.map snd) e.body + let alias = + let tmp = + Statement.typeAlias false e.name (e.tyargs |> List.map snd) + (Type.appOpt (str e.name) (e.tyargs |> List.map snd) |> Some) + match e.body, e.shouldAssert with + | _, false | None, _ -> tmp + | Some b, true -> tmp +@ " = " + b + {| types = actual; intf = actual; impl = alias |} + let rec f = function - | Conditional (i, c) -> c, snd (f i) - | ImportText t -> { EmitCondition.all with onTypes = false }, Choice1Of5 t - | TypeDefText t -> EmitCondition.all, Choice2Of5 t - | Binding b -> { EmitCondition.all with onTypes = false }, Choice3Of5 (b renamer currentScope) - | EnumCaseText e -> EmitCondition.all, Choice4Of5 (emitEnumCase e) - | Comment c -> { EmitCondition.all with onTypes = false }, Choice5Of5 c + | ImportText t -> ImportText t + | TypeAliasText t -> TypeAliasText t + | TypeDefText d -> TypeDefText (emitTypeDefText d) + | Binding b -> Binding (b renamer currentScope) + | EnumCaseText e -> EnumCaseText (emitEnumCase e) + | Comment c -> Comment c match st.value with None -> [] | Some v -> v.items |> List.map f let imports = - items |> List.choose (function (_, Choice1Of5 t) -> Some t | _ -> None) + items |> List.choose (function ImportText t -> Some t | _ -> None) let types = let items = items |> List.choose (function - | c, Choice2Of5 t when c.onTypes -> Some t - | _, Choice4Of5 e -> Some e.types + | TypeDefText d -> Some d.types + | EnumCaseText e -> Some e.types | _ -> None) let children = children @@ -1744,18 +1712,18 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (dt: DependencyTrie Statement.moduleSigRec let typeDefs = items |> List.choose (function - | c, Choice2Of5 t when c.onIntf -> Some t - | _, Choice4Of5 e -> Some e.intf + | TypeAliasText t -> Some t + | TypeDefText d -> Some d.intf + | EnumCaseText e -> Some e.intf | _ -> None) [ yield! children yield! typeDefs - for cond, item in items do - if cond.onIntf then - match item with - | Choice3Of5 b -> yield! Binding.emitForInterface b - | Choice5Of5 c -> yield c - | _ -> () + for item in items do + match item with + | Binding b -> yield! Binding.emitForInterface b + | Comment c -> yield c + | _ -> () yield! exports.intf ] @@ -1773,18 +1741,18 @@ let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (dt: DependencyTrie Statement.moduleValMany let typeDefs = items |> List.choose (function - | c, Choice2Of5 t when c.onImpl -> Some t - | _, Choice4Of5 e -> Some e.impl + | TypeAliasText t -> Some t + | TypeDefText d -> Some d.impl + | EnumCaseText e -> Some e.impl | _ -> None) [ yield! children yield! typeDefs - for cond, item in items do - if cond.onImpl then - match item with - | Choice3Of5 b -> yield! Binding.emitForImplementation b - | Choice5Of5 c -> yield c - | _ -> () + for item in items do + match item with + | Binding b -> yield! Binding.emitForImplementation b + | Comment c -> yield c + | _ -> () yield! exports.impl ] @@ -1798,7 +1766,7 @@ and emitExportModule (ctx: Context) (exports: ExportItem list) : EmitModuleResul if i.kind |> Option.map Kind.generatesReScriptModule |> Option.defaultValue false then [ Statement.moduleAlias (name |> Naming.moduleNameReserved) - (i.name |> Naming.structured Naming.moduleName) |> TypeDefText ] + (i.name |> Naming.structured Naming.moduleName) |> TypeAliasText ] else [] let addItems items (acc: StructuredText) = @@ -1988,4 +1956,4 @@ let emit (input: Input) (ctx: IContext) : Output list = [emitImpl input.sources input.info ctx] else input.sources - |> List.map (fun source -> emitImpl [source] input.info ctx) \ No newline at end of file + |> List.map (fun source -> emitImpl [source] input.info ctx) From 2ec515811a0e3ad0dcc75f3ca48f2645a7e08e46 Mon Sep 17 00:00:00 2001 From: cannorin Date: Thu, 13 Oct 2022 20:03:02 +0900 Subject: [PATCH 37/56] Add DependencyTrie.isLinear --- lib/DataTypes/Graph.fs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/lib/DataTypes/Graph.fs b/lib/DataTypes/Graph.fs index 03aaec91..db1298cb 100644 --- a/lib/DataTypes/Graph.fs +++ b/lib/DataTypes/Graph.fs @@ -137,6 +137,13 @@ type DependencyTrie<'k when 'k: comparison> = Trie<'k, DependencyTrieInfo<'k>> module DependencyTrie = open Ts2Ml.Extensions + let rec isLinear (dt: DependencyTrie<'k>) = + let searchChildren () = + dt.children.Values |> Seq.forall isLinear + match dt.value with + | Some { isRecursive = true } -> false + | _ -> searchChildren () + let ofTrie (getReferences: 'v -> WeakTrie<'k>) (trie: Trie<'k, 'v>) : DependencyTrie<'k> = let refTrieMap = new MutableMap<'k list, WeakTrie<'k>>() let rec getRefTrie nsRev (x: Trie<'k, 'v>) = From 6ba4e7b7f9363a514d1b463351fcd6b3bb6fd829 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 8 Nov 2022 14:34:24 +0900 Subject: [PATCH 38/56] Fix fable build --- lib/DataTypes/Graph.fs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/DataTypes/Graph.fs b/lib/DataTypes/Graph.fs index db1298cb..10956540 100644 --- a/lib/DataTypes/Graph.fs +++ b/lib/DataTypes/Graph.fs @@ -139,7 +139,10 @@ module DependencyTrie = let rec isLinear (dt: DependencyTrie<'k>) = let searchChildren () = - dt.children.Values |> Seq.forall isLinear + dt.children + |> Map.toSeq + |> Seq.map snd + |> Seq.forall isLinear match dt.value with | Some { isRecursive = true } -> false | _ -> searchChildren () From 60ae34329bb4482a2a55713d2fb2f66718ef155f Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 8 Nov 2022 17:47:22 +0900 Subject: [PATCH 39/56] Remove unwanted extends clauses --- lib/Typer.fs | 268 +++++++++++++++++++-------------- src/Targets/ReScript/Writer.fs | 5 +- 2 files changed, 162 insertions(+), 111 deletions(-) diff --git a/lib/Typer.fs b/lib/Typer.fs index 380a220a..72d27fe2 100644 --- a/lib/Typer.fs +++ b/lib/Typer.fs @@ -43,6 +43,11 @@ type TyperOptions = /// ``` abstract replaceNewableFunction: bool with get,set + /// Ignores all `T extends U` while typechecking. + /// + /// Good for targets which don't support constrained type parameters. + abstract noExtendsInTyprm: bool with get,set + type [] Definition = | TypeAlias of TypeAlias | Class of Class @@ -339,6 +344,12 @@ module Type = let mapInIntersection mapping ctx (i: IntersectionType) : IntersectionType = { types = i.types |> List.map (mapping ctx) } + let mapInErased mapping ctx (e: ErasedType) : ErasedType = + match e with + | IndexedAccess (t1, t2) -> IndexedAccess (mapping ctx t1, mapping ctx t2) + | TypeQuery i -> TypeQuery i + | Keyof t -> Keyof (mapping ctx t) + let rec mapIdent f = function | Intrinsic -> Intrinsic | PolymorphicThis -> PolymorphicThis | Ident i -> Ident (f i) @@ -376,45 +387,61 @@ module Type = Erased (e, loc, origText) | UnknownType msg -> UnknownType msg - let rec substTypeVar (subst: Map) _ctx = function - | TypeVar v -> - match subst |> Map.tryFind v with - | Some t -> t - | None -> TypeVar v - | Union u -> Union (mapInUnion (substTypeVar subst) _ctx u) - | Intersection i -> Intersection (mapInIntersection (substTypeVar subst) _ctx i) - | Tuple ts -> Tuple (ts |> mapInTupleType (substTypeVar subst) _ctx) - | AnonymousInterface c -> AnonymousInterface (mapInClass (substTypeVar subst) _ctx c) - | Func (f, typrms, loc) -> - Func (substTypeVarInFunction subst _ctx f, List.map (substTypeVarInTypeParam subst _ctx) typrms, loc) - | NewableFunc (f, typrms, loc) -> - NewableFunc (substTypeVarInFunction subst _ctx f, List.map (substTypeVarInTypeParam subst _ctx) typrms, loc) + let rec mapTypeVar (f: 'Context -> string -> Type) ctx = function + | TypeVar v -> f ctx v + | Union u -> Union (mapInUnion (mapTypeVar f) ctx u) + | Intersection i -> Intersection (mapInIntersection (mapTypeVar f) ctx i) + | Tuple ts -> Tuple (ts |> mapInTupleType (mapTypeVar f) ctx) + | AnonymousInterface c -> AnonymousInterface (mapInClass (mapTypeVar f) ctx c) + | Func (fn, typrms, loc) -> + Func (mapInFuncType (mapTypeVar f) ctx fn, List.map (mapInTypeParam (mapTypeVar f) ctx) typrms, loc) + | NewableFunc (fn, typrms, loc) -> + NewableFunc (mapInFuncType (mapTypeVar f) ctx fn, List.map (mapInTypeParam (mapTypeVar f) ctx) typrms, loc) | App (t, ts, loc) -> let t = match t with - | AAnonymousInterface i -> AAnonymousInterface (mapInClass (substTypeVar subst) _ctx i) + | AAnonymousInterface i -> AAnonymousInterface (mapInClass (mapTypeVar f) ctx i) | _ -> t - App (t, ts |> List.map (substTypeVar subst _ctx), loc) + App (t, ts |> List.map (mapTypeVar f ctx), loc) | Ident i -> Ident i | Prim p -> Prim p | TypeLiteral l -> TypeLiteral l | PolymorphicThis -> PolymorphicThis | Intrinsic -> Intrinsic | Erased (e, loc, origText) -> - let e' = - match e with - | IndexedAccess (t1, t2) -> IndexedAccess (substTypeVar subst _ctx t1, substTypeVar subst _ctx t2) - | TypeQuery i -> TypeQuery i - | Keyof t -> Keyof (substTypeVar subst _ctx t) - Erased (e', loc, origText) + Erased (mapInErased (mapTypeVar f) ctx e, loc, origText) | UnknownType msgo -> UnknownType msgo - and substTypeVarInTypeParam subst _ctx (tp: TypeParam) = - { tp with - extends = Option.map (substTypeVar subst _ctx) tp.extends - defaultType = Option.map (substTypeVar subst _ctx) tp.defaultType } + let substTypeVar (subst: Map) _ctx = + mapTypeVar (fun _ v -> + match subst |> Map.tryFind v with + | Some t -> t + | None -> TypeVar v + ) _ctx - and substTypeVarInFunction subst _ctx f = - { f with - returnType = substTypeVar subst _ctx f.returnType; - args = List.map (mapInArg (substTypeVar subst) _ctx) f.args } + let private mapTypeParamInClassImpl f mtp ctx (c: Class<'a>) = + { c with + implements = c.implements |> List.map (mtp f ctx) + members = c.members |> List.map (mapInMember (mtp f) ctx) + typeParams = c.typeParams |> List.map (f ctx) } + + let rec mapTypeParam (f: 'Context -> TypeParam -> TypeParam) ctx = function + | Intrinsic -> Intrinsic | PolymorphicThis -> PolymorphicThis + | Ident i -> Ident i | Prim p -> Prim p | TypeLiteral l -> TypeLiteral l | TypeVar v -> TypeVar v | UnknownType m -> UnknownType m + | Union u -> Union (mapInUnion (mapTypeParam f) ctx u) + | Intersection i -> Intersection (mapInIntersection (mapTypeParam f) ctx i) + | Tuple ts -> Tuple (ts |> mapInTupleType (mapTypeParam f) ctx) + | AnonymousInterface c -> AnonymousInterface (mapTypeParamInClassImpl f mapTypeParam ctx c) + | Func (fn, typrms, loc) -> + Func (mapInFuncType (mapTypeParam f) ctx fn, typrms |> List.map (f ctx), loc) + | NewableFunc (fn, typrms, loc) -> + NewableFunc (mapInFuncType (mapTypeParam f) ctx fn, typrms |> List.map (f ctx), loc) + | App (lhs, ts, loc) -> + let lhs = + match lhs with + | AIdent _ | APrim _ -> lhs + | AAnonymousInterface c -> AAnonymousInterface (mapTypeParamInClassImpl f mapTypeParam ctx c) + App (lhs, ts |> List.map (mapTypeParam f ctx), loc) + | Erased (e, loc, orig) -> Erased (mapInErased (mapTypeParam f) ctx e, loc, orig) + + let mapTypeParamInClass f ctx c = mapTypeParamInClassImpl f mapTypeParam ctx c type TypeFinder<'State, 'Result> = 'State -> Type -> Type list option * 'State * 'Result seq @@ -1652,6 +1679,25 @@ let inferEnumCaseValue (stmts: Statement list) : Statement list = | s -> s stmts |> List.map go +let removeExtendsInTyprm = + let remove _ (tp: TypeParam) = { tp with extends = None } + let rec goStmt ctx = function + | Class c -> Type.mapTypeParamInClass remove ctx c |> Class |> Some + | TypeAlias a -> + TypeAlias { + a with + target = a.target |> Type.mapTypeParam remove ctx + typeParams = a.typeParams |> List.map (remove ctx) + } |> Some + | Function f -> + Function { + f with + typ = f.typ |> Type.mapInFuncType (Type.mapTypeParam remove) ctx + typeParams = f.typeParams |> List.map (remove ctx) + } |> Some + | _ -> None + Statement.mapTypeWith goStmt (Type.mapTypeParam remove) (fun _ -> id) id () + let rec mergeStatements (stmts: Statement list) = let mutable result : Choice list = [] @@ -1839,73 +1885,71 @@ type private MemberType = | Method of string * int | Callable of int | Newable of int | Indexer of int | Constructor of int let addParentMembersToClass (ctx: TyperContext<#TyperOptions, _>) (stmts: Statement list) : Statement list = - if not ctx.options.addAllParentMembersToClass then stmts - else - let m = new MutableMap() - let processing = new MutableSet() - let rec addMembers (c: Class) = - match m.TryGetValue(c.loc) with - | true, c -> c - | false, _ when processing.Contains(c.loc) -> c - | false, _ -> - processing.Add(c.loc) |> ignore - // we remove any parent type which is a super type of some other parent type - let implements = - c.implements - |> List.filter (fun t -> c.implements |> List.forall (fun t' -> Type.isSuperClass ctx t t' |> not)) - let getMemberType m = - match m with - | Field (fl, _) | Getter fl -> MemberType.Getter (fl.name |> String.normalize) |> Some - | Setter fl -> MemberType.Setter (fl.name |> String.normalize) |> Some - | Method (name, ft, _) -> MemberType.Method (name |> String.normalize, ft.args.Length) |> Some - | Callable (ft, _) -> MemberType.Callable (ft.args.Length) |> Some - | Newable (ft, _) -> MemberType.Newable (ft.args.Length) |> Some - | Indexer (ft, _) -> MemberType.Indexer (ft.args.Length) |> Some - | Constructor ft -> MemberType.Constructor (ft.args.Length) |> Some - | SymbolIndexer _ | UnknownMember _ -> None - // if a parent member has the same arity as the member in a child, - // we should only keep the one from the child. - let memberTypes : Set = - c.members |> List.choose (snd >> getMemberType) |> Set.ofList - let parentMembers : (MemberAttribute * Member) list = - let (|Dummy|) _ = [] - let rec collector : _ -> _ list = function - | (Ident ({ loc = loc } & i) & Dummy ts) | App (AIdent i, ts, loc) -> - let collect = function - | Definition.TypeAlias a -> - if List.isEmpty ts then collector a.target - else - let bindings = Type.createBindings i.name loc a.typeParams ts - collector a.target |> List.map (Type.mapInMember (Type.substTypeVar bindings) ()) - // we ignore `implements` clauses i.e. interfaces inherited by a class. - | Definition.Class c' when c.isInterface || not c'.isInterface -> - if List.isEmpty ts then (addMembers c').members - else - let members = (addMembers c').members - let bindings = Type.createBindings i.name loc c'.typeParams ts - members |> List.map (Type.mapInMember (Type.substTypeVar bindings) ()) - | _ -> [] - Ident.collectDefinition ctx i collect |> List.distinct - | Intersection i -> i.types |> List.collect collector |> List.distinct - | _ -> [] - implements - |> List.collect collector - |> List.filter (fun (_, m) -> - match getMemberType m with - | None -> false - | Some mt -> memberTypes |> Set.contains mt |> not) - |> List.distinct - let c = { c with members = c.members @ parentMembers } - m[c.loc] <- c - c - let rec go stmts = - stmts |> List.map (function - | Class c when c.isInterface -> Class (addMembers c) - | Namespace m -> Namespace { m with statements = go m.statements } - | AmbientModule m -> AmbientModule { m with statements = go m.statements } - | Global m -> Global { m with statements = go m.statements } - | x -> x) - go stmts + let m = new MutableMap() + let processing = new MutableSet() + let rec addMembers (c: Class) = + match m.TryGetValue(c.loc) with + | true, c -> c + | false, _ when processing.Contains(c.loc) -> c + | false, _ -> + processing.Add(c.loc) |> ignore + // we remove any parent type which is a super type of some other parent type + let implements = + c.implements + |> List.filter (fun t -> c.implements |> List.forall (fun t' -> Type.isSuperClass ctx t t' |> not)) + let getMemberType m = + match m with + | Field (fl, _) | Getter fl -> MemberType.Getter (fl.name |> String.normalize) |> Some + | Setter fl -> MemberType.Setter (fl.name |> String.normalize) |> Some + | Method (name, ft, _) -> MemberType.Method (name |> String.normalize, ft.args.Length) |> Some + | Callable (ft, _) -> MemberType.Callable (ft.args.Length) |> Some + | Newable (ft, _) -> MemberType.Newable (ft.args.Length) |> Some + | Indexer (ft, _) -> MemberType.Indexer (ft.args.Length) |> Some + | Constructor ft -> MemberType.Constructor (ft.args.Length) |> Some + | SymbolIndexer _ | UnknownMember _ -> None + // if a parent member has the same arity as the member in a child, + // we should only keep the one from the child. + let memberTypes : Set = + c.members |> List.choose (snd >> getMemberType) |> Set.ofList + let parentMembers : (MemberAttribute * Member) list = + let (|Dummy|) _ = [] + let rec collector : _ -> _ list = function + | (Ident ({ loc = loc } & i) & Dummy ts) | App (AIdent i, ts, loc) -> + let collect = function + | Definition.TypeAlias a -> + if List.isEmpty ts then collector a.target + else + let bindings = Type.createBindings i.name loc a.typeParams ts + collector a.target |> List.map (Type.mapInMember (Type.substTypeVar bindings) ()) + // we ignore `implements` clauses i.e. interfaces inherited by a class. + | Definition.Class c' when c.isInterface || not c'.isInterface -> + if List.isEmpty ts then (addMembers c').members + else + let members = (addMembers c').members + let bindings = Type.createBindings i.name loc c'.typeParams ts + members |> List.map (Type.mapInMember (Type.substTypeVar bindings) ()) + | _ -> [] + Ident.collectDefinition ctx i collect |> List.distinct + | Intersection i -> i.types |> List.collect collector |> List.distinct + | _ -> [] + implements + |> List.collect collector + |> List.filter (fun (_, m) -> + match getMemberType m with + | None -> false + | Some mt -> memberTypes |> Set.contains mt |> not) + |> List.distinct + let c = { c with members = c.members @ parentMembers } + m[c.loc] <- c + c + let rec go stmts = + stmts |> List.map (function + | Class c when c.isInterface -> Class (addMembers c) + | Namespace m -> Namespace { m with statements = go m.statements } + | AmbientModule m -> AmbientModule { m with statements = go m.statements } + | Global m -> Global { m with statements = go m.statements } + | x -> x) + go stmts let introduceAdditionalInheritance (ctx: IContext<#TyperOptions>) (stmts: Statement list) : Statement list = let opts = ctx.options @@ -2069,10 +2113,7 @@ let replaceAliasToFunction (ctx: #IContext<#TyperOptions>) stmts = } | _ -> TypeAlias ta | x -> x - if ctx.options.replaceAliasToFunction then - List.map go stmts - else - stmts + List.map go stmts let replaceFunctions (ctx: #IContext<#TyperOptions>) (stmts: Statement list) = let rec goType (ctx: #IContext<#TyperOptions>) = function @@ -2089,10 +2130,7 @@ let replaceFunctions (ctx: #IContext<#TyperOptions>) (stmts: Statement list) = | NewableFunc (f, typrms, loc) -> let f = Type.mapInFuncType goType ctx f let typrms = typrms |> List.map (Type.mapInTypeParam goType ctx) - if ctx.options.replaceRankNFunction || ctx.options.replaceNewableFunction then - Type.createFunctionInterface [{| ty = f; typrms = typrms; loc = loc; isNewable = true; comments = [] |}] - else - NewableFunc (f, typrms, loc) + Type.createFunctionInterface [{| ty = f; typrms = typrms; loc = loc; isNewable = true; comments = [] |}] | TypeVar v -> TypeVar v | Union u -> Union (u |> Type.mapInUnion goType ctx) | Intersection i -> Intersection (i |> Type.mapInIntersection goType ctx) @@ -2336,7 +2374,16 @@ let runAll (srcs: SourceFile list) (baseCtx: IContext<#TyperOptions>) = let inline withSourceFileContext ctx f (src: SourceFile) = f (ctx |> TyperContext.ofSourceFileRoot src.fileName) src - let result = srcs |> List.map (mapStatements (inferEnumCaseValue >> mergeStatements)) + let inline onFlag b f = if b then f else id + + let result = + srcs |> List.map ( + mapStatements ( + inferEnumCaseValue + >> onFlag baseCtx.options.noExtendsInTyprm removeExtendsInTyprm + >> mergeStatements + ) + ) // build a context let ctx = createRootContextForTyper result baseCtx @@ -2347,21 +2394,22 @@ let runAll (srcs: SourceFile list) (baseCtx: IContext<#TyperOptions>) = src |> mapStatements (fun stmts -> stmts // add members inherited from parent classes/interfaces to interfaces - |> addParentMembersToClass ctx + |> onFlag ctx.options.addAllParentMembersToClass (addParentMembersToClass ctx) |> Statement.resolveErasedTypes ctx // add common inheritances which tends not to be defined by `extends` or `implements` - |> introduceAdditionalInheritance ctx + |> onFlag (ctx.options.inheritArraylike || ctx.options.inheritIterable || ctx.options.inheritPromiselike) + (introduceAdditionalInheritance ctx) // add default constructors to class if not explicitly defined |> addDefaultConstructorToClass ctx // group statements with pattern |> detectPatterns // replace alias to function type with a function interface - |> replaceAliasToFunction ctx + |> onFlag ctx.options.replaceAliasToFunction (replaceAliasToFunction ctx) // replace N-rank and/or newable function type with an interface - |> replaceFunctions ctx + |> onFlag (ctx.options.replaceRankNFunction || ctx.options.replaceNewableFunction) (replaceFunctions ctx) ))) // rebuild the context because resolveErasedTypes may introduce additional anonymous interfaces let ctx = createRootContext result ctx - ctx, result \ No newline at end of file + ctx, result diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 3e86ea28..36088003 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -895,7 +895,9 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c OverrideFunc.combine overrideFunc orf let knownTypes = - let dummy = c.MapName(fun _ -> ExportDefaultUnnamedClass) + let dummy = + // remove `extends` and `implements` clauses since it's not needed for the `Types` module + { c with implements = [] }.MapName(fun _ -> ExportDefaultUnnamedClass) Statement.getKnownTypes ctx [Class dummy] |> Set.union additionalKnownTypes let isAnonymous, isExportDefaultClass = @@ -1812,6 +1814,7 @@ let setTyperOptions (ctx: IContext) = ctx.options.replaceNewableFunction <- false ctx.options.replaceRankNFunction <- true ctx.options.addAllParentMembersToClass <- true + ctx.options.noExtendsInTyprm <- true let emitTypes (types: text list) : text list = [ From c69a5821b3b663be0067c00b983423e79d8a6a2a Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 9 Nov 2022 17:13:24 +0900 Subject: [PATCH 40/56] Fix getKnownTypes --- lib/Typer.fs | 41 ++++++++++++++++----------- src/Targets/ReScript/Writer.fs | 52 +++++++++++++++++++--------------- 2 files changed, 53 insertions(+), 40 deletions(-) diff --git a/lib/Typer.fs b/lib/Typer.fs index 72d27fe2..bc349519 100644 --- a/lib/Typer.fs +++ b/lib/Typer.fs @@ -764,9 +764,26 @@ module Type = let isSubClass ctx (sub: Type) (super: Type) = Set.isProperSuperset (getAllInheritancesAndSelf ctx super) (getAllInheritancesAndSelf ctx sub) - let getKnownTypes (ctx: TyperContext<_, _>) t = - findTypes (fun state -> function - | Ident { fullName = fns } -> None, state, List.map KnownType.Ident fns + let knownTypeFinder ctx : TypeFinder<_, _> = + fun state -> function + | Ident ({ fullName = fns } & i) & Dummy ts + | App (AIdent ({ fullName = fns } & i), ts, _) -> + let next = + Ident.getDefinitionsWithFullName ctx i + |> List.collect (fun x -> + match x.definition with + | Definition.TypeAlias { typeParams = typrms } | Definition.Class { typeParams = typrms } -> + assignTypeParams i.name i.loc typrms ts + (fun _ ty -> Some ty) + (fun tv -> + match tv.defaultType with + | Some ty -> Some ty + | None -> None) + | _ -> []) + |> List.choose id + |> List.append ts + |> List.distinct + Some next, state, List.map KnownType.Ident fns | AnonymousInterface a -> let info = ctx |> TyperContext.bindCurrentSourceInfo (fun info -> info.anonymousInterfacesMap |> Map.tryFind a) @@ -775,7 +792,9 @@ module Type = | None -> [] | Some info -> [KnownType.AnonymousInterface (a, info)] | _ -> None, state, [] - ) () t |> Set.ofSeq + + let getKnownTypes (ctx: TyperContext<_, _>) t = + findTypes (knownTypeFinder ctx) () t |> Set.ofSeq let rec resolveErasedTypeImpl typeQueries ctx = function | PolymorphicThis -> PolymorphicThis | Intrinsic -> Intrinsic @@ -1202,19 +1221,7 @@ module Statement = ) () stmts |> Seq.fold (fun state (k, v) -> Trie.addOrUpdate k v Set.union state) Trie.empty let getKnownTypes (ctx: TyperContext<_, _>) stmts = - let (|Dummy|) _ = [] - findTypesInStatements (fun state -> function - | Ident { fullName = fns } -> - None, state, List.map KnownType.Ident fns - | AnonymousInterface a -> - let info = - ctx |> TyperContext.bindCurrentSourceInfo (fun info -> info.anonymousInterfacesMap |> Map.tryFind a) - None, state, - match info with - | None -> [] - | Some info -> [KnownType.AnonymousInterface (a, info)] - | _ -> None, state, [] - ) () stmts |> Set.ofSeq + findTypesInStatements (knownTypeFinder ctx) () stmts |> Set.ofSeq let rec mapTypeWith overrideFunc mapping ctxOfChildNamespace ctxOfRoot ctx stmts = let mapVariable (v: Variable) = { v with typ = mapping ctx v.typ } diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 36088003..6cf0eb52 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -894,12 +894,6 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c selfTy, OverrideFunc.combine overrideFunc orf - let knownTypes = - let dummy = - // remove `extends` and `implements` clauses since it's not needed for the `Types` module - { c with implements = [] }.MapName(fun _ -> ExportDefaultUnnamedClass) - Statement.getKnownTypes ctx [Class dummy] |> Set.union additionalKnownTypes - let isAnonymous, isExportDefaultClass = match kind with | ClassKind.AnonymousInterface _ -> true, false @@ -917,17 +911,36 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let typrms = List.map (fun (tp: TypeParam) -> tprintf "'%s" tp.name) c.typeParams let selfTyText = Type.appOpt (str "t") typrms let currentNamespace = innerCtx |> Context.getFullName [] + let inheritingTypes = c.implements |> List.map (getAllInheritancesAndSelf innerCtx) |> Set.unionMany + + let knownTypes = + Set.unionMany [ + // We only need the type arguments of the inherited types + yield! + inheritingTypes + |> Set.toList + |> List.collect (function + | InheritingType.KnownIdent x -> x.tyargs + | InheritingType.UnknownIdent x -> x.tyargs + | _ -> []) + |> List.map (getKnownTypes innerCtx) + + // We only need the anonymous interfaces that appear in the members + yield + c.members + |> Seq.collect (snd >> findTypesInClassMember (knownTypeFinder innerCtx) ()) + |> Seq.filter (function KnownType.AnonymousInterface _ -> true | _ -> false) + |> Set.ofSeq + ] |> Set.union additionalKnownTypes let labels = - let emitType_ = emitType overrideFunc // labels should not have polymorphic this type match kind with | ClassKind.NormalClass _ -> getLabelsOfFullName flags overrideFunc innerCtx currentNamespace c.typeParams | ClassKind.ExportDefaultClass _ -> - c.implements - |> List.map (getAllInheritancesAndSelf innerCtx) |> Set.unionMany - |> getLabelsFromInheritingTypes flags overrideFunc innerCtx + inheritingTypes |> getLabelsFromInheritingTypes flags overrideFunc innerCtx | ClassKind.AnonymousInterface _ -> [] + let emittedLabels = emitLabels innerCtx labels let useTags = not isAnonymous @@ -964,10 +977,10 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c if useTags && innerCtx.options.inheritWithTags.HasProvide then let alias = emitTypeAliasesImpl - "tags" flags overrideFunc innerCtx c.typeParams (emitLabels innerCtx labels |> Some) + "tags" flags overrideFunc innerCtx c.typeParams (Some emittedLabels) (fun x -> [Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target]) |> concat newline - alias|> TypeAliasText |> Some + alias |> TypeAliasText |> Some else None let polymorphicThisDefinition = @@ -991,8 +1004,6 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | Name name -> assert (name = List.last innerCtx.currentNamespace) if innerCtx.options.subtyping |> List.contains Subtyping.Tag then - let labels = - getLabelsOfFullName flags overrideFunc innerCtx (innerCtx |> Context.getFullName []) c.typeParams if List.isEmpty labels then fallback else let isRec = @@ -1000,16 +1011,11 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | Case (_, args) | TagType (_, args) -> args |> List.contains (str "t") ) - {| ty = Type.intf (emitLabels innerCtx labels) |> Some; isRec = isRec |} + {| ty = Type.intf emittedLabels |> Some; isRec = isRec |} else fallback | ExportDefaultUnnamedClass -> - let labels = - c.implements - |> List.map (getAllInheritancesAndSelf innerCtx) |> Set.unionMany - |> getLabelsFromInheritingTypes flags overrideFunc innerCtx if List.isEmpty labels then fallback - else - {| ty = Type.intf (emitLabels innerCtx labels) |> Some; isRec = false |} + else {| ty = Type.intf emittedLabels |> Some; isRec = false |} let selfTyText = match kind with | ClassKind.NormalClass x -> getSelfTyText x.orig @@ -1090,7 +1096,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let addAsNode (name: string) = current |> add [name] node - |> inTrie [name] (addAnonymousInterface flags ctx knownTypes) + |> inTrie [name] (addAnonymousInterface flags ctx node.knownTypes) |> set {| StructuredTextNode.empty with exports = Option.toList export |} match kind with @@ -1099,7 +1105,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | ClassKind.ExportDefaultClass _ -> current |> set {| StructuredTextNode.empty with exports = [ExportItem.DefaultUnnamedClass node] |} - |> addAnonymousInterface flags ctx knownTypes + |> addAnonymousInterface flags ctx node.knownTypes and addAnonymousInterfaceExcluding emitTypeFlags (ctx: Context) knownTypes ais (current: StructuredText) = knownTypes From fe0623cbf772f4b848d89e71b37cb82b785b8bd2 Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 9 Nov 2022 18:13:31 +0900 Subject: [PATCH 41/56] Do not use Types module if linear --- src/Targets/ReScript/Writer.fs | 359 +++++++++++++++++---------------- 1 file changed, 188 insertions(+), 171 deletions(-) diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 6cf0eb52..ffde5168 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -915,22 +915,31 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let knownTypes = Set.unionMany [ - // We only need the type arguments of the inherited types - yield! - inheritingTypes - |> Set.toList - |> List.collect (function - | InheritingType.KnownIdent x -> x.tyargs - | InheritingType.UnknownIdent x -> x.tyargs - | _ -> []) - |> List.map (getKnownTypes innerCtx) + if innerCtx.options.subtyping |> List.contains Subtyping.CastFunction then + yield! c.implements |> List.map (getKnownTypes innerCtx) + else + // We only need the type arguments of the inherited types + yield! + inheritingTypes + |> Set.toList + |> List.collect (function + | InheritingType.KnownIdent x -> x.tyargs + | InheritingType.UnknownIdent x -> x.tyargs + | InheritingType.Prim (_, tyargs) -> tyargs + | InheritingType.Other t -> [t]) + |> List.map (getKnownTypes innerCtx) // We only need the anonymous interfaces that appear in the members yield c.members |> Seq.collect (snd >> findTypesInClassMember (knownTypeFinder innerCtx) ()) - |> Seq.filter (function KnownType.AnonymousInterface _ -> true | _ -> false) + // |> Seq.filter (function KnownType.AnonymousInterface _ -> true | _ -> false) |> Set.ofSeq + + yield! + c.typeParams + |> List.choose (fun c -> c.defaultType) + |> List.map (getKnownTypes innerCtx) ] |> Set.union additionalKnownTypes let labels = @@ -1608,166 +1617,172 @@ module EmitModuleResult = let empty : EmitModuleResult = {| imports = []; types = []; impl = []; intf = []; comments = [] |} -let rec emitModule (flags: EmitModuleFlags) (ctx: Context) (dt: DependencyTrie) (st: StructuredText) : EmitModuleResult = - let renamer = new OverloadRenamer() - let children = - st.children - |> Map.toList - |> List.map (fun (k, v) -> - let name = +let rec emitModule (dt: DependencyTrie) flags ctx st = + let isLinear = DependencyTrie.isLinear dt // compute only once + let rec go (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) : EmitModuleResult = + let renamer = new OverloadRenamer() + let children = + st.children + |> Map.toList + |> List.map (fun (k, v) -> let name = - if flags.isReservedModule then Naming.moduleNameReserved k - else Naming.moduleName k - name |> renamer.Rename "module" - let scopeRev, jsModule = - let overrideScope name = - match ctx |> Context.getExportTypeOfName [name] with - | None - | Some (ExportType.Child _) -> name :: flags.scopeRev - | Some ExportType.CommonJS -> [] - | Some (ExportType.ES6 None) -> [name] - | Some ExportType.ES6Default -> ["default"] - | Some (ExportType.ES6 (Some name)) -> [name] - match v.value with - | None -> k :: flags.scopeRev, flags.jsModule - | Some v -> - match v.scope with - | Scope.Default -> overrideScope k, flags.jsModule - | Scope.Path p -> overrideScope p, flags.jsModule - | Scope.Module m -> [], Some m - | Scope.Global -> [], None - | Scope.Ignore -> flags.scopeRev, flags.jsModule - let flags = {| flags with scopeRev = scopeRev; jsModule = jsModule |} - let ctx = ctx |> Context.ofChildNamespace k - let result = emitModule flags ctx dt v - let openTypesModule = - if flags.isReservedModule then false - else - let hasTypeDefinitions = result.types |> List.isEmpty |> not - v.value - |> Option.map (fun v -> hasTypeDefinitions && v.openTypesModule) - |> Option.defaultValue hasTypeDefinitions - {| name = name; origName = k |}, openTypesModule, result) - - let items = - let currentScope : CurrentScope = !!flags - - let emitEnumCase (e: {| name: string; ty: text; comments: Comment list |}) = - let moduleName = Naming.moduleName e.name - let types = - tprintf "module %s : " moduleName +@ "{ type t = " + e.ty +@ " }" - let attrs = scopeToAttr currentScope [Attr.External.val_] - let intf = [ - yield str $"type t = {e.ty}" - yield Statement.external attrs "value" (str "t") e.name - ] - let impl = [ - yield Statement.open_ moduleName - yield str "type t = t" - yield Statement.external attrs "value" (str "t") e.name - ] - let m content = {| name = moduleName; origName = e.name; content = content; comments = emitComments e.comments |} - {| types = types; intf = Statement.moduleSig (m intf); impl = Statement.moduleVal (m impl) |} - - let emitTypeDefText (e: {| name: string; tyargs:(TypeParam * text) list; isRec: bool; body: text option; shouldAssert: bool |}) = - let actual = Statement.typeAlias e.isRec e.name (e.tyargs |> List.map snd) e.body - let alias = - let tmp = - Statement.typeAlias false e.name (e.tyargs |> List.map snd) - (Type.appOpt (str e.name) (e.tyargs |> List.map snd) |> Some) - match e.body, e.shouldAssert with - | _, false | None, _ -> tmp - | Some b, true -> tmp +@ " = " + b - {| types = actual; intf = actual; impl = alias |} - - let rec f = function - | ImportText t -> ImportText t - | TypeAliasText t -> TypeAliasText t - | TypeDefText d -> TypeDefText (emitTypeDefText d) - | Binding b -> Binding (b renamer currentScope) - | EnumCaseText e -> EnumCaseText (emitEnumCase e) - | Comment c -> Comment c - match st.value with None -> [] | Some v -> v.items |> List.map f - - let imports = - items |> List.choose (function ImportText t -> Some t | _ -> None) - - let types = + let name = + if flags.isReservedModule then Naming.moduleNameReserved k + else Naming.moduleName k + name |> renamer.Rename "module" + let scopeRev, jsModule = + let overrideScope name = + match ctx |> Context.getExportTypeOfName [name] with + | None + | Some (ExportType.Child _) -> name :: flags.scopeRev + | Some ExportType.CommonJS -> [] + | Some (ExportType.ES6 None) -> [name] + | Some ExportType.ES6Default -> ["default"] + | Some (ExportType.ES6 (Some name)) -> [name] + match v.value with + | None -> k :: flags.scopeRev, flags.jsModule + | Some v -> + match v.scope with + | Scope.Default -> overrideScope k, flags.jsModule + | Scope.Path p -> overrideScope p, flags.jsModule + | Scope.Module m -> [], Some m + | Scope.Global -> [], None + | Scope.Ignore -> flags.scopeRev, flags.jsModule + let flags = {| flags with scopeRev = scopeRev; jsModule = jsModule |} + let ctx = ctx |> Context.ofChildNamespace k + let result = go flags ctx v + let openTypesModule = + if flags.isReservedModule then false + else + let hasTypeDefinitions = result.types |> List.isEmpty |> not + v.value + |> Option.map (fun v -> hasTypeDefinitions && v.openTypesModule) + |> Option.defaultValue hasTypeDefinitions + {| name = name; origName = k |}, openTypesModule, result) + let items = - items |> List.choose (function - | TypeDefText d -> Some d.types - | EnumCaseText e -> Some e.types - | _ -> None) - let children = - children - |> List.filter (fun (_, _, c) -> c.types |> List.isEmpty |> not) - |> List.map (fun (k, _, c) -> {| k with content = c.imports @ c.types; comments = [] |}) - |> Statement.moduleSCC dt Statement.moduleSigRec Statement.moduleSigNonRec ctx - children @ items - - let exports = - st.value - |> Option.map (fun m -> m.exports |> emitExportModule ctx) - |> Option.defaultValue EmitModuleResult.empty - - let intf = - let children = - children - |> List.filter (fun (_, _, c) -> c.intf |> List.isEmpty |> not) - |> List.map (fun (k, _, c) -> - let content = c.imports @ c.intf - {| k with content = content; comments = c.comments |}) - |> Statement.moduleSigRec - let typeDefs = - items |> List.choose (function - | TypeAliasText t -> Some t - | TypeDefText d -> Some d.intf - | EnumCaseText e -> Some e.intf - | _ -> None) - [ - yield! children - yield! typeDefs - for item in items do - match item with - | Binding b -> yield! Binding.emitForInterface b - | Comment c -> yield c - | _ -> () - yield! exports.intf - ] + let currentScope : CurrentScope = !!flags + + let emitEnumCase (e: {| name: string; ty: text; comments: Comment list |}) = + let moduleName = Naming.moduleName e.name + let types = + tprintf "module %s : " moduleName +@ "{ type t = " + e.ty +@ " }" + let attrs = scopeToAttr currentScope [Attr.External.val_] + let intf = [ + yield str $"type t = {e.ty}" + yield Statement.external attrs "value" (str "t") e.name + ] + let impl = [ + yield Statement.open_ moduleName + yield str "type t = t" + yield Statement.external attrs "value" (str "t") e.name + ] + let m content = {| name = moduleName; origName = e.name; content = content; comments = emitComments e.comments |} + {| types = types + intf = Statement.moduleSig (m intf) + impl = Statement.moduleVal (m (if isLinear then intf else impl)) + |} + + let emitTypeDefText (e: {| name: string; tyargs:(TypeParam * text) list; isRec: bool; body: text option; shouldAssert: bool |}) = + let actual = Statement.typeAlias e.isRec e.name (e.tyargs |> List.map snd) e.body + let alias = + let tmp = + Statement.typeAlias false e.name (e.tyargs |> List.map snd) + (Type.appOpt (str e.name) (e.tyargs |> List.map snd) |> Some) + match e.body, e.shouldAssert with + | _, false | None, _ -> tmp + | Some b, true -> tmp +@ " = " + b + {| types = actual; intf = actual; impl = alias |} + + let rec f = function + | ImportText t -> ImportText t + | TypeAliasText t -> TypeAliasText t + | TypeDefText d -> TypeDefText (emitTypeDefText d) + | Binding b -> Binding (b renamer currentScope) + | EnumCaseText e -> EnumCaseText (emitEnumCase e) + | Comment c -> Comment c + match st.value with None -> [] | Some v -> v.items |> List.map f + + let imports = + items |> List.choose (function ImportText t -> Some t | _ -> None) - let impl = - let children = - children - |> List.filter (fun (_, _, c) -> c.impl |> List.isEmpty |> not) - |> List.map (fun (k, openTypesModule, c) -> - let content = - if openTypesModule then - Statement.open_ k.name :: c.imports @ c.impl - else - c.imports @ c.impl - {| k with content = content; comments = c.comments |}) - |> Statement.moduleValMany - let typeDefs = - items |> List.choose (function - | TypeAliasText t -> Some t - | TypeDefText d -> Some d.impl - | EnumCaseText e -> Some e.impl - | _ -> None) - [ - yield! children - yield! typeDefs - for item in items do - match item with - | Binding b -> yield! Binding.emitForImplementation b - | Comment c -> yield c - | _ -> () - yield! exports.impl - ] + let types = + if isLinear then [] + else + let items = + items |> List.choose (function + | TypeDefText x | EnumCaseText x -> Some x.types + | _ -> None) + let children = + children + |> List.filter (fun (_, _, c) -> c.types |> List.isEmpty |> not) + |> List.map (fun (k, _, c) -> {| k with content = c.imports @ c.types; comments = [] |}) + |> Statement.moduleSCC dt Statement.moduleSigRec Statement.moduleSigNonRec ctx + children @ items + + let exports = + st.value + |> Option.map (fun m -> m.exports |> emitExportModule ctx) + |> Option.defaultValue EmitModuleResult.empty + + let intf = + let children = + children + |> List.filter (fun (_, _, c) -> c.intf |> List.isEmpty |> not) + |> List.map (fun (k, _, c) -> + let content = c.imports @ c.intf + {| k with content = content; comments = c.comments |}) + |> Statement.moduleSigRec + let typeDefs = + items |> List.choose (function + | TypeAliasText t -> Some t + | TypeDefText x | EnumCaseText x -> Some x.intf + | _ -> None) + [ + yield! children + yield! typeDefs + for item in items do + match item with + | Binding b -> yield! Binding.emitForInterface b + | Comment c -> yield c + | _ -> () + yield! exports.intf + ] - let comments = - match st.value with None -> [] | Some v -> v.comments + let impl = + let children = + children + |> List.filter (fun (_, _, c) -> c.impl |> List.isEmpty |> not) + |> List.map (fun (k, openTypesModule, c) -> + let content = + if not isLinear && openTypesModule then + Statement.open_ k.name :: c.imports @ c.impl + else + c.imports @ c.impl + {| k with content = content; comments = c.comments |}) + |> Statement.moduleSCC dt Statement.moduleValMany Statement.moduleValMany ctx + let typeDefs = + items |> List.choose (function + | TypeAliasText t -> Some t + | TypeDefText d -> if isLinear then Some d.types else Some d.impl + | EnumCaseText x -> Some x.impl + | _ -> None) + [ + yield! children + yield! typeDefs + for item in items do + match item with + | Binding b -> yield! Binding.emitForImplementation b + | Comment c -> yield c + | _ -> () + yield! exports.impl + ] - {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} + let comments = + match st.value with None -> [] | Some v -> v.comments + + {| imports = imports; types = types; intf = intf; impl = impl; comments = comments |} + go flags ctx st and emitExportModule (ctx: Context) (exports: ExportItem list) : EmitModuleResult = let emitModuleAlias name (i: Ident) = @@ -1806,7 +1821,7 @@ and emitExportModule (ctx: Context) (exports: ExportItem list) : EmitModuleResul go isFirst acc rest let st = go true Trie.empty exports - st |> emitModule {| isReservedModule = true; jsModule = None; scopeRev = [] |} ctx Trie.empty + st |> emitModule Trie.empty {| isReservedModule = true; jsModule = None; scopeRev = [] |} ctx let header = [ str "@@warning(\"-27-32-33-44\")" @@ -1823,10 +1838,12 @@ let setTyperOptions (ctx: IContext) = ctx.options.noExtendsInTyprm <- true let emitTypes (types: text list) : text list = - [ - Statement.moduleSigRec1 "Types" types - Statement.open_ "Types" - ] + if List.isEmpty types then [] + else + [ + Statement.moduleSigRec1 "Types" types + Statement.open_ "Types" + ] let emitReferenceTypeDirectives (ctx: Context) (src: SourceFile) : text list = let refs = @@ -1928,7 +1945,7 @@ let private emitImpl (sources: SourceFile list) (info: PackageInfo option) (ctx: if hasExport then Some moduleName else None {| jsModule = jsModule; scopeRev = []; isReservedModule = false |} let dt = DependencyTrie.ofTrie (StructuredTextNode.getReferences ctx) st - let m = emitModule flags ctx dt st + let m = emitModule dt flags ctx st let opens = [ yield Statement.open_ "Js" From f8aeb9f1423d0eb19b1e4796ece267a88783da64 Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 9 Nov 2022 18:53:30 +0900 Subject: [PATCH 42/56] Add --no-types-module option --- src/Targets/ReScript/Common.fs | 15 ++++++++++++--- src/Targets/ReScript/Writer.fs | 22 +++++++++++++++++----- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index a70bc1db..970505ec 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -72,12 +72,14 @@ type Options = // output options abstract outputDir: string option with get abstract resi: bool with get - // code generator options + // typer options abstract numberAsInt: bool with get, set abstract subtyping: Subtyping list with get, set abstract inheritWithTags: FeatureFlag with get, set + // code generator options abstract simplify: Simplify list with get, set abstract readableNames: bool with get, set + abstract noTypesModule: bool with get, set module Options = open Fable.Core.JsInterop @@ -203,7 +205,8 @@ module Options = .group( !^ResizeArray[ "simplify"; - "human-readable-anonymous-interface-names"; + "readable-names"; + "no-types-module" ], "Code Generator Options:") .addCommaSeparatedStringSet( @@ -219,6 +222,12 @@ module Options = descr="Try to use more readable names instead of AnonymousInterfaceN.", defaultValue = false ) + .addFlag( + "no-types-module", + (fun (o: Options) -> o.noTypesModule), + descr="Unsafe. Do not emit Types module even if there are recursive modules.", + defaultValue = false + ) .middleware(!^validate) @@ -231,4 +240,4 @@ type Output = { res: text } -let [] stdlib: string = jsNative \ No newline at end of file +let [] stdlib: string = jsNative diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index ffde5168..ba051299 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -929,11 +929,9 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | InheritingType.Other t -> [t]) |> List.map (getKnownTypes innerCtx) - // We only need the anonymous interfaces that appear in the members yield c.members |> Seq.collect (snd >> findTypesInClassMember (knownTypeFinder innerCtx) ()) - // |> Seq.filter (function KnownType.AnonymousInterface _ -> true | _ -> false) |> Set.ofSeq yield! @@ -1617,8 +1615,8 @@ module EmitModuleResult = let empty : EmitModuleResult = {| imports = []; types = []; impl = []; intf = []; comments = [] |} -let rec emitModule (dt: DependencyTrie) flags ctx st = - let isLinear = DependencyTrie.isLinear dt // compute only once +let rec emitModule (dt: DependencyTrie) flags (ctx: Context) st = + let isLinear = ctx.options.noTypesModule || DependencyTrie.isLinear dt // compute only once let rec go (flags: EmitModuleFlags) (ctx: Context) (st: StructuredText) : EmitModuleResult = let renamer = new OverloadRenamer() let children = @@ -1750,6 +1748,20 @@ let rec emitModule (dt: DependencyTrie) flags ctx st = ] let impl = + let fixmeRecursiveModules (ms: TextModule list) = + match ms with + | [] -> [] + | [m] -> [Statement.moduleVal m] + | _ when ctx.options.noTypesModule -> + [ yield + commentStr ( + sprintf "FIXME: start of recursive definitions (%s)" + (ms |> List.map (fun m -> m.name) |> String.concat ", ") + ) + yield! Statement.moduleValMany ms + yield commentStr "FIXME: end of recursive definitions" ] + | _ -> Statement.moduleValMany ms + let children = children |> List.filter (fun (_, _, c) -> c.impl |> List.isEmpty |> not) @@ -1760,7 +1772,7 @@ let rec emitModule (dt: DependencyTrie) flags ctx st = else c.imports @ c.impl {| k with content = content; comments = c.comments |}) - |> Statement.moduleSCC dt Statement.moduleValMany Statement.moduleValMany ctx + |> Statement.moduleSCC dt fixmeRecursiveModules Statement.moduleValMany ctx let typeDefs = items |> List.choose (function | TypeAliasText t -> Some t From 1d5b70f12cc9677cd6c4c82ce0a420cd7e210cee Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 14 Nov 2022 13:13:42 +0900 Subject: [PATCH 43/56] Proper union type optimization --- lib/Typer.fs | 12 +- src/Targets/JsOfOCaml/Writer.fs | 6 +- src/Targets/ReScript/ReScriptHelper.fs | 8 +- src/Targets/ReScript/Writer.fs | 152 ++++++++++++++++++++----- 4 files changed, 139 insertions(+), 39 deletions(-) diff --git a/lib/Typer.fs b/lib/Typer.fs index bc349519..231e0a41 100644 --- a/lib/Typer.fs +++ b/lib/Typer.fs @@ -1370,7 +1370,7 @@ type ResolvedUnion = { caseUndefined: bool typeofableTypes: Set caseArray: Set option - caseEnum: Set> + caseEnum: Set> discriminatedUnions: Map> otherTypes: Set } @@ -1393,8 +1393,8 @@ module ResolvedUnion = ru.caseEnum |> Set.toSeq |> Seq.map (function - | Choice1Of2 ({ name = ty }, { name = name; value = Some value }) -> sprintf "%s.%s=%s" ty name (Literal.toString value) - | Choice1Of2 ({ name = ty }, { name = name; value = None }) -> sprintf "%s.%s=?" ty name + | Choice1Of2 ({ name = ty }, { name = name; value = Some value }, _) -> sprintf "%s.%s=%s" ty name (Literal.toString value) + | Choice1Of2 ({ name = ty }, { name = name; value = None }, _) -> sprintf "%s.%s=?" ty name | Choice2Of2 l -> Literal.toString l) yield sprintf "enum<%s>" (cases |> String.concat " | ") for k, m in ru.discriminatedUnions |> Map.toSeq do @@ -1411,7 +1411,7 @@ module ResolvedUnion = let hasUndefined = nullOrUndefined |> List.contains (Prim Undefined) {| hasNull = hasNull; hasUndefined = hasUndefined; rest = rest |} - let rec private getEnumFromUnion ctx (u: UnionType) : Set> * UnionType = + let rec private getEnumFromUnion ctx (u: UnionType) : Set> * UnionType = let (|Dummy|) _ = [] let rec go t = @@ -1429,9 +1429,9 @@ module ResolvedUnion = let bindings = Type.createBindings i.name loc a.typeParams tyargs go (a.target |> Type.substTypeVar bindings ()) | Definition.Enum e -> - e.cases |> Seq.map (fun c -> Choice1Of2 (Choice1Of2 (e, c))) + e.cases |> Seq.map (fun c -> Choice1Of2 (Choice1Of2 (e, c, t))) | Definition.EnumCase (c, e) -> - Seq.singleton (Choice1Of2 (Choice1Of2 (e, c))) + Seq.singleton (Choice1Of2 (Choice1Of2 (e, c, t))) | _ -> Seq.empty let result = i |> Ident.getDefinitions ctx diff --git a/src/Targets/JsOfOCaml/Writer.fs b/src/Targets/JsOfOCaml/Writer.fs index 9aabffa9..ddd76fa6 100644 --- a/src/Targets/JsOfOCaml/Writer.fs +++ b/src/Targets/JsOfOCaml/Writer.fs @@ -161,11 +161,11 @@ module OverrideFunc = | Some text -> Some text | None -> f1 _flags _emitType _ctx ty -let emitEnum (flags: EmitTypeFlags) ctx (cases: Set>) = +let emitEnum (flags: EmitTypeFlags) ctx (cases: Set>) = let forceSkipAttr text = if flags.forceSkipAttributes then empty else text let usedValues = cases - |> Seq.choose (function Choice1Of2 (_, { value = v }) -> v | _ -> None) + |> Seq.choose (function Choice1Of2 (_, { value = v }, _) -> v | _ -> None) |> Set.ofSeq let cases = cases @@ -173,7 +173,7 @@ let emitEnum (flags: EmitTypeFlags) ctx (cases: Set Set.filter (function Choice2Of2 l when usedValues |> Set.contains l -> false | _ -> true) // Convert to identifiers while merging duplicate enum cases |> Set.map (function - | Choice1Of2 (e, c) -> enumCaseToIdentifier e c |> str, c.value + | Choice1Of2 (e, c, _) -> enumCaseToIdentifier e c |> str, c.value | Choice2Of2 l -> "L_" @+ literalToIdentifier ctx l, Some l) between "[" "]" (concat (str " | ") [ for name, value in Set.toSeq cases do diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 30543552..a9a1c937 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -310,9 +310,11 @@ module Type = let void_ = str "unit" let string = str "string" let boolean = str "bool" + let int = str "int" + let float = str "float" let number (opt: Options) = - if opt.numberAsInt then str "int" - else str "float" + if opt.numberAsInt then int + else float let array = str "array" let readonlyArray = str "array" let option t = app (str "option") [t] @@ -518,4 +520,4 @@ module Statement = modules |> List.filter (fun x -> sccSet |> Set.contains x.origName |> not) |> emitNonRec - sccModules @ otherModules \ No newline at end of file + sccModules @ otherModules diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index ba051299..03d81b51 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -32,13 +32,6 @@ module State = type Context = TyperContext module Context = TyperContext -type Variance = Covariant | Contravariant | Invariant with - static member (~-) (v: Variance) = - match v with - | Covariant -> Contravariant - | Contravariant -> Covariant - | Invariant -> Invariant - type Label = | Case of text * text list | TagType of text * text list @@ -52,9 +45,7 @@ type [] External = type EmitTypeFlags = { resolveUnion: bool needParen: bool - variance: Variance external: External - simplifyContravariantUnion: bool avoidTheseArgumentNames: Set } @@ -63,9 +54,7 @@ module EmitTypeFlags = { resolveUnion = true needParen = false - variance = Covariant external = External.None - simplifyContravariantUnion = false avoidTheseArgumentNames = Set.empty } @@ -73,7 +62,6 @@ module EmitTypeFlags = { flags with external = External.None } let ofFuncArg isVariadic flags = { flags with - variance = -flags.variance external = match flags.external with | External.Root _ -> External.Argument isVariadic @@ -347,18 +335,130 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte | _ -> Type.curriedArrow (args ()) (retTy flags) |> paren and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (u: UnionType) : text = - // TODO: more classification - let u = ResolvedUnion.checkNullOrUndefined u - let rest = - let rest = u.rest |> List.map (emitTypeImpl (EmitTypeFlags.noExternal flags) overrideFunc ctx) - if List.isEmpty rest then Type.never - else Type.union rest - match u.hasNull, u.hasUndefined with - | true, _ | _, true when flags.external = External.Return true -> Type.option rest - | true, true -> Type.null_or_undefined_or rest - | true, false -> Type.null_or rest - | false, true -> Type.undefined_or rest - | false, false -> rest + if flags.resolveUnion = false then + u.types + |> List.distinct + |> List.map (emitTypeImpl (EmitTypeFlags.noExternal flags) overrideFunc ctx) + |> Type.union + else if flags.external = External.Return true then + let u = ResolvedUnion.checkNullOrUndefined u + let rest = + if List.isEmpty u.rest then Type.never + else + let t = Union { types = u.rest } + emitTypeImpl (EmitTypeFlags.noExternal flags) overrideFunc ctx t + match u.hasNull, u.hasUndefined with + | true, _ | _, true -> Type.option rest + | false, false -> rest + else + let u = ResolvedUnion.resolve ctx u + + let treatEnum (cases: Set>) = + let handleLiteral l attr ty = + match l with + | LString s -> Choice1Of2 {| name = Choice1Of2 s; value = None; attr = attr |} + | LInt i -> Choice1Of2 {| name = Choice2Of2 i; value = None; attr = attr |} + | LFloat _ -> Choice2Of2 (ty |? Type.float) + | LBool _ -> Choice2Of2 (ty |? Type.boolean) + let cases = [ + for c in cases do + match c with + | Choice1Of2 (_, _, ty) -> + let ty = emitTypeImpl (EmitTypeFlags.noExternal flags) overrideFunc ctx ty + yield Choice2Of2 ty + | Choice2Of2 l -> yield handleLiteral l None None + ] + let cases, rest = List.splitChoice2 cases + [ + if List.isEmpty cases |> not then + yield Type.polyVariant cases + yield! rest + ] + + let treatArray (ts: Set) = + // TODO: think how to map multiple array cases properly + let elemT = + let elemT = + match Set.toList ts with + | [t] -> t + | ts -> Union { types = ts } + emitTypeImpl (EmitTypeFlags.noExternal flags) overrideFunc ctx elemT + Type.app Type.array [elemT] + + let treatDUMany du = + // TODO: anonymous DU? + let types = + du + |> Map.toList + |> List.collect (fun (_, cases) -> Map.toList cases) + |> List.map (fun (_, t) -> t) + types + |> List.map (emitTypeImpl (EmitTypeFlags.noExternal { flags with resolveUnion = false }) overrideFunc ctx) + |> List.distinct + + let baseTypes = [ + if not (Set.isEmpty u.caseEnum) then + yield! treatEnum u.caseEnum + if not (Map.isEmpty u.discriminatedUnions) then + yield! treatDUMany u.discriminatedUnions + match u.caseArray with + | Some ts -> yield treatArray ts + | None -> () + for t in u.otherTypes do + yield emitTypeImpl (EmitTypeFlags.noExternal { flags with resolveUnion = false }) overrideFunc ctx t + ] + + let case name value = {| name = Choice1Of2 name; value = value; attr = None |} + let genPoly unwrap = + let cases = [ + for t in u.typeofableTypes do + match t with + | Typeofable.String -> yield case "String" (Some Type.string) + | Typeofable.Number -> yield case "Number" (Some (Type.number ctx.options)) + | Typeofable.Boolean -> yield case "Boolean" (Some Type.boolean) + | Typeofable.Symbol -> yield case "Symbol" (Some Type.symbol) + | Typeofable.BigInt -> yield case "BigInt" (Some Type.bigint) + + if u.caseNull then + yield case "Null" (if unwrap then Some Type.null_ else None) + if u.caseUndefined then + yield case "Undefined" (if unwrap then Some Type.undefined else None) + + match List.distinct baseTypes with + | [] -> () + | ts -> + if unwrap then + for i, t in ts |> List.indexed do + yield case (sprintf "U%d" (i+1)) (Some t) + else + yield case "Other" (Some (Type.union ts)) + ] + Type.polyVariant cases + + let createNullable isNull isUndefined t = + match isNull, isUndefined with + | false, false -> t + | true, false -> Type.null_or t + | false, true -> Type.undefined_or t + | true, true -> Type.null_or_undefined_or t + + let emitTypeofableType t = emitTypeImpl flags overrideFunc ctx (TypeofableType.toType t) + + let isExternalArg = match flags.external with External.Argument _ -> true | _ -> false + + match baseTypes, Set.toList u.typeofableTypes, u.caseNull, u.caseUndefined with + | [], [], false, false -> impossible "emitUnion_empty_union" + | [], [], true, false -> Type.null_ + | [], [], false, true -> Type.undefined + | [], [], true, true -> Type.null_or_undefined_or Type.never + | [t], [], isNull, isUndefined -> createNullable isNull isUndefined t + | ts, [], isNull, isUndefined when not isExternalArg -> + createNullable isNull isUndefined (Type.union ts) + | [], [t], isNull, isUndefined -> createNullable isNull isUndefined (emitTypeofableType t) + | _, _, _, _ -> + match flags.external with + | External.Argument _ -> Attr.PolyVariant.unwrap +@ " " + genPoly true + | _ -> Type.app (str "Primitive.t") [genPoly false] /// `[ #A | #B | ... ]` and emitLabels (ctx: Context) labels = @@ -621,7 +721,6 @@ let extValue flags overrideFunc ctx (t: Type) = ty, attr let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: bool) (ma: MemberAttribute) m = - let flags = { flags with simplifyContravariantUnion = true } let emitType_ = emitTypeImpl flags overrideFunc let comments = emitComments ma.comments @@ -1052,7 +1151,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c let builder = let emitType_ ctx ty = - emitTypeImpl { flags with needParen = true; variance = Contravariant } overrideFunc ctx ty + emitTypeImpl { flags with needParen = true } overrideFunc ctx ty if not c.isPOJO then [] else let field (fl: FieldLike) = @@ -1362,7 +1461,6 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured /// convert interface members to appropriate statements let intfToStmts (moduleIntf: Class<_>) ctx flags overrideFunc = - let flags = { flags with simplifyContravariantUnion = true } let inline extFunc ft = extFunc flags overrideFunc ctx ft let inline func ft = func flags overrideFunc ctx ft let inline newableFunc ft = newableFunc flags overrideFunc ctx ft From 759108bb62fd8437f4244024b27bf06c05c7d8fa Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 14 Nov 2022 13:21:20 +0900 Subject: [PATCH 44/56] Proper union type optimization (2) --- src/Targets/ReScript/Writer.fs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 03d81b51..2c2e780b 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -426,6 +426,7 @@ and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) match List.distinct baseTypes with | [] -> () + | [t] -> yield case "Other" (Some t) | ts -> if unwrap then for i, t in ts |> List.indexed do From 1cc321aa79e726e156b6701d11060dccc0c82905 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 17 Jul 2023 11:56:41 +0900 Subject: [PATCH 45/56] Rebase to main --- .github/workflows/ci.yml | 4 +-- build/build.fs | 24 ++++++++--------- src/Targets/ReScript/Writer.fs | 23 +++++++++++----- test/res/src/placeholders/ReadonlyMap.res | 1 + test/res/yarn.lock | 32 +++++++++++------------ 5 files changed, 47 insertions(+), 37 deletions(-) create mode 100644 test/res/src/placeholders/ReadonlyMap.res diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2f5d5112..5e28e1f1 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -65,9 +65,9 @@ jobs: os: - ubuntu-latest dotnet: - - 5.0.x + - 6.0.x node-version: - - 16.x + - 20.x runs-on: ${{ matrix.os }} diff --git a/build/build.fs b/build/build.fs index df04beff..c4a3fc6e 100644 --- a/build/build.fs +++ b/build/build.fs @@ -77,21 +77,25 @@ let setup () = Target.create "Test" ignore - "Clean" ?=> "Build" + Target.create "Publish" ignore - "Clean" - ?=> "YarnInstall" + "YarnInstall" ==> "Restore" ==> "Prepare" - ?=> "Build" "Prepare" - ?=> "BuildForTest" - ?=> "BuildForPublish" + ==> "BuildForTest" ==> "Build" "Prepare" - ?=> "Watch" + ==> "BuildForPublish" + + "Prepare" + ==> "Watch" + + "Clean" + ?=> "BuildForTest" ?=> "Build" ?=> "Test" + ?=> "BuildForPublish" ?=> "Publish" // Test targets @@ -270,8 +274,6 @@ module Publish = inDirectory targetDir <| fun () -> dune "build" let setup () = - Target.create "Publish" <| fun _ -> () - Target.create "PublishNpm" <| fun _ -> Npm.updateVersion () @@ -285,10 +287,6 @@ module Publish = ==> "PublishJsoo" ==> "Publish" - "TestJsoo" ==> "PublishJsoo" - - "Build" ?=> "Test" ?=> "Publish" - // Utility targets module Utility = diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 2c2e780b..fed81af0 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -897,6 +897,7 @@ let emitTypeAliasesImpl (baseName: string) flags overrideFunc (ctx: Context) + loc (typrms: TypeParam list) (target: text option) (lines: {| name: string; tyargs:(TypeParam * text) list; target: text option; isOverload: bool |} -> 'a list) = @@ -911,16 +912,26 @@ let emitTypeAliasesImpl let name = Naming.createTypeNameOfArity arity None baseName let tyargs' = List.take arity tyargs let typrms' = List.take arity typrms + + let bindings = + createBindings (ctx.currentNamespace @ [name]) loc + (typrms |> List.skip arity) + (typrms |> List.skip arity |> List.map (fun t -> + match t.defaultType with + | None -> impossible "emitTypeAliases" + | Some t -> t + )) + let target = Type.appOpt (str baseName) [ for tyarg in tyargs' do yield tyarg for t in typrms |> List.skip arity do - match t.defaultType with - | None -> impossible "emitTypeAliases" - | Some t -> yield emitType_ ctx t + let t' = repeatUntilEquilibrium (substTypeVar bindings ctx) (TypeVar t.name) + yield emitType_ ctx t' ] + yield! lines {| name = name; tyargs = List.zip typrms' tyargs'; target = Some target; isOverload = true |} ] @@ -1084,7 +1095,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c if useTags && innerCtx.options.inheritWithTags.HasProvide then let alias = emitTypeAliasesImpl - "tags" flags overrideFunc innerCtx c.typeParams (Some emittedLabels) + "tags" flags overrideFunc innerCtx c.loc c.typeParams (Some emittedLabels) (fun x -> [Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target]) |> concat newline alias |> TypeAliasText |> Some @@ -1129,7 +1140,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | ClassKind.ExportDefaultClass x -> getSelfTyText x.orig | ClassKind.AnonymousInterface _ -> fallback - emitTypeAliasesImpl "t" flags overrideFunc innerCtx c.typeParams selfTyText.ty (fun x -> + emitTypeAliasesImpl "t" flags overrideFunc innerCtx c.loc c.typeParams selfTyText.ty (fun x -> if not x.isOverload then [TypeDefText {| name = x.name; tyargs = x.tyargs; body = x.target; isRec = selfTyText.isRec; shouldAssert = false |}] else @@ -1569,7 +1580,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let isRec = knownTypes |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) let items = - emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.typeParams (emitSelfType ctx ta.target |> Some) (fun x -> + emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.loc ta.typeParams (emitSelfType ctx ta.target |> Some) (fun x -> if not x.isOverload then [TypeDefText {| name = x.name; tyargs = x.tyargs; body = x.target; isRec = false; shouldAssert = false |}] else diff --git a/test/res/src/placeholders/ReadonlyMap.res b/test/res/src/placeholders/ReadonlyMap.res new file mode 100644 index 00000000..77030897 --- /dev/null +++ b/test/res/src/placeholders/ReadonlyMap.res @@ -0,0 +1 @@ +type t<'k, 'v> \ No newline at end of file diff --git a/test/res/yarn.lock b/test/res/yarn.lock index ddfd35d7..ac450546 100644 --- a/test/res/yarn.lock +++ b/test/res/yarn.lock @@ -65,13 +65,13 @@ chalk@^5.0.1: resolved "https://registry.yarnpkg.com/chalk/-/chalk-5.0.1.tgz#ca57d71e82bb534a296df63bbacc4a1c22b2a4b6" integrity sha512-Fo07WOYGqMfCWHOzSXOt2CxDbC6skS/jO9ynEcmpANMoPrD+W1r1K6Vx7iNm+AQmETU1Xr2t+n8nzkV9t6xh3w== -cliui@^7.0.2: - version "7.0.4" - resolved "https://registry.yarnpkg.com/cliui/-/cliui-7.0.4.tgz#a0265ee655476fc807aea9df3df8df7783808b4f" - integrity sha512-OcRE68cOsVMXp1Yvonl/fzkQOyjLSu/8bhPDfQt0e0/Eb283TKP20Fs2MqoPsr9SwA595rRCA+QMzYc9nBP+JQ== +cliui@^8.0.1: + version "8.0.1" + resolved "https://registry.yarnpkg.com/cliui/-/cliui-8.0.1.tgz#0c04b075db02cbfe60dc8e6cf2f5486b1a3608aa" + integrity sha512-BSeNnyus75C4//NQ9gQt1/csTXyo/8Sb+afLAkzAptFuMsod9HFokGNudZpi/oQV73hnVK+sR+5PVRMd+Dr7YQ== dependencies: string-width "^4.2.0" - strip-ansi "^6.0.0" + strip-ansi "^6.0.1" wrap-ansi "^7.0.0" color-convert@^1.9.0: @@ -166,10 +166,10 @@ supports-color@^5.3.0: dependencies: has-flag "^3.0.0" -typescript@4.7: - version "4.7.4" - resolved "https://registry.yarnpkg.com/typescript/-/typescript-4.7.4.tgz#1a88596d1cf47d59507a1bcdfb5b9dfe4d488235" - integrity sha512-C0WQT0gezHuw6AdY1M2jxUO83Rjf0HP7Sk1DtXj6j1EwkQNZrHAg2XPWlq62oqEhYvONq5pkC2Y9oPljWToLmQ== +typescript@^5.1.6: + version "5.1.6" + resolved "https://registry.yarnpkg.com/typescript/-/typescript-5.1.6.tgz#02f8ac202b6dad2c0dd5e0913745b47a37998274" + integrity sha512-zaWCozRZ6DLEWAWFrVDz1H6FVXzUSfTy5FUMWsQlU8Ym5JP9eO4xkTIROFCQvhQf61z6O/G6ugw3SgAnvvm+HA== wrap-ansi@^7.0.0: version "7.0.0" @@ -185,20 +185,20 @@ y18n@^5.0.5: resolved "https://registry.yarnpkg.com/y18n/-/y18n-5.0.8.tgz#7f4934d0f7ca8c56f95314939ddcd2dd91ce1d55" integrity sha512-0pfFzegeDWJHJIAmTLRP2DwHjdF5s7jo9tuztdQxAhINCdvS+3nGINqPd00AphqJR/0LhANUS6/+7SCb98YOfA== -yargs-parser@^21.0.0: +yargs-parser@^21.1.1: version "21.1.1" resolved "https://registry.yarnpkg.com/yargs-parser/-/yargs-parser-21.1.1.tgz#9096bceebf990d21bb31fa9516e0ede294a77d35" integrity sha512-tVpsJW7DdjecAiFpbIB1e3qxIQsE6NoPc5/eTdrbbIC4h0LVsWhnoa3g+m2HclBIujHzsxZ4VJVA+GUuc2/LBw== -yargs@17.5.1: - version "17.5.1" - resolved "https://registry.yarnpkg.com/yargs/-/yargs-17.5.1.tgz#e109900cab6fcb7fd44b1d8249166feb0b36e58e" - integrity sha512-t6YAJcxDkNX7NFYiVtKvWUz8l+PaKTLiL63mJYWR2GnHq2gjEWISzsLp9wg3aY36dY1j+gfIEL3pIF+XlJJfbA== +yargs@^17.5.1: + version "17.7.2" + resolved "https://registry.yarnpkg.com/yargs/-/yargs-17.7.2.tgz#991df39aca675a192b816e1e0363f9d75d2aa269" + integrity sha512-7dSzzRQ++CKnNI/krKnYRV7JKKPUXMEh61soaHKg9mrWEhzFWhFnxPxGl+69cD1Ou63C13NUPCnmIcrvqCuM6w== dependencies: - cliui "^7.0.2" + cliui "^8.0.1" escalade "^3.1.1" get-caller-file "^2.0.5" require-directory "^2.1.1" string-width "^4.2.3" y18n "^5.0.5" - yargs-parser "^21.0.0" + yargs-parser "^21.1.1" From 5c86226925903b2b6e20d62a4098ad8abc8bd254 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 17 Jul 2023 13:26:10 +0900 Subject: [PATCH 46/56] Upgrade ReScript to v11 beta --- .github/workflows/publish.yml | 2 +- .gitignore | 4 ++-- build/build.fs | 10 ++++----- {dist_jsoo => dist/jsoo}/.gitignore | 0 {dist_jsoo => dist/jsoo}/dune-project | 0 {dist_jsoo => dist/jsoo}/src/dune | 0 {dist_jsoo => dist/jsoo}/src/ts2ocaml.ml | 0 .../jsoo}/ts2ocaml-jsoo-stdlib.opam | 0 {dist_rescript => dist/res}/.gitignore | 0 {dist_rescript => dist/res}/bsconfig.json | 0 {dist_rescript => dist/res}/package.json | 2 +- {dist_rescript => dist/res}/src/ts2ocaml.res | 0 dist/res/yarn.lock | 8 +++++++ dist_rescript/package-lock.json | 13 ------------ docs/development.md | 21 ++++++++++--------- package.json | 10 ++++----- src/Targets/ReScript/Common.fs | 2 +- src/Targets/ReScript/ReScriptHelper.fs | 4 ++-- src/Targets/ReScript/Writer.fs | 6 +++--- test/res/package.json | 2 +- test/res/yarn.lock | 8 +++---- webpack.config.js | 2 +- yarn.lock | 8 +++---- 23 files changed, 49 insertions(+), 53 deletions(-) rename {dist_jsoo => dist/jsoo}/.gitignore (100%) rename {dist_jsoo => dist/jsoo}/dune-project (100%) rename {dist_jsoo => dist/jsoo}/src/dune (100%) rename {dist_jsoo => dist/jsoo}/src/ts2ocaml.ml (100%) rename {dist_jsoo => dist/jsoo}/ts2ocaml-jsoo-stdlib.opam (100%) rename {dist_rescript => dist/res}/.gitignore (100%) rename {dist_rescript => dist/res}/bsconfig.json (100%) rename {dist_rescript => dist/res}/package.json (89%) rename {dist_rescript => dist/res}/src/ts2ocaml.res (100%) create mode 100644 dist/res/yarn.lock delete mode 100644 dist_rescript/package-lock.json diff --git a/.github/workflows/publish.yml b/.github/workflows/publish.yml index 85916da7..861a2f6c 100644 --- a/.github/workflows/publish.yml +++ b/.github/workflows/publish.yml @@ -57,7 +57,7 @@ jobs: env: REPO: self BRANCH: jsoo-stdlib - FOLDER: dist_jsoo + FOLDER: dist/jsoo TAG: jsoo-stdlib-${{ github.event.release.tag_name }} GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} MESSAGE: "Build ({sha}) {msg}" diff --git a/.gitignore b/.gitignore index 4de5b3e7..b216a232 100644 --- a/.gitignore +++ b/.gitignore @@ -307,5 +307,5 @@ test/jsoo/src/*.mli test/jsoo/src/stub.js # Dist artifacts -dist -dist_jsoo/src/ts2ocaml_*.ml* +dist/js/ +dist/jsoo/src/ts2ocaml_*.ml* diff --git a/build/build.fs b/build/build.fs index c4a3fc6e..55981837 100644 --- a/build/build.fs +++ b/build/build.fs @@ -46,7 +46,7 @@ let setup () = Target.create "Clean" <| fun _ -> !! "src/bin" ++ "src/obj" - ++ distDir + ++ (distDir "js") // clean ts2ocaml.js ++ "src/.fable" |> Seq.iter Shell.cleanDir @@ -122,7 +122,7 @@ module Test = let packages = [ // "full" package involving a lot of inheritance - "full", !! "node_modules/typescript/lib/typescript.d.ts", ["--safe-arity=off"]; + "full", !! "node_modules/typescript/lib/typescript.d.ts", []; // "full" packages involving a lot of dependencies (which includes some "safe" packages) "safe", !! "node_modules/@types/scheduler/tracing.d.ts", []; @@ -239,7 +239,7 @@ module Publish = Yarn.exec $"version --new-version {newVersion} --no-git-tag-version" id module Jsoo = - let targetDir = "./dist_jsoo" + let targetDir = distDir "jsoo" let duneProject = targetDir "dune-project" let copyArtifacts () = @@ -262,10 +262,10 @@ module Publish = if result.Success then let oldVersion = result.Groups.[1].Value if oldVersion <> newVersion then - printfn $"* updating version in dist_jsoo/dune-project from '{oldVersion}' to '{newVersion}'." + printfn $"* updating version in dist/jsoo/dune-project from '{oldVersion}' to '{newVersion}'." content |> String.replace result.Value $"(version {newVersion})" else - printfn $"* version in dist_jsoo/dune-project not updated ('{newVersion}')." + printfn $"* version in dist/jsoo/dune-project not updated ('{newVersion}')." content else content ) diff --git a/dist_jsoo/.gitignore b/dist/jsoo/.gitignore similarity index 100% rename from dist_jsoo/.gitignore rename to dist/jsoo/.gitignore diff --git a/dist_jsoo/dune-project b/dist/jsoo/dune-project similarity index 100% rename from dist_jsoo/dune-project rename to dist/jsoo/dune-project diff --git a/dist_jsoo/src/dune b/dist/jsoo/src/dune similarity index 100% rename from dist_jsoo/src/dune rename to dist/jsoo/src/dune diff --git a/dist_jsoo/src/ts2ocaml.ml b/dist/jsoo/src/ts2ocaml.ml similarity index 100% rename from dist_jsoo/src/ts2ocaml.ml rename to dist/jsoo/src/ts2ocaml.ml diff --git a/dist_jsoo/ts2ocaml-jsoo-stdlib.opam b/dist/jsoo/ts2ocaml-jsoo-stdlib.opam similarity index 100% rename from dist_jsoo/ts2ocaml-jsoo-stdlib.opam rename to dist/jsoo/ts2ocaml-jsoo-stdlib.opam diff --git a/dist_rescript/.gitignore b/dist/res/.gitignore similarity index 100% rename from dist_rescript/.gitignore rename to dist/res/.gitignore diff --git a/dist_rescript/bsconfig.json b/dist/res/bsconfig.json similarity index 100% rename from dist_rescript/bsconfig.json rename to dist/res/bsconfig.json diff --git a/dist_rescript/package.json b/dist/res/package.json similarity index 89% rename from dist_rescript/package.json rename to dist/res/package.json index 8282c803..887a63db 100644 --- a/dist_rescript/package.json +++ b/dist/res/package.json @@ -12,6 +12,6 @@ "author": "", "license": "Apache-2.0", "dependencies": { - "rescript": "*" + "rescript": "^11.0.0-beta.3" } } diff --git a/dist_rescript/src/ts2ocaml.res b/dist/res/src/ts2ocaml.res similarity index 100% rename from dist_rescript/src/ts2ocaml.res rename to dist/res/src/ts2ocaml.res diff --git a/dist/res/yarn.lock b/dist/res/yarn.lock new file mode 100644 index 00000000..992ba920 --- /dev/null +++ b/dist/res/yarn.lock @@ -0,0 +1,8 @@ +# THIS IS AN AUTOGENERATED FILE. DO NOT EDIT THIS FILE DIRECTLY. +# yarn lockfile v1 + + +rescript@^11.0.0-beta.3: + version "11.0.0-beta.3" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.0-beta.3.tgz#f883a19aa8cb2ab162fd2c9f3d46d2c05cc5710b" + integrity sha512-j3YT3VdWMoHgwL4RydKJm9O/VIpN3NTI6keP18rZVJ8ansRKgkHYGLaIwoG6iVqSYYwBjb6d8l8oZ1Jz0fmTeQ== diff --git a/dist_rescript/package-lock.json b/dist_rescript/package-lock.json deleted file mode 100644 index a6ede281..00000000 --- a/dist_rescript/package-lock.json +++ /dev/null @@ -1,13 +0,0 @@ -{ - "name": "ts2ocaml-rescript-stdlib", - "version": "0.0.0", - "lockfileVersion": 1, - "requires": true, - "dependencies": { - "rescript": { - "version": "9.1.4", - "resolved": "https://registry.npmjs.org/rescript/-/rescript-9.1.4.tgz", - "integrity": "sha512-aXANK4IqecJzdnDpJUsU6pxMViCR5ogAxzuqS0mOr8TloMnzAjJFu63fjD6LCkWrKAhlMkFFzQvVQYaAaVkFXw==" - } - } -} diff --git a/docs/development.md b/docs/development.md index a42146ff..39543cf6 100644 --- a/docs/development.md +++ b/docs/development.md @@ -34,8 +34,9 @@ Modules with **\[\\]** does not require `open` to use. - `Main.fs` ... entry point - `test/` - `jsoo/` ... test for `js_of_ocaml` target -- `dist/` ... output directory for NPM packaging -- `dist_jsoo/` ... output directory for OPAM packaging +- `dist/` + - `js/ `... output directory for NPM packaging + - `jsoo/` ... output directory for OPAM packaging - `output/` ... temporary output directory for automated testing, etc ## Requirements @@ -54,7 +55,7 @@ Modules with **\[\\]** does not require `open` to use. ## Debugging -`./fake watch` to live update `dist/ts2ocaml.js`. +`./fake watch` to live update `dist/js/ts2ocaml.js`. It will be bundled by Webpack with the `development` mode. @@ -64,9 +65,9 @@ It will be bundled by Webpack with the `development` mode. - `yarn install` to populate `node_modules` - `dotnet restore ts2ocaml.sln` to install required F# libraries - Compile F# source files into JS source files (through Fable) -- Bundle the JS files into `dist/ts2ocaml.js` (through Webpack) +- Bundle the JS files into `dist/js/ts2ocaml.js` (through Webpack) -The resulting `dist/ts2ocaml.js` is then ready to run through `node`. +The resulting `dist/js/ts2ocaml.js` is then ready to run through `node`. ## Testing @@ -96,12 +97,12 @@ The resulting `dist/ts2ocaml.js` is then ready to run through `node`. ### Prepare for publishing the standard library for [`js_of_ocaml` target](js_of_ocaml.md) to the `jsoo-stdlib` branch -- Copy `ts2ocaml_*.mli` from `output/test_jsoo/` to `dist_jsoo/src/` -- Copy `ts2ocaml_*.ml` from `test/jsoo/_build/default/src/` to `dist_jsoo/src/` -- Set the correct `version` in `dist_jsoo/dune-project` -- Perform `dune build` in `dist_jsoo/` to generate `.opam` file and check if it compiles +- Copy `ts2ocaml_*.mli` from `output/test_jsoo/` to `dist/jsoo/src/` +- Copy `ts2ocaml_*.ml` from `test/jsoo/_build/default/src/` to `dist/jsoo/src/` +- Set the correct `version` in `dist/jsoo/dune-project` +- Perform `dune build` in `dist/jsoo/` to generate `.opam` file and check if it compiles -GitHub Action `publish.yml` is configured to push the `dist_jsoo` directory to the `jsoo-stdlib` branch. +GitHub Action `publish.yml` is configured to push the `dist/jsoo` directory to the `jsoo-stdlib` branch. ### Prepare for publishing the tool to NPM diff --git a/package.json b/package.json index 7111c385..84c1aece 100644 --- a/package.json +++ b/package.json @@ -17,13 +17,13 @@ }, "homepage": "https://github.com/ocsigen/ts2ocaml", "scripts": { - "ts2ocaml": "node ./dist/ts2ocaml.js" + "ts2ocaml": "node ./dist/js/ts2ocaml.js" }, "files": [ - "dist/" + "dist/js/" ], - "main": "./dist/ts2ocaml.js", - "bin": "./dist/ts2ocaml.js", + "main": "./dist/js/ts2ocaml.js", + "bin": "./dist/js/ts2ocaml.js", "dependencies": { "@babel/code-frame": "^7.18.6", "browser-or-node": "^2.0.0", @@ -43,7 +43,7 @@ "cdk8s": "^2.2.41", "monaco-editor": "0.40.0", "react-player": "2.12.0", - "rescript": "^10.0.0", + "rescript": "^11.0.0-beta.3", "ts2fable": "0.8.0-build.723", "webpack": "5.88.0", "webpack-cli": "5.1.0", diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 970505ec..7cf40998 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -240,4 +240,4 @@ type Output = { res: text } -let [] stdlib: string = jsNative +let [] stdlib: string = jsNative diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index a9a1c937..1aadc331 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -9,7 +9,7 @@ open DataTypes.Text module Source = open Fable.Core - let [] dom: string = jsNative + let [] dom: string = jsNative let comment text = if text = empty then empty @@ -240,7 +240,7 @@ module Type = Source.dom |> String.splitManyThenRemoveEmptyEntries ["\n"; "\r"] |> Array.filter (fun s -> s.StartsWith("type ")) - |> Array.choose (fun s -> s |> String.replace "type " "" |> String.splitMany [" = "; " (*"] |> Array.tryHead) + |> Array.choose (fun s -> s |> String.replace "type " "" |> String.splitMany [" = "; " /*"] |> Array.tryHead) |> Array.filter (fun s -> s.Length > 0 && s.ToCharArray() |> Array.forall Char.isAlphabet) |> Array.map (fun s -> Naming.upperFirst s, "Dom." + s) let ignoreCase = diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index fed81af0..bfec46d8 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -750,10 +750,10 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: | Choice2Of2 _ :: rest -> let name = sprintf "arg%d" index |> rename go (index+1) false ({| ml = str name; js = name; used = true |} :: acc) rest - | Choice1Of2 { name = name; isOptional = isOptional } :: rest -> - let ml = if isOptional then sprintf "~%s=?" name else "~" + name + | Choice1Of2 { name = name; isOptional = isOptional' } :: rest -> + let ml = if isOptional' then sprintf "~%s=?" name else "~" + name let js = name |> String.replace "'" "$p" - go (index+1) isOptional ({| ml = str ml; js = js; used = true |} :: acc) rest + go (index+1) (isOptional || isOptional') ({| ml = str ml; js = js; used = true |} :: acc) rest go 1 false [] args let body = let args = diff --git a/test/res/package.json b/test/res/package.json index c45b2177..2117d6f3 100644 --- a/test/res/package.json +++ b/test/res/package.json @@ -15,6 +15,6 @@ "@ocsigen/ts2ocaml": "link:../../" }, "dependencies": { - "rescript": "^10.0.0" + "rescript": "^11.0.0-beta.3" } } diff --git a/test/res/yarn.lock b/test/res/yarn.lock index ac450546..1f82cd1d 100644 --- a/test/res/yarn.lock +++ b/test/res/yarn.lock @@ -138,10 +138,10 @@ require-directory@^2.1.1: resolved "https://registry.yarnpkg.com/require-directory/-/require-directory-2.1.1.tgz#8c64ad5fd30dab1c976e2344ffe7f792a6a6df42" integrity sha512-fGxEI7+wsG9xrvdjsrlmL22OMTTiHRwAMroiEeMgq8gzoLC/PQr7RsRDSTLUg/bZAZtF+TVIkHc6/4RIKrui+Q== -rescript@^10.0.0: - version "10.0.0" - resolved "https://registry.yarnpkg.com/rescript/-/rescript-10.0.0.tgz#8460bc6f7d94bc580eac02d7c7efdf0a470916b8" - integrity sha512-LhNg/4+0j8NvoFeslgAeYLlzUwkq6kR6l6v8BnZ61VDTxopK2l96uT1lq5lv1aMxzMDynvE2qnX0zalre+6XxA== +rescript@^11.0.0-beta.3: + version "11.0.0-beta.3" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.0-beta.3.tgz#f883a19aa8cb2ab162fd2c9f3d46d2c05cc5710b" + integrity sha512-j3YT3VdWMoHgwL4RydKJm9O/VIpN3NTI6keP18rZVJ8ansRKgkHYGLaIwoG6iVqSYYwBjb6d8l8oZ1Jz0fmTeQ== string-width@^4.1.0, string-width@^4.2.0, string-width@^4.2.3: version "4.2.3" diff --git a/webpack.config.js b/webpack.config.js index a352dd5c..77be6bcf 100644 --- a/webpack.config.js +++ b/webpack.config.js @@ -6,7 +6,7 @@ const webpack = require('webpack'); var CONFIG = { fsharpEntry: './src/Main.fs.js', - outputDir: './dist', + outputDir: './dist/js', } var path = require("path"); diff --git a/yarn.lock b/yarn.lock index efaa8b5b..330c8f28 100644 --- a/yarn.lock +++ b/yarn.lock @@ -2732,10 +2732,10 @@ requires-port@^1.0.0: resolved "https://registry.yarnpkg.com/requires-port/-/requires-port-1.0.0.tgz#925d2601d39ac485e091cf0da5c6e694dc3dcaff" integrity sha1-kl0mAdOaxIXgkc8NpcbmlNw9yv8= -rescript@^10.0.0: - version "10.0.0" - resolved "https://registry.yarnpkg.com/rescript/-/rescript-10.0.0.tgz#8460bc6f7d94bc580eac02d7c7efdf0a470916b8" - integrity sha512-LhNg/4+0j8NvoFeslgAeYLlzUwkq6kR6l6v8BnZ61VDTxopK2l96uT1lq5lv1aMxzMDynvE2qnX0zalre+6XxA== +rescript@^11.0.0-beta.3: + version "11.0.0-beta.3" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.0-beta.3.tgz#f883a19aa8cb2ab162fd2c9f3d46d2c05cc5710b" + integrity sha512-j3YT3VdWMoHgwL4RydKJm9O/VIpN3NTI6keP18rZVJ8ansRKgkHYGLaIwoG6iVqSYYwBjb6d8l8oZ1Jz0fmTeQ== resolve-cwd@^3.0.0: version "3.0.0" From ca305eae75a9cac9407f8f903c2cff3306a1927c Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 17 Jul 2023 15:42:41 +0900 Subject: [PATCH 47/56] Adopt ReScript v11 enum representation --- src/Targets/ReScript/Writer.fs | 141 +++++++++------------------------ 1 file changed, 37 insertions(+), 104 deletions(-) diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index bfec46d8..23d26838 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -593,7 +593,7 @@ and StructuredTextItem = StructuredTextItemBase< {| name: string; tyargs: (TypeParam * text) list; isRec: bool; body: text option; shouldAssert: bool |}, (OverloadRenamer -> CurrentScope -> Binding), - {| name: string; ty: text; comments: Comment list |} + {| name: string; comments: Comment list |} > and CurrentScope = { @@ -1113,7 +1113,6 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c (Type.intf (str "'tags") +@ " constraint 'tags = " + tags |> Some) |> TypeAliasText |> Some else None - // " this resets the weird syntax highlighting let typeDefinition = let fallback = {| ty = None; isRec = false |} @@ -1241,25 +1240,7 @@ and addAnonymousInterfaceExcluding emitTypeFlags (ctx: Context) knownTypes ais ( ) current and addAnonymousInterface emitTypeFlags ctx knownTypes (current: StructuredText) = addAnonymousInterfaceExcluding emitTypeFlags ctx knownTypes [] current -type EnumType = - /// Integer enum of which first case is `0` and (n+1)th case is `n`. - | CleanInt = 0 - /// Integer enum but not 'clean' in the above sense. - | Int = 1 - /// Float enum. - | Float = 2 - /// Boolean enum. - | Boolean = 3 - /// String enum. - | String = 4 - /// Enum with integer and float cases. - | Number = 5 - /// Enum with integer and string cases. - | PolyVariant = 6 - /// Other heterogeneous enum. - | Heterogeneous = 7 - -let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enum) = +let emitEnum (ctx: Context) (current: StructuredText) (e: Enum) = let enumCaseToIdentifier (e: Enum) (c: EnumCase) = let duplicateCases = e.cases |> List.filter (fun c' -> c.value = c'.value) @@ -1273,88 +1254,43 @@ let emitEnum flags overrideFunc (ctx: Context) (current: StructuredText) (e: Enu let distinctCases = e.cases - |> List.map (fun c -> enumCaseToIdentifier e c, c.value) - |> List.distinctBy snd - let enumValues = distinctCases |> List.map snd - let enumType = - let types = - enumValues - |> List.map (function - | None -> EnumType.Heterogeneous - | Some (LString _) -> EnumType.String - | Some (LInt i) -> if i >= 0 then EnumType.Int else EnumType.Float - | Some (LFloat _) -> EnumType.Float - | Some (LBool _) -> EnumType.Boolean) - |> List.distinct - |> List.sort - match types with - | [EnumType.Int] -> - let isClean = - enumValues - |> List.map (function Some (LInt i) -> i | _ -> impossible "emitEnum_Int") - |> Seq.sort - |> Seq.mapi ((=)) - |> Seq.forall id - if isClean then EnumType.CleanInt - else EnumType.Int - | [x] -> x - | [EnumType.Int; EnumType.Float] -> EnumType.Number - | [EnumType.Int; EnumType.String] -> EnumType.PolyVariant - | _ -> EnumType.Heterogeneous - - let child (c: EnumCase) = - let ty = - match enumType with - | EnumType.Int | EnumType.String | EnumType.PolyVariant -> - let case = - match c.value with - | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} - | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} - | _ -> impossible "emitEnum_child_PolyVariant" - Type.polyVariant [case] - | _ -> str "private t" - EnumCaseText {| name = c.name; ty = ty; comments = c.comments |} + |> List.map (fun c -> enumCaseToIdentifier e c, c.value, c) + |> List.distinctBy (fun (_, value, _) -> value) + |> List.map (fun (key, value, case) -> + key, value |> Option.defaultWith (fun () -> + ctx.logger.errorf "error: the case '%s' of enum '%s' has an unknown value, which is not supported at %s" + case.name e.name case.loc.AsString + )) + + let childNode (c: EnumCase) = + EnumCaseText {| name = c.name; comments = c.comments |} let parentNode = - let items = - match enumType with - | EnumType.CleanInt -> - let cases = - distinctCases - |> List.map (fun (n, v) -> n, match v with Some (LInt i) -> i | _ -> impossible "emitEnum_parentNode_CleanInt") - |> List.sortBy snd - |> List.map fst - let casesText = - if (cases |> List.sumBy (fun s -> s.Length)) > 80 then - newline + concat newline [ - for case in cases do - yield indent (tprintf "| %s" case) + let casesText = + newline + concat newline [ + for key, value in distinctCases do + yield indent ( + concat (str " ") [ + str "|" + Attr.as_ (Term.literal value) + str key ] - else cases |> String.concat " | " |> str - [TypeDefText {| name = "t"; tyargs = []; isRec = false; body = Some casesText; shouldAssert = true |}] - | EnumType.Int | EnumType.String | EnumType.PolyVariant -> - let cases = - distinctCases - |> List.map snd - |> List.map (function - | Some (LString s) -> {| name = Choice1Of2 s; value = None; attr = None |} - | Some (LInt i) -> {| name = Choice2Of2 i; value = None; attr = None |} - | _ -> impossible "emitEnum_parentNode_PolyVariant") - [TypeDefText {| name = "t"; tyargs = []; isRec = false; body = (Type.polyVariant cases |> Some); shouldAssert = false |}] - | EnumType.Boolean -> Statement.typeAlias false "t" [] (str "private bool" |> Some) |> TypeAliasText |> List.singleton - | EnumType.Float | EnumType.Number -> - ctx.logger.warnf "an enum type '%s' contains a case with float or negative value, which is not supported in ReScript at %s" e.name e.loc.AsString - let def = "private float " @+ commentStr (sprintf "FIXME: float/negative enum (at %s)" e.loc.AsString) - [TypeDefText {| name = "t"; tyargs = []; isRec = false; body = Some def; shouldAssert = false |}] - | EnumType.Heterogeneous | _ -> - ctx.logger.warnf "a heterogeneous enum '%s' is not supported at %s" e.name e.loc.AsString - let def = Type.object +@ " " + commentStr (sprintf "FIXME: heterogeneous enum (at %s)" e.loc.AsString) - [TypeDefText {| name = "t"; tyargs = []; isRec = false; body = Some def; shouldAssert = false |}] - let items = items @ List.map child e.cases + ) + ] + let item = + TypeDefText {| + name = "t"; + tyargs = []; + isRec = false; + body = Some casesText; + shouldAssert = true + |} + let items = item :: List.map childNode e.cases let comments = e.comments |> emitComments {| StructuredTextNode.empty with items = items; comments = comments |} let exports = getExportFromStatement ctx e.name Kind.OfEnum "enum" (Enum e) + current |> add [e.name] parentNode |> set {| StructuredTextNode.empty with exports = Option.toList exports |} @@ -1573,7 +1509,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Class c -> emitClass emitTypeFlags OverrideFunc.noOverride ctx current (c.MapName Choice1Of2) ((fun _ _ _ -> []), Set.empty, None) | Enum e -> - emitEnum emitTypeFlags OverrideFunc.noOverride ctx current e + emitEnum ctx current e | TypeAlias ta -> let ctx = ctx |> Context.ofChildNamespace ta.name let knownTypes = knownTypes () @@ -1771,19 +1707,16 @@ let rec emitModule (dt: DependencyTrie) flags (ctx: Context) st = let items = let currentScope : CurrentScope = !!flags - let emitEnumCase (e: {| name: string; ty: text; comments: Comment list |}) = + let emitEnumCase (e: {| name: string; comments: Comment list |}) = let moduleName = Naming.moduleName e.name let types = - tprintf "module %s : " moduleName +@ "{ type t = " + e.ty +@ " }" - let attrs = scopeToAttr currentScope [Attr.External.val_] + tprintf "module %s : " moduleName +@ "{ type nonrec t = t }" let intf = [ - yield str $"type t = {e.ty}" - yield Statement.external attrs "value" (str "t") e.name + yield str $"type nonrec t = t" ] let impl = [ yield Statement.open_ moduleName - yield str "type t = t" - yield Statement.external attrs "value" (str "t") e.name + yield str "type nonrec t = t" ] let m content = {| name = moduleName; origName = e.name; content = content; comments = emitComments e.comments |} {| types = types From e4213e6a831f9e017ffeaa92d4447834320b55cc Mon Sep 17 00:00:00 2001 From: cannorin Date: Sun, 3 Sep 2023 16:45:33 +0900 Subject: [PATCH 48/56] Emit unboxed variant if appropriate --- dist/res/src/ts2ocaml.res | 14 +- lib/Syntax.fs | 67 ++++- lib/Typer.fs | 29 ++- src/Targets/ReScript/ReScriptHelper.fs | 87 ++++++- src/Targets/ReScript/Writer.fs | 343 ++++++++++++++----------- 5 files changed, 367 insertions(+), 173 deletions(-) diff --git a/dist/res/src/ts2ocaml.res b/dist/res/src/ts2ocaml.res index 96ef8d18..6f4dcbb0 100644 --- a/dist/res/src/ts2ocaml.res +++ b/dist/res/src/ts2ocaml.res @@ -23,7 +23,6 @@ module Unknown = { type true_ = bool type false_ = bool type symbol = Js.Types.symbol -type bigint = Js.Bigint.t type intrinsic = private string type untypedObject = any type untypedFunction = any @@ -82,7 +81,7 @@ module Intersection = { type intf<-'tags> module Primitive = { - type cases<'other> = [ #Null | #Undefined | #String(string) | #Number(float) | #Boolean(bool) | #Symbol(symbol) | #BigInt(bigint) | #Other('other) ] + type cases<'other> = [ #Null | #Undefined | #String(string) | #Number(float) | #Boolean(bool) | #Symbol(symbol) | #Bigint(Js.Bigint.t) | #Other('other) ] type t<+'cases> let return: ([< cases<'other>] as 'cases) => t<'cases> = x => @@ -94,6 +93,15 @@ module Primitive = { } })(x)`) + let null: t<[> #Null]> = %raw(`null`) + let undefined: t<[> #Undefined]> = %raw(`undefined`) + external string: string => t<[> #String(string)]> = "%identity" + external number: float => t<[> #Number(float)]> = "%identity" + external boolean: bool => t<[> #Boolean(bool)]> = "%identity" + external symbol: symbol => t<[> #Symbol(symbol)]> = "%identity" + external bigint: Js.Bigint.t => t<[> #Bigint(Js.Bigint.t)]> = "%identity" + external other: 'a => t<[> #Other('a)]> = "%identity" + external fromNull: Js.null<'a> => t<[> #Null | #Other('a) ]> = "%identity" external toNull: t<[< #Null | #Other('a) ]> => Js.null<'a> = "%identity" @@ -109,7 +117,7 @@ module Primitive = { | "number" => Obj.magic(#Number(Obj.magic(x))) | "boolean" => Obj.magic(#Boolean(Obj.magic(x))) | "symbol" => Obj.magic(#Symbol(Obj.magic(x))) - | "bigint" => Obj.magic(#BigInt(Obj.magic(x))) + | "bigint" => Obj.magic(#Bigint(Obj.magic(x))) | "undefined" => Obj.magic(#Undefined) | _ => if (Js.testAny(x)) { Obj.magic(#Null) } diff --git a/lib/Syntax.fs b/lib/Syntax.fs index 0e4cb6e8..a79251a5 100644 --- a/lib/Syntax.fs +++ b/lib/Syntax.fs @@ -230,7 +230,19 @@ and [] FullName = { and FieldLike = { name:string; isOptional:bool; value:Type } -and FuncType<'returnType> = { args:Choice list; isVariadic:bool; returnType:'returnType; loc: Location } +and FuncType<'returnType> = { + args:Choice list + isVariadic:bool + returnType:'returnType + loc: Location +} with + member this.map (f: 'returnType -> 'a) = + { + args = this.args + isVariadic = this.isVariadic + returnType = f this.returnType + loc = this.loc + } and Accessibility = Public | Protected | Private and Mutability = ReadOnly | WriteOnly | Mutable @@ -317,43 +329,75 @@ and MemberAttribute = { member this.getComments() = this.comments member this.mapComments f = { this with comments = f this.comments } -and Variable = { +and Variable<'Type> = { name: string - typ: Type + typ: 'Type isConst: bool isExported: Exported accessibility : Accessibility option comments: Comment list loc: Location } with - interface ICommented with + member this.map (f: 'Type -> 'a) = + { + name = this.name + typ = f this.typ + isConst = this.isConst + isExported = this.isExported + accessibility = this.accessibility + comments = this.comments + loc = this.loc + } + interface ICommented> with member this.getComments() = this.comments member this.mapComments f = { this with comments = f this.comments } +and Variable = Variable -and Function = { +and Function<'Type> = { name: string - typ: FuncType + typ: FuncType<'Type> typeParams: TypeParam list isExported: Exported accessibility : Accessibility option comments: Comment list loc: Location } with - interface ICommented with + member this.map (f: 'Type -> 'a) = + { + name = this.name + typ = this.typ.map f + typeParams = this.typeParams + isExported = this.isExported + accessibility = this.accessibility + comments = this.comments + loc = this.loc + } + interface ICommented> with member this.getComments() = this.comments member this.mapComments f = { this with comments = f this.comments } +and Function = Function -and TypeAlias = { +and TypeAlias<'Type> = { name: string typeParams: TypeParam list - target: Type + target: 'Type comments: Comment list isExported: Exported loc: Location } with - interface ICommented with + member this.map (f: 'Type -> 'a) = + { + name = this.name + typeParams = this.typeParams + target = f this.target + comments = this.comments + isExported = this.isExported + loc = this.loc + } + interface ICommented> with member this.getComments() = this.comments member this.mapComments f = { this with comments = f this.comments } +and TypeAlias = TypeAlias and Statement = /// ```ts @@ -404,6 +448,9 @@ and Statement = /// export ... /// ``` | Export of Export + /// ```ts + /// export ... from ... + /// ``` | ReExport of ReExport | Pattern of Pattern | UnknownStatement of {| origText: string option; comments: Comment list; loc: Location |} diff --git a/lib/Typer.fs b/lib/Typer.fs index 231e0a41..ad0c466c 100644 --- a/lib/Typer.fs +++ b/lib/Typer.fs @@ -1021,7 +1021,22 @@ module Type = |> String.replace "-" "minus" |> String.replace "." "_" match l with - | LString s -> formatString s + | LString s -> + match s with + | "\r" -> "cr" | "\n" -> "lf" | "\r\n" -> "crlf" | "\t" -> "tab" + | " " -> "whitespace" + | "/" -> "sol" | "\\" -> "bsol" | "|" -> "vert" + | "'" -> "apos" | "\"" -> "quot" | "`" -> "grave" + | "!" -> "excl" | "?" -> "quest" + | "," -> "comma" | "." -> "period" | ":" -> "colon" | ";" -> "semi" + | "+" -> "plus" | "-" -> "minus" | "*" -> "ast" | "^" -> "hat" + | "$" -> "dollar" | "&" -> "amp" | "%" -> "percnt" | "#" -> "num" | "@" -> "commat" | "_" -> "lowbar" + | "[" -> "lbrack" | "]" -> "rbrack" | "(" -> "lpar" | ")" -> "rpar" | "{" -> "lbrace" | "}" -> "rbrace" + | "<" -> "lt" | ">" -> "gt" | "=" -> "equals" + | _ -> + if System.String.IsNullOrEmpty s then "empty" + else if String.forall ((=) ' ') s then $"whitespace{s.Length}" + else formatString s | LInt i -> formatNumber i | LFloat f -> formatNumber f | LBool true -> "true" | LBool false -> "false" @@ -1373,7 +1388,17 @@ type ResolvedUnion = { caseEnum: Set> discriminatedUnions: Map> otherTypes: Set -} +} with + member this.satisfies(?hasNull, ?hasUndefined, ?hasTypeofable, ?hasArray, ?hasEnum, ?hasDU, ?hasOther) = + let check opt value = + opt |> Option.map (fun x -> x = value) |? true + check hasNull this.caseNull + && check hasUndefined this.caseUndefined + && check hasTypeofable (this.typeofableTypes |> Set.isEmpty |> not) + && check hasArray (this.caseArray |> Option.map (Set.isEmpty >> not) |? false) + && check hasEnum (this.caseEnum |> Set.isEmpty |> not) + && check hasDU (this.discriminatedUnions |> Map.isEmpty |> not) + && check hasOther (this.otherTypes |> Set.isEmpty |> not) module ResolvedUnion = let rec pp (ru: ResolvedUnion) = diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 1aadc331..794b3933 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -83,6 +83,14 @@ module Attr = /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#modeling-this-based-callbacks let this = str "@this" + module Variant = + /// https://rescript-lang.org/blog/improving-interop#tagged-variants + let tag name = + tprintf "@tag(\"%s\")" (String.escape name) + + /// https://rescript-lang.org/blog/improving-interop#untagged-variants + let unboxed = str "@unboxed" + module PolyVariant = /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#constrain-arguments-better let int = str "@int" @@ -151,7 +159,9 @@ module Naming = let constructorName (name: string list) = let s = String.concat "_" name |> removeInvalidChars |> upperFirst - if keywords |> Set.contains s then s + "_" else s + if s.StartsWith("_") then "C" + s + else if keywords |> Set.contains s then s + "_" + else s let structured (baseName: string -> string) (name: string list) = let rec prettify = function @@ -324,23 +334,35 @@ module Type = let object = str "untypedObject" let function_ = str "untypedFunction" let symbol = str "symbol" - let regexp = str "Js.Re.t" + let regexp = str "Re.t" // ES2020 - let bigint = str "Js.Bigint.t" + let bigint = str "Bigint.t" // TS types let never = str "never" let any = str "any" let unknown = str "unknown" - let null_or t = app (str "Js.null") [t] + let null_or t = app (str "Null.t") [t] let undefined_or t = app (str "option") [t] - let null_or_undefined_or t = app (str "Js.nullable") [t] - let null_ = str "Js.null" + let null_or_undefined_or t = app (str "Nullable.t") [t] + let null_ = str "Null.t" let undefined = str "unit" let intrinsic = str "intrinsic" let true_ = str "true_" let false_ = str "false_" + let record isInline (fields: {| name: string; isOptional: bool; attrs: text list; ty: text |} list) = + let body = + fields + |> List.map (fun f -> + let attrs = f.attrs |> List.map (fun x -> x +@ " ") |> join + let name = tprintf "%s%s: " f.name (if f.isOptional then "?" else "") + attrs + name + f.ty) + |> List.map (fun f -> if isInline then f else indent f) + |> concat (if isInline then str ", " else str ",") + if isInline then "{ " @+ body +@ " }" + else "{" @+ newline + body + newline +@ "}" + // our types let intf tags = app (str "intf") [tags] let prim cases = app (str "prim") [cases] @@ -521,3 +543,56 @@ module Statement = |> List.filter (fun x -> sccSet |> Set.contains x.origName |> not) |> emitNonRec sccModules @ otherModules + +type [] Binding = + | Let of {| name: string; ty: text; body: text; attrs: text list; comments: text list |} + | Ext of {| name: string; ty: text; target: string; attrs: text list; comments: text list |} + | Unknown of {| msg:text option; comments: text list |} +with + member this.comments = + match this with Let x -> x.comments | Ext x -> x.comments | Unknown x -> x.comments + +module Binding = + let let_ (attrs: text list) comments name ty body = + Binding.Let {| name = name; ty = ty; body = body; attrs = attrs; comments = comments |} + + let ext (attrs: text list) comments name ty target = + Binding.Ext {| name = name; ty = ty; target = target; attrs = attrs; comments = comments |} + + let unknown comments msg = + Binding.Unknown {| msg = msg; comments = comments |} + + let cast comments name ty = + Binding.Ext {| name = name; ty = ty; target = "%identity"; attrs = []; comments = comments |} + + let builder name (fields: {| isOptional: bool; name: string; value: text |} list) (thisType: text) = + let args = + fields + |> List.distinctBy (fun x -> x.name) + |> List.map (fun f -> + let name = f.name |> Naming.valueName + let suffix = + if f.isOptional then "=?" else "" + tprintf "~%s:" name + f.value +@ suffix) + let args = + match List.tryLast fields with + | None -> args + | Some last -> if last.isOptional then args @ [Type.void_] else args + let ty = + Type.curriedArrow args thisType + Binding.Ext {| name = name; ty = ty; target = ""; attrs = [Attr.External.obj]; comments = []|} + + let emitForImplementation (b: Binding) = [ + match b with + | Binding.Let x -> yield Statement.let_ x.attrs x.name x.ty x.body + | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target + | Binding.Unknown x -> match x.msg with Some msg -> yield comment msg | None -> () + ] + + let emitForInterface (b: Binding) = [ + yield! b.comments + match b with + | Binding.Let x -> yield Statement.val_ x.attrs x.name x.ty + | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target + | Binding.Unknown x -> match x.msg with Some msg -> yield comment msg | None -> () + ] diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 23d26838..09aa185c 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -417,7 +417,7 @@ and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) | Typeofable.Number -> yield case "Number" (Some (Type.number ctx.options)) | Typeofable.Boolean -> yield case "Boolean" (Some Type.boolean) | Typeofable.Symbol -> yield case "Symbol" (Some Type.symbol) - | Typeofable.BigInt -> yield case "BigInt" (Some Type.bigint) + | Typeofable.BigInt -> yield case "Bigint" (Some Type.bigint) if u.caseNull then yield case "Null" (if unwrap then Some Type.null_ else None) @@ -524,77 +524,41 @@ and getLabelOfFullName flags overrideFunc (ctx: Context) (fullName: FullName) (t let inheritingType = InheritingType.KnownIdent {| fullName = fullName; tyargs = typeParams |> List.map (fun tp -> TypeVar tp.name) |} getLabelsFromInheritingTypes flags overrideFunc ctx (Set.singleton inheritingType) |> Choice1Of2 -type [] Binding = - | Let of {| name: string; ty: text; body: text; attrs: text list; comments: text list |} - | Ext of {| name: string; ty: text; target: string; attrs: text list; comments: text list |} - | Unknown of {| msg:text option; comments: text list |} -with - member this.comments = - match this with Let x -> x.comments | Ext x -> x.comments | Unknown x -> x.comments - -let let_ (attrs: text list) comments name ty body = - Binding.Let {| name = name; ty = ty; body = body; attrs = attrs; comments = comments |} - -let ext (attrs: text list) comments name ty target = - Binding.Ext {| name = name; ty = ty; target = target; attrs = attrs; comments = comments |} - -let unknownBinding comments msg = - Binding.Unknown {| msg = msg; comments = comments |} - -let cast comments name ty = - Binding.Ext {| name = name; ty = ty; target = "%identity"; attrs = []; comments = comments |} - -module Binding = - let emitForImplementation (b: Binding) = [ - match b with - | Binding.Let x -> yield Statement.let_ x.attrs x.name x.ty x.body - | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target - | Binding.Unknown x -> match x.msg with Some msg -> yield comment msg | None -> () - ] - - let emitForInterface (b: Binding) = [ - yield! b.comments - match b with - | Binding.Let x -> yield Statement.val_ x.attrs x.name x.ty - | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target - | Binding.Unknown x -> match x.msg with Some msg -> yield comment msg | None -> () - ] - -let builder name (fields: {| isOptional: bool; name: string; value: text |} list) (thisType: text) = - let args = - fields - |> List.distinctBy (fun x -> x.name) - |> List.map (fun f -> - let name = f.name |> Naming.valueName - let suffix = - if f.isOptional then "=?" else "" - tprintf "~%s:" name + f.value +@ suffix) - let args = - match List.tryLast fields with - | None -> args - | Some last -> if last.isOptional then args @ [Type.void_] else args - let ty = - Type.curriedArrow args thisType - Binding.Ext {| name = name; ty = ty; target = ""; attrs = [Attr.External.obj]; comments = []|} - -type StructuredTextItemBase<'TypeDef, 'Binding, 'EnumCase> = +type StructuredTextItemBase<'TypeDefText, 'Binding, 'EnumCaseText> = /// Will always be emitted at the top of the module. | ImportText of text /// Will always be emitted at the next top of the module. - | TypeDefText of 'TypeDef + | TypeDefText of 'TypeDefText | TypeAliasText of text /// Will be emitted in `.res` and `.resi`, but not in the `Types` module | Comment of text /// Will only be emitted in `.res` (not in `.resi` or in the `Types` module) | Binding of 'Binding - | EnumCaseText of 'EnumCase - -and StructuredTextItem = - StructuredTextItemBase< - {| name: string; tyargs: (TypeParam * text) list; isRec: bool; body: text option; shouldAssert: bool |}, - (OverloadRenamer -> CurrentScope -> Binding), - {| name: string; comments: Comment list |} - > + | EnumCaseText of 'EnumCaseText + +and StructuredTextItem = StructuredTextItemBase< + TypeDefText, + (OverloadRenamer -> CurrentScope -> Binding), + {| name: string; comments: Comment list |} +> + +and TypeDefText = { + name: string + tyargs: (TypeParam * text) list + body: text option + isRec: bool + shouldAssert: bool + attrs: text list + comments: text list +} with + static member Create(name, tyargs, body, ?attrs, ?comments, ?isRec, ?shouldAssert) = + TypeDefText { + name = name; tyargs = tyargs; body = body + attrs = attrs |? [] + comments = comments |? [] + isRec = isRec |? false + shouldAssert = shouldAssert |? false + } and CurrentScope = { jsModule: string option @@ -615,7 +579,6 @@ and [] ExportItem = | DefaultUnnamedClass of StructuredTextNode and StructuredTextNode = {| - /// By default, key is used as a scope. `Some scope` to override it. scope: Scope items: StructuredTextItem list comments: text list @@ -798,21 +761,21 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: | None -> impossible "emitMembers_Constructor(%s)" ma.loc.AsString | Some x -> x.self, x.attr let attrs = attrs |> List.rev - ext attrs comments (rename "make") ty target + Binding.ext attrs comments (rename "make") ty target ) | Newable (ft, _typrm) -> let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args; isVariadic = false } let value = createRawCall None ft.isVariadic true ft.args - binding (fun rename _ -> let_ [] comments (rename "make") ty value) + binding (fun rename _ -> Binding.let_ [] comments (rename "make") ty value) | Callable (ft, _typrm) -> let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args; isVariadic = false } let value = createRawCall None ft.isVariadic false ft.args - binding (fun rename _ -> let_ [] comments (rename "apply") ty value) + binding (fun rename _ -> Binding.let_ [] comments (rename "apply") ty value) | Field ({ name = name; value = Func (ft, _typrm, _); isOptional = false }, _) | Method (name, ft, _typrm) -> let origName = name let ext ty attrs = - binding (fun rename s -> ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) + binding (fun rename s -> Binding.ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) if ma.isStatic then match extFunc ft with | ty, Some attr -> ext ty (Attr.External.val_ :: attr) @@ -824,7 +787,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: | _, None -> let ty = func { ft with args = Choice2Of2 PolymorphicThis :: ft.args; isVariadic = false } let value = createRawCall (Some name) ft.isVariadic false ft.args - binding (fun rename _ -> let_ [] comments (rename name |> Naming.valueName) ty value) + binding (fun rename _ -> Binding.let_ [] comments (rename name |> Naming.valueName) ty value) | Getter fl | Field (fl, ReadOnly) -> let origName = fl.name let name = @@ -836,13 +799,13 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ty, attrs = let ty, attrs = extValue ty ty, Attr.External.val_ :: attrs - binding (fun rename s -> ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) + binding (fun rename s -> Binding.ext (scopeToAttr s attrs) comments (rename name |> Naming.valueName) ty origName) else let ty, attrs = let args = [Choice2Of2 PolymorphicThis] let ty, attrs = extFunc { isVariadic = false; args = args; returnType = ty; loc = ma.loc } ty, Attr.External.get_ :: impossibleNone (fun () -> "emitMembers_Getter") attrs - binding (fun rename _ -> ext attrs comments (rename name |> Naming.valueName) ty origName) + binding (fun rename _ -> Binding.ext attrs comments (rename name |> Naming.valueName) ty origName) | Setter fl | Field (fl, WriteOnly) -> let origName = fl.name if ma.isStatic then @@ -861,7 +824,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let ty, attrs = extFunc { isVariadic = false; args = args; returnType = Prim Void; loc = ma.loc } ty, Attr.External.set_ :: impossibleNone (fun () -> "emitMembers_Setter") attrs - binding (fun rename s -> ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) + binding (fun rename s -> Binding.ext (scopeToAttrIf ma.isStatic s attrs) comments (rename name |> Naming.valueName) ty origName) | Field (fl, Mutable) -> List.concat [ emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Getter fl) @@ -872,14 +835,14 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let args = Choice2Of2 PolymorphicThis :: removeLabels ft.args extFunc { ft with args = args; isVariadic = false } let attrs = Attr.External.get_index :: impossibleNone (fun () -> "emitMembers_Indexer_Read") attrs - binding (fun rename _ -> ext attrs comments (rename "get") ty "") + binding (fun rename _ -> Binding.ext attrs comments (rename "get") ty "") | Indexer (ft, WriteOnly) -> let ty, attrs = let args = Choice2Of2 PolymorphicThis :: removeLabels ft.args @ [Choice2Of2 ft.returnType] let ret = Prim Void extFunc { ft with args = args; returnType = ret; isVariadic = false } let attrs = Attr.External.set_index :: impossibleNone (fun () -> "emitMembers_Indexer_Write") attrs - binding (fun rename _ -> ext attrs comments (rename "set") ty "") + binding (fun rename _ -> Binding.ext attrs comments (rename "set") ty "") | Indexer (ft, Mutable) -> List.concat [ emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Indexer (ft, ReadOnly)) @@ -889,9 +852,9 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: let c = let ft = func ft tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol - binding (fun _ _ -> unknownBinding comments (Some c)) + binding (fun _ _ -> Binding.unknown comments (Some c)) | UnknownMember msgo -> - binding (fun _ _ -> unknownBinding comments (msgo |> Option.map str)) + binding (fun _ _ -> Binding.unknown comments (msgo |> Option.map str)) let emitTypeAliasesImpl (baseName: string) @@ -961,6 +924,11 @@ let getExportFromStatement (ctx: Context) (name: string) (kind: Kind list) (kind | _ -> "export" Some (ExportItem.Export {| comments = []; clauses = [clause, Set.ofList kind]; loc = s.loc; origText = sprintf "%s %s %s" prefix kindString name |}) +let addExportFromStatement ctx name kind kindString s current = + match getExportFromStatement ctx name kind kindString s with + | None -> current + | Some e -> current |> set {| StructuredTextNode.empty with exports = [e] |} + type [] ClassKind<'a, 'b, 'c> = | NormalClass of 'a | ExportDefaultClass of 'b @@ -1141,7 +1109,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c emitTypeAliasesImpl "t" flags overrideFunc innerCtx c.loc c.typeParams selfTyText.ty (fun x -> if not x.isOverload then - [TypeDefText {| name = x.name; tyargs = x.tyargs; body = x.target; isRec = selfTyText.isRec; shouldAssert = false |}] + [TypeDefText.Create(x.name, x.tyargs, x.target, isRec=selfTyText.isRec, comments=emitComments c.comments)] else [TypeAliasText (Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target)] ) @@ -1151,13 +1119,13 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c if useTags then let castTy = Type.curriedArrow [polymorphicThis] selfTyText - yield! binding (fun _ _ -> cast [] "castFrom" castTy) + yield! binding (fun _ _ -> Binding.cast [] "castFrom" castTy) if innerCtx.options.subtyping |> List.contains Subtyping.CastFunction then for parent in c.implements do let ty = Type.curriedArrow [selfTyText] (emitType_ innerCtx parent) let parentName = getHumanReadableName innerCtx parent - yield! binding (fun rename _ -> cast [] (rename $"as{parentName}") ty) + yield! binding (fun rename _ -> Binding.cast [] (rename $"as{parentName}") ty) ] let builder = @@ -1188,7 +1156,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c Some {| isOptional = false; name = name; value = value |} *) | _ -> None) - binding (fun rename _ -> builder (rename "make") fields selfTyText) + binding (fun rename _ -> Binding.builder (rename "make") fields selfTyText) let items = [ yield! typeDefinition @@ -1240,51 +1208,49 @@ and addAnonymousInterfaceExcluding emitTypeFlags (ctx: Context) knownTypes ais ( ) current and addAnonymousInterface emitTypeFlags ctx knownTypes (current: StructuredText) = addAnonymousInterfaceExcluding emitTypeFlags ctx knownTypes [] current +let emitConstructor name attrs types = + concat (str " ") [ + yield str "|" + yield! attrs + yield str name + if List.isEmpty types |> not then + yield between "(" ")" (concat (str ", ") types) + ] + +let getEnumCaseValue (ctx: Context) (e: Enum) (ec: EnumCase) = + ec.value |> Option.defaultWith (fun () -> + ctx.logger.errorf "error: the case '%s' of enum '%s' has an unknown value, which is not supported at %s" + ec.name e.name ec.loc.AsString + ) + let emitEnum (ctx: Context) (current: StructuredText) (e: Enum) = - let enumCaseToIdentifier (e: Enum) (c: EnumCase) = + let enumCaseToIdentifier (e: Enum) (ec: EnumCase) = let duplicateCases = - e.cases |> List.filter (fun c' -> c.value = c'.value) + e.cases |> List.filter (fun ec' -> ec.value = ec'.value) match duplicateCases with | [] -> impossible "enumCaseToIdentifier" - | [c'] -> - assert (c = c') - Naming.constructorName [c.name] - | cs -> - cs |> List.map (fun c -> c.name) |> Naming.constructorName + | [ec'] -> + assert (ec = ec') + Naming.constructorName [ec.name] + | ecs -> + ecs |> List.map (fun ec -> ec.name) |> Naming.constructorName let distinctCases = e.cases - |> List.map (fun c -> enumCaseToIdentifier e c, c.value, c) - |> List.distinctBy (fun (_, value, _) -> value) - |> List.map (fun (key, value, case) -> - key, value |> Option.defaultWith (fun () -> - ctx.logger.errorf "error: the case '%s' of enum '%s' has an unknown value, which is not supported at %s" - case.name e.name case.loc.AsString - )) + |> List.map (fun ec -> enumCaseToIdentifier e ec, ec) + |> List.distinctBy (fun (_, ec) -> ec.value) + |> List.map (fun (key, ec) -> key, getEnumCaseValue ctx e ec) - let childNode (c: EnumCase) = - EnumCaseText {| name = c.name; comments = c.comments |} + let childNode (ec: EnumCase) = + EnumCaseText {| name = ec.name; comments = ec.comments |} let parentNode = let casesText = newline + concat newline [ for key, value in distinctCases do - yield indent ( - concat (str " ") [ - str "|" - Attr.as_ (Term.literal value) - str key - ] - ) + yield emitConstructor key [Attr.as_ (Term.literal value)] [] |> indent ] - let item = - TypeDefText {| - name = "t"; - tyargs = []; - isRec = false; - body = Some casesText; - shouldAssert = true - |} + let item = TypeDefText.Create("t", [], Some casesText, shouldAssert=true, comments=emitComments e.comments) let items = item :: List.map childNode e.cases let comments = e.comments |> emitComments {| StructuredTextNode.empty with items = items; comments = comments |} @@ -1295,9 +1261,107 @@ let emitEnum (ctx: Context) (current: StructuredText) (e: Enum) = |> add [e.name] parentNode |> set {| StructuredTextNode.empty with exports = Option.toList exports |} +let emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (ta: TypeAlias) : StructuredText = + let emitType = emitTypeImpl flags overrideFunc + + let comments = (ta :> ICommented<_>).getComments() |> emitComments + let knownTypes = Statement.getKnownTypes ctx [TypeAlias ta] + + let items = + let ctx = ctx |> Context.ofChildNamespace ta.name + let isRec = knownTypes |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) + let emitTypeAliases attrs shouldAssert target = + emitTypeAliasesImpl "t" flags OverrideFunc.noOverride ctx ta.loc ta.typeParams (Some target) (fun x -> + if not x.isOverload then + [TypeDefText.Create ( + x.name, x.tyargs, x.target, + isRec=isRec, attrs=attrs, shouldAssert=shouldAssert, + comments=emitComments ta.comments + )] + else + [TypeAliasText (Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target)] + ) + let fallback () = emitTypeAliases [] false (emitType ctx ta.target) + let renamer = new OverloadRenamer() + let rename s = renamer.Rename "ctor" s + let nameFromType t = + Naming.constructorName [getHumanReadableName ctx t] |> rename + + match ta.target with + | Union u -> // emit as variant if possible + let ru = ResolvedUnion.resolve ctx u + let isEnumOrUnboxed = + ru.satisfies(hasDU=false, hasOther=false) + && ru.typeofableTypes |> Set.contains Typeofable.BigInt |> not // not supported by res + && ru.typeofableTypes |> Set.contains Typeofable.Symbol |> not // not supported by res + + let isTagged = + ru.satisfies(hasDU=true, hasTypeofable=false, hasArray=false, hasOther=false) + && Map.count ru.discriminatedUnions = 1 + && ru.discriminatedUnions |> Map.forall (fun _ -> Map.forall (fun _ -> function AnonymousInterface _ -> true | _ -> false)) + + let commonCases () = [ + if ru.caseNull then + yield emitConstructor (rename "Null") [Attr.as_ (str "null")] [] + if ru.caseUndefined then + yield emitConstructor (rename "Undefined") [Attr.as_ (str "undefined")] [] + for e in ru.caseEnum do + match e with + | Choice1Of2 (e, ec, _) -> + let value = + ec.value |> Option.defaultWith (fun () -> + ctx.logger.errorf "error: the case '%s' of enum '%s' has an unknown value, which is not supported at %s" + ec.name e.name ec.loc.AsString + ) + yield + emitConstructor + (Naming.constructorName [ec.name] |> rename) + [Attr.as_ (Term.literal value)] + [] + | Choice2Of2 l -> + yield emitConstructor (nameFromType (TypeLiteral l)) [Attr.as_ (Term.literal l)] [] + ] + if isEnumOrUnboxed then + let attrs = + if Set.isEmpty ru.typeofableTypes && Option.isNone ru.caseArray then [] + else [Attr.Variant.unboxed] + emitTypeAliases attrs true ( + newline + concat newline [ + yield! commonCases () + + match ru.caseArray with + | None -> () + | Some ts -> + yield emitConstructor (rename "Array") [] [ + Type.app Type.array [emitType ctx (Union { types = Set.toList ts })] + ] + + for t in ru.typeofableTypes do + match t with + | Typeofable.String -> yield emitConstructor (rename "String") [] [Type.string] + | Typeofable.Number -> yield emitConstructor (rename "Number") [] [Type.number ctx.options] + | Typeofable.Boolean -> yield emitConstructor (rename "Boolean") [] [Type.boolean] + | _ -> () + ] + ) + else if isTagged then + fallback () // TODO: special case, or just contribute to res compiler for unboxed tagged union? + else fallback () + | TypeLiteral l -> // emit as single-case variant + emitTypeAliases [] true ( + emitConstructor (nameFromType (TypeLiteral l)) [Attr.as_ (Term.literal l)] [] + ) + | _ -> fallback () + + let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes |} + current + |> inTrie [ta.name] (set node) + |> addExportFromStatement ctx ta.name Kind.OfTypeAlias "type" (TypeAlias ta) + |> inTrie [ta.name] (addAnonymousInterface flags ctx knownTypes) + let private createExternalForValue (ctx: Context) (rename: string -> string) (s: CurrentScope) attr comments name ty = let fallback () = - ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty name + Binding.ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty name let jsModule () = match s.jsModule with | None -> impossible "createExternalForValue" @@ -1305,11 +1369,11 @@ let private createExternalForValue (ctx: Context) (rename: string -> string) (s: match ctx |> Context.getExportTypeOfName [name] with | None | Some (ExportType.Child _) | Some (ExportType.ES6 None) -> fallback () | Some ExportType.CommonJS -> - ext (Attr.External.module_ None :: attr) comments (rename name |> Naming.valueName) ty (jsModule ()) + Binding.ext (Attr.External.module_ None :: attr) comments (rename name |> Naming.valueName) ty (jsModule ()) | Some ExportType.ES6Default -> - ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty "default" + Binding.ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty "default" | Some (ExportType.ES6 (Some renameAs)) -> - ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty renameAs + Binding.ext (scopeToAttr s attr) comments (rename name |> Naming.valueName) ty renameAs let rec emitFunction flags overrideFunc ctx (f: Function) = if functionNeedsWorkaround f.typ then @@ -1397,10 +1461,6 @@ let emitImport (ctx: Context) (i: Import) : StructuredTextItem list = for c in i.clauses do yield! emitImportClause c] -let emitTypeAliasToUnionFunctions flags overrideFunc ctx (u: UnionType) : StructuredTextItem list = - // TODO - [] - let createStructuredText (rootCtx: Context) (stmts: Statement list) : StructuredText = let emitTypeFlags = EmitTypeFlags.defaultValue let overrideFunc = OverrideFunc.noOverride @@ -1446,7 +1506,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Some x -> x.self, x.attr | None -> impossible "intfToStmts_Newable(%s)" ma.loc.AsString let attrs = attrs |> List.rev - ext attrs comments (rename "make") ty target + Binding.ext attrs comments (rename "make") ty target ) | Callable (ft, _tps) -> let ty, attrs = @@ -1460,14 +1520,14 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Some x -> x.self, x.attr | None -> impossible "intfToStmts_Callable(%s)" ma.loc.AsString let attrs = attrs |> List.rev - ext attrs comments (rename "apply") ty target + Binding.ext attrs comments (rename "apply") ty target ) | Constructor _ -> impossible "emitStructuredDefinition_Pattern_intfToModule_Constructor" // because interface! | Indexer (ft, _) -> let ty = func ft - yield! binding (fun _ _ -> unknownBinding comments (Some ("unsupported indexer of type: " @+ ty))) + yield! binding (fun _ _ -> Binding.unknown comments (Some ("unsupported indexer of type: " @+ ty))) | UnknownMember (Some msg) -> - yield! binding (fun _ _ -> unknownBinding comments (Some (str msg))) + yield! binding (fun _ _ -> Binding.unknown comments (Some (str msg))) | SymbolIndexer _ | UnknownMember None -> () ] let rec folder ctx (current: StructuredText) (s: Statement) : StructuredText = @@ -1475,9 +1535,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured let knownTypes () = Statement.getKnownTypes ctx [s] let addExport name kind kindString current = - match getExportFromStatement ctx name kind kindString s with - | None -> current - | Some e -> current |> set {| StructuredTextNode.empty with exports = [e] |} + addExportFromStatement ctx name kind kindString s current let addAnonymousInterfaceWithKnownTypes knownTypes current = addAnonymousInterface emitTypeFlags ctx knownTypes current let addAnonymousInterface current = addAnonymousInterfaceWithKnownTypes (knownTypes ()) current let addAnonymousInterfaceExcludingWithKnownTypes knownTypes ais current = addAnonymousInterfaceExcluding emitTypeFlags ctx knownTypes ais current @@ -1511,28 +1569,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Enum e -> emitEnum ctx current e | TypeAlias ta -> - let ctx = ctx |> Context.ofChildNamespace ta.name - let knownTypes = knownTypes () - let isRec = - knownTypes |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) - let items = - emitTypeAliasesImpl "t" emitTypeFlags OverrideFunc.noOverride ctx ta.loc ta.typeParams (emitSelfType ctx ta.target |> Some) (fun x -> - if not x.isOverload then - [TypeDefText {| name = x.name; tyargs = x.tyargs; body = x.target; isRec = false; shouldAssert = false |}] - else - [TypeAliasText (Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target)] - ) - let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes |} - current - |> inTrie [ta.name] (set node) - |> addExport ta.name Kind.OfTypeAlias "type" - |> inTrie [ta.name] ( - match ta.target with - | Union u -> - let functions = emitTypeAliasToUnionFunctions emitTypeFlags OverrideFunc.noOverride ctx u - set {| StructuredTextNode.empty with items = functions |} - | _ -> id) - |> inTrie [ta.name] addAnonymousInterface + emitTypeAlias emitTypeFlags overrideFunc ctx current ta | Pattern p -> let fallback current = p.underlyingStatements @@ -1724,15 +1761,17 @@ let rec emitModule (dt: DependencyTrie) flags (ctx: Context) st = impl = Statement.moduleVal (m (if isLinear then intf else impl)) |} - let emitTypeDefText (e: {| name: string; tyargs:(TypeParam * text) list; isRec: bool; body: text option; shouldAssert: bool |}) = - let actual = Statement.typeAlias e.isRec e.name (e.tyargs |> List.map snd) e.body + let emitTypeDefText (e: TypeDefText) = + // TODO: emit comments + let attrs = e.attrs |> List.map (fun x -> x +@ " ") |> join + let actual = attrs + Statement.typeAlias e.isRec e.name (e.tyargs |> List.map snd) e.body let alias = let tmp = Statement.typeAlias false e.name (e.tyargs |> List.map snd) (Type.appOpt (str e.name) (e.tyargs |> List.map snd) |> Some) match e.body, e.shouldAssert with | _, false | None, _ -> tmp - | Some b, true -> tmp +@ " = " + b + | Some b, true -> attrs + tmp +@ " = " + b {| types = actual; intf = actual; impl = alias |} let rec f = function From 2e7116c55ca68c188228ab9d56ea8f9c72332685 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 30 Jan 2024 18:35:35 +0900 Subject: [PATCH 49/56] Update ReScript to v11.0.1 --- fake | 0 package.json | 2 +- yarn.lock | 8 ++++---- 3 files changed, 5 insertions(+), 5 deletions(-) mode change 100644 => 100755 fake diff --git a/fake b/fake old mode 100644 new mode 100755 diff --git a/package.json b/package.json index 4d7f0f20..b5ed4acb 100644 --- a/package.json +++ b/package.json @@ -43,7 +43,7 @@ "cdk8s": "^2.2.41", "monaco-editor": "0.45.0", "react-player": "2.14.0", - "rescript": "^11.0.0-beta.3", + "rescript": "11.0.1", "ts2fable": "0.8.0-build.723", "webpack": "5.90.0", "webpack-cli": "5.1.0", diff --git a/yarn.lock b/yarn.lock index aa8b3fef..212802a5 100644 --- a/yarn.lock +++ b/yarn.lock @@ -2676,10 +2676,10 @@ requires-port@^1.0.0: resolved "https://registry.yarnpkg.com/requires-port/-/requires-port-1.0.0.tgz#925d2601d39ac485e091cf0da5c6e694dc3dcaff" integrity sha1-kl0mAdOaxIXgkc8NpcbmlNw9yv8= -rescript@^11.0.0-beta.3: - version "11.0.0-beta.3" - resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.0-beta.3.tgz#f883a19aa8cb2ab162fd2c9f3d46d2c05cc5710b" - integrity sha512-j3YT3VdWMoHgwL4RydKJm9O/VIpN3NTI6keP18rZVJ8ansRKgkHYGLaIwoG6iVqSYYwBjb6d8l8oZ1Jz0fmTeQ== +rescript@11.0.1: + version "11.0.1" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.1.tgz#c74af134dc8a16d152169b2456d0720324835f54" + integrity sha512-7T4PRp/d0+CBNnY6PYKffFqo9tGZlvnZpboF/n+8SKS+JZ6VvXJO7W538VPZXf3EYx1COGAWWvkF9e/HgSAqHg== resolve-cwd@^3.0.0: version "3.0.0" From ea996cf66a1ed5c1367278c8dc6d38770afcb975 Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 30 Jan 2024 19:09:06 +0900 Subject: [PATCH 50/56] Update ReScript to v11 in dist/res and test/res --- dist/res/package.json | 7 +++++-- dist/res/{bsconfig.json => rescript.json} | 0 dist/res/yarn.lock | 8 ++++---- test/res/package.json | 2 +- test/res/{bsconfig.json => rescript.json} | 3 ++- test/res/src/main.res | 14 ++++++++++---- test/res/yarn.lock | 8 ++++---- 7 files changed, 26 insertions(+), 16 deletions(-) rename dist/res/{bsconfig.json => rescript.json} (100%) rename test/res/{bsconfig.json => rescript.json} (82%) diff --git a/dist/res/package.json b/dist/res/package.json index 887a63db..99faf0a8 100644 --- a/dist/res/package.json +++ b/dist/res/package.json @@ -11,7 +11,10 @@ ], "author": "", "license": "Apache-2.0", - "dependencies": { - "rescript": "^11.0.0-beta.3" + "devDependencies": { + "rescript": "11.0.1" + }, + "peerDependencies": { + "rescript": "^11.0.1" } } diff --git a/dist/res/bsconfig.json b/dist/res/rescript.json similarity index 100% rename from dist/res/bsconfig.json rename to dist/res/rescript.json diff --git a/dist/res/yarn.lock b/dist/res/yarn.lock index 992ba920..405d1f49 100644 --- a/dist/res/yarn.lock +++ b/dist/res/yarn.lock @@ -2,7 +2,7 @@ # yarn lockfile v1 -rescript@^11.0.0-beta.3: - version "11.0.0-beta.3" - resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.0-beta.3.tgz#f883a19aa8cb2ab162fd2c9f3d46d2c05cc5710b" - integrity sha512-j3YT3VdWMoHgwL4RydKJm9O/VIpN3NTI6keP18rZVJ8ansRKgkHYGLaIwoG6iVqSYYwBjb6d8l8oZ1Jz0fmTeQ== +rescript@11.0.1: + version "11.0.1" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.1.tgz#c74af134dc8a16d152169b2456d0720324835f54" + integrity sha512-7T4PRp/d0+CBNnY6PYKffFqo9tGZlvnZpboF/n+8SKS+JZ6VvXJO7W538VPZXf3EYx1COGAWWvkF9e/HgSAqHg== diff --git a/test/res/package.json b/test/res/package.json index 2117d6f3..d0843ca5 100644 --- a/test/res/package.json +++ b/test/res/package.json @@ -15,6 +15,6 @@ "@ocsigen/ts2ocaml": "link:../../" }, "dependencies": { - "rescript": "^11.0.0-beta.3" + "rescript": "11.0.1" } } diff --git a/test/res/bsconfig.json b/test/res/rescript.json similarity index 82% rename from test/res/bsconfig.json rename to test/res/rescript.json index 38340e3e..0dde58eb 100644 --- a/test/res/bsconfig.json +++ b/test/res/rescript.json @@ -9,5 +9,6 @@ "module": "commonjs", "in-source": true }, - "suffix": ".bs.js" + "suffix": ".bs.js", + "uncurried": true } diff --git a/test/res/src/main.res b/test/res/src/main.res index 165395f2..801d7626 100644 --- a/test/res/src/main.res +++ b/test/res/src/main.res @@ -1,7 +1,13 @@ -open Ts2ocaml +module Ts = Typescript.Export -let tsVersion = Typescript.Ts.version +let source = "let x: string = 'hello, world!'" -let x = Prop_types.ElementStatic.isRequired +let result = Ts.transpileModule( + ~input=source, + ~transpileOptions=Ts.TranspileOptions.make( + ~compilerOptions=Ts.CompilerOptions.make(~\"module"=CommonJS, ()), + (), + ), +) -let y = Scheduler__tracing.__interactionsRef \ No newline at end of file +Js.log(result->Ts.TranspileOutput.get_outputText) diff --git a/test/res/yarn.lock b/test/res/yarn.lock index 1f82cd1d..dcddde29 100644 --- a/test/res/yarn.lock +++ b/test/res/yarn.lock @@ -138,10 +138,10 @@ require-directory@^2.1.1: resolved "https://registry.yarnpkg.com/require-directory/-/require-directory-2.1.1.tgz#8c64ad5fd30dab1c976e2344ffe7f792a6a6df42" integrity sha512-fGxEI7+wsG9xrvdjsrlmL22OMTTiHRwAMroiEeMgq8gzoLC/PQr7RsRDSTLUg/bZAZtF+TVIkHc6/4RIKrui+Q== -rescript@^11.0.0-beta.3: - version "11.0.0-beta.3" - resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.0-beta.3.tgz#f883a19aa8cb2ab162fd2c9f3d46d2c05cc5710b" - integrity sha512-j3YT3VdWMoHgwL4RydKJm9O/VIpN3NTI6keP18rZVJ8ansRKgkHYGLaIwoG6iVqSYYwBjb6d8l8oZ1Jz0fmTeQ== +rescript@11.0.1: + version "11.0.1" + resolved "https://registry.yarnpkg.com/rescript/-/rescript-11.0.1.tgz#c74af134dc8a16d152169b2456d0720324835f54" + integrity sha512-7T4PRp/d0+CBNnY6PYKffFqo9tGZlvnZpboF/n+8SKS+JZ6VvXJO7W538VPZXf3EYx1COGAWWvkF9e/HgSAqHg== string-width@^4.1.0, string-width@^4.2.0, string-width@^4.2.3: version "4.2.3" From ba4db6655a944484437090996a56cf03d2454caf Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 31 Jan 2024 10:54:09 +0900 Subject: [PATCH 51/56] Use uncurried mode --- src/Targets/ReScript/ReScriptHelper.fs | 27 ++------------- src/Targets/ReScript/Writer.fs | 46 ++++++++++++-------------- test/res/src/main.res | 3 +- 3 files changed, 25 insertions(+), 51 deletions(-) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 794b3933..6c34440a 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -272,22 +272,13 @@ module Type = | xs -> concat (str ", ") xs |> between "(" ")" /// `(t1, t2) => tr` - let curriedArrow args ret = + let arrow args ret = let lhs = match args with | [] -> str "()" - | [x] -> x | xs -> concat (str ", ") xs |> between "(" ")" lhs +@ " => " + ret - /// `(.t1, t2) => tr` - let uncurriedArrow args ret = - let lhs = - match args with - | [] -> str "()" - | xs -> concat (str ", ") xs |> between "(. " ")" - lhs +@ " => " + ret - let app t args = if List.isEmpty args then failwith "type application with empty arguments" else t + between "<" ">" (concat (str ", ") args) @@ -410,7 +401,7 @@ module Term = let appUncurried t us = t + (us |> concat (str ", ") |> between "(. " ")") /// `(arg1, arg2) => ret` - let curriedArrow args ret = + let arrow args ret = let lhs = match args with | [] -> failwith "0-ary function" @@ -418,14 +409,6 @@ module Term = | xs -> concat (str ", ") xs |> between "(" ")" lhs +@ " => " + ret - /// `(. arg1, arg2) => ret` - let uncurriedArrow args ret = - let lhs = - match args with - | [] -> failwith "0-ary function" - | xs -> concat (str ", ") xs |> between "(. " ")" - lhs +@ " => " + ret - let literal (l: Literal) = match l with | LBool true -> str "true" | LBool false -> str "false" @@ -574,12 +557,8 @@ module Binding = let suffix = if f.isOptional then "=?" else "" tprintf "~%s:" name + f.value +@ suffix) - let args = - match List.tryLast fields with - | None -> args - | Some last -> if last.isOptional then args @ [Type.void_] else args let ty = - Type.curriedArrow args thisType + Type.arrow args thisType Binding.Ext {| name = name; ty = ty; target = ""; attrs = [Attr.External.obj]; comments = []|} let emitForImplementation (b: Binding) = [ diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 09aa185c..28febac1 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -301,12 +301,12 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte | Choice2Of2 t -> emitTypeImpl flags overrideFunc ctx t) Type.newable args retTy let args () = - let rec go optional acc (args: Choice list) = + let rec go acc (args: Choice list) = let flags = { flags with needParen = true } |> EmitTypeFlags.ofFuncArg false match args with - | [] -> if optional then Type.void_ :: acc else acc + | [] -> acc | Choice1Of2 x :: [] when acc = [] && not x.isOptional -> - go optional acc [Choice2Of2 x.value] + go acc [Choice2Of2 x.value] | Choice1Of2 x :: [] when f.isVariadic -> assert (not x.isOptional) let t = emitTypeImpl { flags with external = External.Argument true } overrideFunc ctx x.value @@ -319,20 +319,20 @@ and emitFuncType (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Conte let arg = let tmp = tprintf "~%s:" (Naming.valueName x.name) + emitTypeImpl flags overrideFunc ctx x.value if x.isOptional then tmp +@ "=?" else tmp - go (optional || x.isOptional) (arg :: acc) rest + go (arg :: acc) rest | Choice2Of2 t :: rest -> let t = emitTypeImpl flags overrideFunc ctx t - go false (t :: acc) rest - go false [] f.args |> List.rev + go (t :: acc) rest + go [] f.args |> List.rev match flags.external with | _ when isNewable -> if f.isVariadic then variadicFallback () else newableFallback () - | External.Root (true, _) -> Type.curriedArrow (args ()) (retTy flags) + | External.Root (true, _) -> Type.arrow (args ()) (retTy flags) | _ when f.isVariadic -> variadicFallback () - | External.Root (_, _) -> Type.curriedArrow (args ()) (retTy flags) - | External.Argument _ -> paren ("@uncurry " @+ Type.curriedArrow (args ()) (retTy flags)) - | External.Return _ -> Type.uncurriedArrow (args ()) (retTy flags) - | _ -> Type.curriedArrow (args ()) (retTy flags) |> paren + | External.Root (_, _) + | External.Argument _ + | External.Return _ -> Type.arrow (args ()) (retTy flags) + | _ -> Type.arrow (args ()) (retTy flags) |> paren and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) (u: UnionType) : text = if flags.resolveUnion = false then @@ -703,25 +703,20 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: else rename (s + "_") let self = rename "t" let args = - let rec go index isOptional acc = function - | [] -> - if isOptional then - let name = rename "unit" - List.rev ({| ml = str name; js = name; used = false |} :: acc) - else - List.rev acc + let rec go index acc = function + | [] -> List.rev acc | Choice2Of2 _ :: rest -> let name = sprintf "arg%d" index |> rename - go (index+1) false ({| ml = str name; js = name; used = true |} :: acc) rest + go (index+1) ({| ml = str name; js = name |} :: acc) rest | Choice1Of2 { name = name; isOptional = isOptional' } :: rest -> let ml = if isOptional' then sprintf "~%s=?" name else "~" + name let js = name |> String.replace "'" "$p" - go (index+1) (isOptional || isOptional') ({| ml = str ml; js = js; used = true |} :: acc) rest - go 1 false [] args + go (index+1) ({| ml = str ml; js = js |} :: acc) rest + go 1 [] args let body = let args = let args = - args |> List.filter (fun arg -> arg.used) |> List.map (fun arg -> arg.js) + args |> List.map (fun arg -> arg.js) if not isVariadic then String.concat ", " args else match List.rev args with @@ -736,7 +731,7 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: | None -> sprintf "%s(%s)" self args if isNewable then "new " + body else body let args = str self :: (args |> List.map (fun arg -> arg.ml)) - Term.curriedArrow args (Term.raw body) + Term.arrow args (Term.raw body) let scopeToAttrIf isStatic s attrs = if isStatic then scopeToAttr s attrs else attrs @@ -1118,12 +1113,12 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c // add a generic cast function if tag is available if useTags then let castTy = - Type.curriedArrow [polymorphicThis] selfTyText + Type.arrow [polymorphicThis] selfTyText yield! binding (fun _ _ -> Binding.cast [] "castFrom" castTy) if innerCtx.options.subtyping |> List.contains Subtyping.CastFunction then for parent in c.implements do - let ty = Type.curriedArrow [selfTyText] (emitType_ innerCtx parent) + let ty = Type.arrow [selfTyText] (emitType_ innerCtx parent) let parentName = getHumanReadableName innerCtx parent yield! binding (fun rename _ -> Binding.cast [] (rename $"as{parentName}") ty) ] @@ -1918,6 +1913,7 @@ and emitExportModule (ctx: Context) (exports: ExportItem list) : EmitModuleResul st |> emitModule Trie.empty {| isReservedModule = true; jsModule = None; scopeRev = [] |} ctx let header = [ + str "@@uncurried" str "@@warning(\"-27-32-33-44\")" ] diff --git a/test/res/src/main.res b/test/res/src/main.res index 801d7626..11aa340f 100644 --- a/test/res/src/main.res +++ b/test/res/src/main.res @@ -5,8 +5,7 @@ let source = "let x: string = 'hello, world!'" let result = Ts.transpileModule( ~input=source, ~transpileOptions=Ts.TranspileOptions.make( - ~compilerOptions=Ts.CompilerOptions.make(~\"module"=CommonJS, ()), - (), + ~compilerOptions=Ts.CompilerOptions.make(~\"module"=CommonJS), ), ) From 05c11a1f917af2d12612a1a98e3a99f079b9bcef Mon Sep 17 00:00:00 2001 From: cannorin Date: Wed, 31 Jan 2024 11:16:41 +0900 Subject: [PATCH 52/56] Do not generated duplicate types for union with enum type --- src/Targets/ReScript/Writer.fs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 28febac1..b465e35b 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -360,14 +360,15 @@ and emitUnion (flags: EmitTypeFlags) (overrideFunc: OverrideFunc) (ctx: Context) | LInt i -> Choice1Of2 {| name = Choice2Of2 i; value = None; attr = attr |} | LFloat _ -> Choice2Of2 (ty |? Type.float) | LBool _ -> Choice2Of2 (ty |? Type.boolean) - let cases = [ - for c in cases do - match c with - | Choice1Of2 (_, _, ty) -> - let ty = emitTypeImpl (EmitTypeFlags.noExternal flags) overrideFunc ctx ty - yield Choice2Of2 ty - | Choice2Of2 l -> yield handleLiteral l None None - ] + let cases = + List.distinct [ + for c in cases do + match c with + | Choice1Of2 (_, _, ty) -> + let ty = emitTypeImpl (EmitTypeFlags.noExternal flags) overrideFunc ctx ty + yield Choice2Of2 ty + | Choice2Of2 l -> yield handleLiteral l None None + ] let cases, rest = List.splitChoice2 cases [ if List.isEmpty cases |> not then From 6c0a164c4909906402f937a6ab8ee772430251b8 Mon Sep 17 00:00:00 2001 From: cannorin Date: Thu, 1 Feb 2024 15:39:30 +0900 Subject: [PATCH 53/56] Emit comments except for recursive modules --- lib/Syntax.fs | 15 +++++++++ src/Targets/ReScript/ReScriptHelper.fs | 15 ++++++++- src/Targets/ReScript/Writer.fs | 46 ++++++++++++++++---------- 3 files changed, 58 insertions(+), 18 deletions(-) diff --git a/lib/Syntax.fs b/lib/Syntax.fs index a79251a5..61fda9ec 100644 --- a/lib/Syntax.fs +++ b/lib/Syntax.fs @@ -91,6 +91,21 @@ and [] Comment = | See of name:string option * text:string list | ESVersion of Ts.ScriptTarget | Other of tag:string * text:string list * orig:Ts.JSDocTag + member x.ToJsDoc() = + let concat (lines: string list) = String.concat "\n" lines + match x with + | Description lines -> "@description " + concat lines + | Summary lines -> "@summary " + concat lines + | Param (name, lines) -> sprintf "@param %s " name + concat lines + | Return lines -> "@returns " + concat lines + | Deprecated lines -> "@deprecated " + concat lines + | Example lines -> "@example" + "\n" + concat lines + | See (Some name, []) -> sprintf "@see %s" name + | See (Some name, lines) -> sprintf "@see {@link %s} " name + concat lines + | See (None, lines) -> "@see " + concat lines + | ESVersion target -> sprintf "@since %s" (Enum.pp target) + | Other (_, _, orig) -> orig.getText() + override x.Equals(yo) = match yo with | :? Comment as y -> true diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index 6c34440a..ca3b6956 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -20,6 +20,14 @@ let comment text = between "/*" "*/" inner let commentStr text = tprintf "/* %s */" text +let docComment text = + if text = empty then empty + else + let inner = + if isMultiLine text then newline + indent text + newline + else between " " " " text + between "/**" "*/" inner + module Attr = let as_ value = between "@as(" ")" value @@ -438,7 +446,11 @@ let private moduleSigImplLines (prefix: string) (isRec: bool) (m: TextModule) = prefix (if isRec then "rec " else "") m.name - [ yield! m.comments + [ + // FIXME: https://github.com/rescript-lang/rescript-compiler/issues/6598 + if prefix <> "and" then + yield! m.comments + yield! moduleSigImplBody head oneliner m ] let private moduleSigImpl (prefix: string) (isRec: bool) (m: TextModule) = @@ -562,6 +574,7 @@ module Binding = Binding.Ext {| name = name; ty = ty; target = ""; attrs = [Attr.External.obj]; comments = []|} let emitForImplementation (b: Binding) = [ + yield! b.comments match b with | Binding.Let x -> yield Statement.let_ x.attrs x.name x.ty x.body | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index b465e35b..0f742195 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -630,9 +630,19 @@ module StructuredText = let removeLabels (xs: Choice list) = xs |> List.map (function Choice2Of2 t -> Choice2Of2 t | Choice1Of2 fl -> Choice2Of2 fl.value) -let emitComments (comments: Comment list) : text list = - // TODO - [] +let emitComments (floating: bool) (comments: Comment list) : text list = + if List.isEmpty comments then [] + else + let escape = + String.replace "/*" "/ *" + >> String.replace "*/" "* /" + let emit (c: Comment) = + match c with + | Description lines + | Summary lines -> lines |> List.map escape |> strLines + | c -> c.ToJsDoc() |> escape |> str + let body = comments |> List.map emit |> concat newline + if floating then [comment body] else [docComment body] let inline binding (f: (string -> string) -> CurrentScope -> Binding) : StructuredTextItem list = [Binding (fun renamer scope -> f (renamer.Rename "value") scope)] @@ -688,7 +698,7 @@ let extValue flags overrideFunc ctx (t: Type) = let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: bool) (ma: MemberAttribute) m = let emitType_ = emitTypeImpl flags overrideFunc - let comments = emitComments ma.comments + let comments = emitComments false ma.comments let inline extFunc ft = extFunc flags overrideFunc ctx ft let inline extValue t = extValue flags overrideFunc ctx t @@ -845,11 +855,13 @@ let rec emitMembers flags overrideFunc ctx (selfTy: Type) (isExportDefaultClass: emitMembers flags overrideFunc ctx selfTy isExportDefaultClass ma (Indexer (ft, WriteOnly)) ] | SymbolIndexer (symbol, ft, _) -> + let comments = emitComments true ma.comments let c = let ft = func ft tprintf "external [Symbol.%s]: " symbol + ft + tprintf " = \"[Symbol.%s]\"" symbol binding (fun _ _ -> Binding.unknown comments (Some c)) | UnknownMember msgo -> + let comments = emitComments true ma.comments binding (fun _ _ -> Binding.unknown comments (msgo |> Option.map str)) let emitTypeAliasesImpl @@ -1053,7 +1065,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c | ClassKind.NormalClass _ -> forceScope |> Option.defaultValue Scope.Default | _ -> Scope.Ignore - let comments = c.comments |> emitComments + let comments = c.comments |> emitComments false let tagsDefinition = if useTags && innerCtx.options.inheritWithTags.HasProvide then @@ -1105,7 +1117,7 @@ let rec emitClass flags overrideFunc (ctx: Context) (current: StructuredText) (c emitTypeAliasesImpl "t" flags overrideFunc innerCtx c.loc c.typeParams selfTyText.ty (fun x -> if not x.isOverload then - [TypeDefText.Create(x.name, x.tyargs, x.target, isRec=selfTyText.isRec, comments=emitComments c.comments)] + [TypeDefText.Create(x.name, x.tyargs, x.target, isRec=selfTyText.isRec, comments=emitComments false c.comments)] else [TypeAliasText (Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target)] ) @@ -1246,9 +1258,9 @@ let emitEnum (ctx: Context) (current: StructuredText) (e: Enum) = for key, value in distinctCases do yield emitConstructor key [Attr.as_ (Term.literal value)] [] |> indent ] - let item = TypeDefText.Create("t", [], Some casesText, shouldAssert=true, comments=emitComments e.comments) + let item = TypeDefText.Create("t", [], Some casesText, shouldAssert=true, comments=emitComments false e.comments) let items = item :: List.map childNode e.cases - let comments = e.comments |> emitComments + let comments = e.comments |> emitComments false {| StructuredTextNode.empty with items = items; comments = comments |} let exports = getExportFromStatement ctx e.name Kind.OfEnum "enum" (Enum e) @@ -1260,7 +1272,7 @@ let emitEnum (ctx: Context) (current: StructuredText) (e: Enum) = let emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (ta: TypeAlias) : StructuredText = let emitType = emitTypeImpl flags overrideFunc - let comments = (ta :> ICommented<_>).getComments() |> emitComments + let comments = (ta :> ICommented<_>).getComments() |> emitComments false let knownTypes = Statement.getKnownTypes ctx [TypeAlias ta] let items = @@ -1272,7 +1284,7 @@ let emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (t [TypeDefText.Create ( x.name, x.tyargs, x.target, isRec=isRec, attrs=attrs, shouldAssert=shouldAssert, - comments=emitComments ta.comments + comments=emitComments false ta.comments )] else [TypeAliasText (Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target)] @@ -1380,7 +1392,7 @@ let rec emitFunction flags overrideFunc ctx (f: Function) = let inline extFunc ft = extFunc flags overrideFunc ctx ft let ty, attr = extFunc f.typ let attr = attr |> impossibleNone (fun () -> "emitFunction") - let comments = emitComments f.comments + let comments = emitComments false f.comments binding (fun rename s -> createExternalForValue ctx rename s (Attr.External.val_ :: attr) comments f.name ty) and emitVariable flags overrideFunc ctx (v: Variable) = @@ -1393,7 +1405,7 @@ and emitVariable flags overrideFunc ctx (v: Variable) = let emitType = emitTypeImpl flags let emitType_ = emitType overrideFunc let ty, attr = emitType_ ctx v.typ, [Attr.External.val_] - let comments = emitComments v.comments + let comments = emitComments false v.comments binding (fun rename s -> createExternalForValue ctx rename s attr comments v.name ty) let emitImport (ctx: Context) (i: Import) : StructuredTextItem list = @@ -1452,7 +1464,7 @@ let emitImport (ctx: Context) (i: Import) : StructuredTextItem list = |> Option.defaultValue [] | NamespaceImport _ | ES6DefaultImport _ | ES6Import _ -> [] - [ yield! emitComments i.comments |> List.map ImportText + [ yield! emitComments true i.comments |> List.map ImportText yield commentStr i.origText |> ImportText for c in i.clauses do yield! emitImportClause c] @@ -1481,7 +1493,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured comments = memberAttr.comments; loc = memberAttr.loc } emitFunction flags overrideFunc ctx f [ for ma, m in moduleIntf.members do - let comments = emitComments ma.comments + let comments = emitComments false ma.comments match m with | Field (fl, mt) -> yield! emitAsVariable fl.name fl.value (mt = ReadOnly) ma @@ -1527,7 +1539,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | SymbolIndexer _ | UnknownMember None -> () ] let rec folder ctx (current: StructuredText) (s: Statement) : StructuredText = - let comments = (s :> ICommented<_>).getComments() |> emitComments + let comments = (s :> ICommented<_>).getComments() |> emitComments false let knownTypes () = Statement.getKnownTypes ctx [s] let addExport name kind kindString current = @@ -1667,7 +1679,7 @@ let createStructuredText (rootCtx: Context) (stmts: Statement list) : Structured | Some s -> commentStr s | None -> commentStr "unknown statement" current |> set {| StructuredTextNode.empty with items = [Comment cmt] |} | FloatingComment c -> - let cmt = c.comments |> emitComments |> List.map Comment + let cmt = c.comments |> emitComments true |> List.map Comment current |> set {| StructuredTextNode.empty with items = Comment empty :: cmt |} stmts |> List.fold (folder rootCtx) Trie.empty @@ -1751,7 +1763,7 @@ let rec emitModule (dt: DependencyTrie) flags (ctx: Context) st = yield Statement.open_ moduleName yield str "type nonrec t = t" ] - let m content = {| name = moduleName; origName = e.name; content = content; comments = emitComments e.comments |} + let m content = {| name = moduleName; origName = e.name; content = content; comments = emitComments false e.comments |} {| types = types intf = Statement.moduleSig (m intf) impl = Statement.moduleVal (m (if isLinear then intf else impl)) From 72d019393f41765bcc18f3a8406125f83d6784e6 Mon Sep 17 00:00:00 2001 From: cannorin Date: Mon, 26 Feb 2024 19:09:52 +0900 Subject: [PATCH 54/56] Add docs for ReScript --- docs/rescript.md | 771 ++++++++++++++++++++++++++++++++- src/Targets/ReScript/Common.fs | 6 +- 2 files changed, 773 insertions(+), 4 deletions(-) diff --git a/docs/rescript.md b/docs/rescript.md index 6d3f6659..9172c8f6 100644 --- a/docs/rescript.md +++ b/docs/rescript.md @@ -1 +1,770 @@ -WIP \ No newline at end of file +# ts2ocaml for ReScript + +Generates binding for ReScript. + +# Overview + +`ts2ocaml` is a powerful tool, but there are so many options and also some caverts. + +Therefore, we first provide a walkthrough to use this tool for your project. + +The documentation for the `ts2ocaml` command and its options comes after the walkthrough, starting with the [Usage](#usage) setion. + +## Requirements + +`ts2ocaml` targets ReScript v11 or later. + +## Adding `ts2ocaml.res` + +ReScript has a rich standard library to use JS and DOM APIs and `ts2ocaml` makes use of it as much as possible. In addition to that, `ts2ocaml` uses a small standard library to handle some TypeScript-specific concepts: + +- `intf<'tags>` type, which is used for [tag-based subtyping](#feature-tag). +- TypeScript-specific primitive types, such as `any`, `never`, `unknown`, etc. +- Utility types for handling TypeScript's union types and intersection types. + +Run `ts2ocaml res --create-stdlib` to generate `ts2ocaml.res`. You can safely add it to your project, and even modify it for your needs. + +## Choosing a preset + +`ts2ocaml` has many options, so there is an option [`--preset`](#--preset) to set multiple options at once which is commonly used together. + +- `--preset=minimal` + - A preset to **minimize the output**. + - Intended for library authors, who will modify the output and build a binding library upon it. + - It generates the simplest binding. + - However, it lacks subtyping and it will not compile if the package depends on another package. +- `--preset=safe` + - A preset to generate a code **which just compiles and works**. + - Suited for generating bindings for relatively small packages, which involve less inheritance and slightly depend on other packages. + - e.g. `yargs`, which has a minimal dependency and does not make use of `extends` so much. +- `--preset=full` + - A preset to generate a code with **more type safety** and **more support for package dependency**. + - Suited for generating bindings for large packages, which have many `extends` and/or heavily depend on another package. + - e.g. React component packages, which almost certainly inherits many interfaces from React. + +[`--preset`](#--preset) doesn't override options you explicitly set. +See [`--preset`](#--preset) for the options which will be set by each preset. + +> **Hint:** if a package `foo` depends only on `bar` and `bar` depends on many other packages, +> it's safe to use `--preset=safe` to `foo` and `--preset=full` to `bar`, but not vice versa. + +## Generating and using the bindings + +Once you figure out which preset (and some additional options if any) to use, you are now ready to run `ts2ocaml`. + +``` +ts2ocaml res --preset full --output-dir src node_modules/typescript/lib/typescript.d.ts +``` + +A binding (`typescript.res` and `typescript.resi` in this example) will be generated in the `src` directory. + +The binding has an `Export` module which corresponds to the package's default export (`export default ..` or `export = ..` in TypeScript). + +Define a module alias to "import" the package: + +```rescript +module Ts = Typescript.Export +``` + +Now you can use the binding through the module alias: + +```rescript +let source = "let x: string = 'hello, world!'" + +let result = Ts.transpileModule( + ~input=source, + ~transpileOptions=Ts.TranspileOptions.make( + ~compilerOptions=Ts.CompilerOptions.make(~\"module"=CommonJS), + ), +) + +Js.log(result->Ts.TranspileOutput.get_outputText) +``` + +# Conventions + +Here we describe the coding conventions and file name conventions used by `ts2ocaml` to ensure that multiple bindings work together without problem. If you are not interested, you can skip to the [Usage](#usage) setion. + +## `import` and `export` + +To work with multiple files and packages, `ts2ocaml` has some conventions around the name of the generated OCaml source codes. + +1. If not known, `ts2ocaml` computes the JS module name of the input `.d.ts` file by [heuristics](#how-the-heuristics-work). +2. `ts2ocaml` converts the JS module name to a ReScript module name by the followings: + - Removes `@` at the top of the module name + - Replaces `/` with `__` + - Replaces any other signs (such as `-`) to `_` +3. `ts2ocaml` uses the ReScript module name as the output file name. + +### How the heuristics work + +- If the filename is equal to `types` or `typings` of `package.json`, then `ts2ocaml` will use the package name itself. + - input: `node_modules/typescript/lib/typescript.d.ts` + - `package.json`: `"typings": "./lib/typescript.d.ts",` + - `getJsModuleName`: `typescript` + - output file: `typescript.res` +- If the filename is present in `exports` of `package.json`, then `ts2ocaml` will combine the package name and the exported module name. + - input: `node_modules/@angular/common/http/http.d.ts` + - `package.json`: `"exports": { .., "./http": { "types": "./http/http.d.ts", .. }, .. }` + - `getJsModuleName`: `@angualr/common/http` + - output file: `angular__common__http.res` +- Otherwise, `ts2ocaml` uses a heuristic module name: it will combine the package name and the filename. `index.d.ts` is handled specially. + - input: `node_modules/cassandra-driver/lib/auth/index.d.ts` + - `getJsModuleName`: `cassandra-driver/auth` + - output file: `cassandra_driver__auth.res` + - if `package.json` is not present, the package name is also inferred heuristically from the filename. + +### How the `import` statements are translated + +- `import` of another package from `node_modules` will be converted to an `open` statement or a module alias. + - The ReScript module name of the imported package is computed by the step 2 of [the above](#handling-import-and-export). + +```typescript +// node_modules/@types/react/index.d.ts +import * as CSS from "csstype"; +import { Interaction as SchedulerInteraction } from "scheduler/tracing"; +``` + +```rescript +// react.res +/* import * as CSS from 'csstype'; */ +module CSS = Csstype.Export +/* import { Interaction as SchedulerInteraction } from 'scheduler/tracing'; */ +module SchedulerInteraction = Scheduler__tracing.Export.Interaction +``` + +- `import` of relative path will be converted to an `open` statement or a module alias. + - The OCaml module name of the imported file will also be inferred by [heuristics](#how-the-heuristics-work). + +```typescript +// node_modules/cassandra-driver/index.d.ts +import { auth } from "./lib/auth"; +``` + +```rescript +// cassandra_driver.res +module Auth = Cassandra_driver__auth.Export.Auth +``` + +```typescript +// node_modules/cassandra-driver/lib/mapping/index.d.ts +import { Client } from "../../"; +``` + +```rescript +// cassandra_driver__mapping.res +module Client = Cassandra_driver.Export.Client +``` + +- Indirect `import` using identifiers is not yet be supported. + +```typescript +import { types } from "./lib/types"; +import Uuid = types.Uuid; // we should be able to convert this to `module Uuid = Type.Uuid`, but not yet +``` + +- Direct `export` of an external module **will not be supported**. + +```typescript +export { someFunction } from "./lib/functions"; // this is VERY hard to do in OCaml! +``` + +### How the `export` statements are translated + +`ts2ocaml` will create a module named `Export` to represent the exported definitions. + +- If an export assignment `export = Something` is used, the `Export` module will be an alias to the `Something` module. + +```rescript +/* export = Something */ +module Export = Something +``` + +- If ES6 exports `export interface Foo` or `export { Bar }` are used, the `Export` module will contain the exported modules. + +```rescript +module Export = { + /* export interface Foo */ + module Foo = Foo + /* export { Bar } */ + module Bar = Bar + /* export { Baz as Buzz } */ + module Buzz = Baz +} +``` + +This is why you are advised to use the generated bindings with the following: + +```rescript +/* This is analogous to `import * as TypeScript from "typescript";` */ +module TypeScript = Typescript.Export +``` + +## Optional type parameters + +TypeScript makes use of [generic parameter defaults](https://www.typescriptlang.org/docs/handbook/2/generics.html#generic-parameter-defaults), where you can make a type parameter optional with a default type, which is not supported by ReScript. As such, `ts2ocaml` emits additional type aliases when it encounters such type parameters. + +For example, assume we have `node_modules/foo/index.d.ts` and `node_modules/bar/index.d.ts` as the following: + +```typescript +// foo/index.d.ts + +declare namespace foo { + interface A { ... } + + interface B { ... } +} + +export = foo; +``` + +```typescript +// bar/index.d.ts + +import * as Foo from "foo"; + +declare function useA(a: Foo.A): void; +declare function useB(b: Foo.B): void; +declare function useBDefault(b: Foo.B): void; +``` + +Then the outputs will look like this: + +```rescript +/* foo.res */ + +module Foo = { + module A = { + type t<'T> = intf<[#A(T)]> + + ... + } + + module B = { + type t<'T> = intf<#B(T)> + type t0 = t + + ... + } +} + +/* export = foo; */ +module Export = Foo +``` + +```rescript +/* bar.res */ + +/* import * as Foo from "foo"; */ +module Foo = Foo.Export + +@module("bar") @val external useA: (Foo.A.t<'T>) => unit = "useA" +@module("bar") @val external useB: (Foo.B.t<'T>) => unit = "useB" +@module("bar") @val external useBDefault: (Foo.B.t0) => unit = "useBDefault" +``` + +# Usage + +```bash +$ ts2ocaml res [options] +``` + +> See also [the common options](common_options.md). + +# General Options + +## `--preset` + +Specify the preset to use. + +- `--preset=minimal` + - It sets `--simplify=all``. +- `--preset=safe` + - It sets `--subtyping=cast-function`. + - It also sets all the options `--preset=minimal` sets. +- `--preset=full` + - It sets `--inherit-with-tags=full` and `--subtyping=tag`. + - It also sets all the options `--preset=safe` sets. + +## `--create-stdlib` + +If set, `ts2ocaml` will create `ts2ocaml.res`. + +# Output Options + +## `-o`, `--output-dir` + +The directory to place the generated bindings. +If not set, it will be the current directory. + +## `--no-resi` + +If set, `ts2ocaml` will not generate interface files (`.resi`). + +# JS Module Options + +## `--module` + +Override the JS module type. If not set, it is inferred from the input. + +- `--module=es`: Treats the input as an ES module. +- `--module=cjs`: Treats the input as a CommonJS module. +- `--module=none`: Treats the input as a global definition. + +## `--name` + +Override the JS module name used in the `@module` attribute. +If not set, it is inferred from `package.json`. + +# Typer Options + +## `--int`, `--number-as-int` + +Treat number types as `int`. If not set, `float` will be used. + +## `--subtyping` + +> See also [the detailed docs about modeling TypeScript's subtyping in OCaml](modeling_subtyping.md). + +Turn on subtyping features. + +You can use `--subtyping=foo,bar` to turn on multiple features. Also, use `--subtyping=off` to explicitly disable subtyping features. + +### Feature: `tag` + +Use `intf<'tags>` for class and interface types, which [simulates nominal subtyping](modeling_subtyping.md#phantom-types-with-row-polymorphism-polymorphic-variants) by putting to `'tags` the class names as a polymorphic variant. + +For example, assume we have the following input: + +```typescript +interface A { + methA(a: number): number; +} + +interface B extends A { + methB(a: number, b: number): number; +} + +interface C extends B { + methC(a: number, b: number, c: number): number; +} +``` + +When this feature is used, the resulting binding will look like: + +```rescript +module A = { + type t = intf<[ #A ]> + @send external methA: (t, ~a:float) => float = "methA" + external castFrom: (intf<[> #A ]>) => t = "%identity" +} + +module B = { + type t = intf<[ #A | #B ]> + @send external methB: (t, ~a:float, ~b:float) => float = "methB" + external castFrom: (intf<[> #B ]>) => t = "%identity" +} + +module C = { + type t = intf<[ #A | #B | #C ]> + @send external methC: (t, ~a:float, ~b:float, ~c:float) => float = "methC" + external castFrom: (intf<[> #C ]>) => t = "%identity" +} +``` + +So if we have a `let x : C.t`, you can directly cast it to `A.t` by writing `x :> A.t`. + +Alternatively, you can also write `A.castFrom(x)`, which uses a generic cast function `castFrom`. + +```rescript +let c : C.t = ... + +let a1 : A.t = c :> A.t +let a2 : A.t = A.castFrom(c) +``` + +### Feature: `cast-function` + +Add [`cast` functions](https://github.com/ocsigen/ts2ocaml/blob/bootstrap/docs/modeling_subtyping.md#cast-functions) to cast types around. + +For example, assume we have the following input: + +```typescript +interface A { + methA(a: number): number; +} + +interface B extends A { + methB(a: number, b: number): number; +} + +interface C extends B { + methC(a: number, b: number, c: number): number; +} +``` + +When this feature is used, the resulting binding will look like: + +```rescript +module A = { + type t + @send external methA: (t, ~a:float) => float = "methA" +} + +module B = { + type t + @send external methB: (t, ~a:float, ~b:float) => float = "methB" + external castToA: (t) => A.t = "%identity" +} + +module C = { + type t + @send external methC: (t, ~a:float, ~b:float, ~c:float) => float = "methC" + external castToB: (t) => B.t = "%identity" +} +``` + +So if we have a `let x : C.t`, you can cast it to `A.t` by writing `B.castToA(C.castToB(x))`. + +```rescript +let c : C.t = ... + +let a : A.t = x->C.castToB->B.castToA +``` + +This feature is less powerful than [`tag`](#feature-tag), but it has some use cases [`tag`](#feature-tag) doesn't cover. + +- [`tag`](#feature-tag) [doesn't support diamond inheritance](modeling_subtyping.md#phantom-types-with-row-polymorphism-polymorphic-variants), while `cast-function` does. +- When [`--inherit-with-tags`](#--inherit-with-tags) is not used, [`tag`](#feature-tag) doesn't support casting a type to other from a different package, while `cast-function` does. + +## `--inherit-with-tags` + +> **Note:** This options requires [`--subtyping=tag`](#feature-tag). If the `tag` feature is not specified, it will fail with an error. + +Use `TypeName.tags` type names to inherit types from other packages. + +- `--inherit-with-tags=full` (default) + - It generates `tags` types in the module, and tries to use `tags` type to inherit a type if it is unknown (e.g. from another package). +- `--inherit-with-tags=provide` + - It only generates `tags` types in the module. +- `--inherit-with-tags=consume` + - It only tries to use `tags` type if the inherited type is unknown. +- `--inherit-with-tags=off` + - It disables any usage of `tags` types. + +For example, assume we have `node_modules/foo/index.d.ts` and `node_modules/bar/index.d.ts` as the following: + +```typescript +// foo/index.d.ts + +declare namespace foo { + interface A { ... } +} + +export = foo; +``` + +```typescript +// bar/index.d.ts + +import * as Foo from 'foo'; + +declare namespace bar { + interface B extends A { ... } +} + +export = bar; +``` + +Then the outputs will look like depending on the option you set: + +```rescript +/* foo.res */ + +module Foo = { + module A = { + type t = intf<[ #A ]> + + /* this will be generated if `full` or `provide` is set */ + type tags = [ #A ] + + /* this will be generated regardless of the option */ + type this<'tags> = intf<'tags> constraint 'tags = [> #A ] + external castFrom: (this<'tags>) => t = "%identity" + + ... + } +} + +/* export = foo; */ +module Export = Foo +``` + +```rescript +/* bar.res */ + +/* import * as Foo from "foo"; */ +module Foo = Foo.Export + +module Bar = { + module B = { + /* if `full` or `consume` is set, this will be generated */ + type t = intf<[ #B | Foo.A.tags ]> + /* otherwise, this will be generated */ + type t = intf<[ #B ]> + + /* if `full` is set, this will be generated */ + type tags = [ #B | Foo.A.tags ] + /* else if `provide` is set, this will be generated */ + type tags = [ #B ] + + /* this will be generated regardless of the option */ + type this<'tags> = intf<'tags> constraint 'tags = [> #B ] + external castFrom: (this<'tags>) => t = "%identity" + + ... + } +} + +/* export = bar; */ +module Export = Bar +``` + +If `provide` or `full` is used for `foo.d.ts` and `consume` or `full` is used for `bar.d.ts`, +you will be able to safely cast `B.t` to `A.t`, although they come from different packages. + +```rescript +module Foo = Foo.Export +module Bar = Bar.Export + +let bar : Bar.B.t = ... + +let foo1 : Foo.A.t = bar :> Foo.A.t +let foo2 : Foo.A.t = Foo.A.castFrom(bar) +``` + +Otherwise, you can't safely cast `B.t` to `A.t`. To do it, you will have to + +- set [`--subtyping=cast-function`](#feature-cast-function) to obtain `castToA: (B.t) => A.t`, or +- manually add `#A` to the definition of `B.t` (and `B.tags` if you choose to provide). + +# Code Generator Options + +## `--simplify` + +Turn on simplification features. + +You can use `--simplify=foo,bar` to turn on multiple features. Also, `--simplify=all` enables all the features and `--simplify=off` explicitly disables simplification features. + +### Feature: `immediate-instance` + +Simplifies a value definition of an interface type with the same name **(case sensitive)** to a module. + +Assume we have the following input: + +```typescript +interface Foo = { + someMethod(value: number): void; +} + +declare var Foo: Foo; +``` + +If this option is set, the output will be: + +```rescript +module Foo = { + @module("package") @val @scope("Foo") external someMethod: float => unit = "someMethod" +} + +/* usage */ +Foo.someMethod(42.0) +``` + +Otherwise, the output will be: + +```rescript +module Foo = { + type t + + @send external someMethod: (t, float) => unit = "someMethod" +} + +@module("package") @val external foo: Foo.t = "Foo" + +/* usage */ +foo->Foo.someMethod(42.0) +``` + +A notable example is the `Math` object in ES5 (https://github.com/microsoft/TypeScript/blob/main/lib/lib.es5.d.ts). + +### Feature: `immediate-constructor` + +Simplifies so-called constructor pattern. + +Assume we have the following input: + +```typescript +interface Foo = { + someMethod(value: number): void; +} + +interface FooConstructor { + new(name: string) : Foo; + + staticMethod(): number; +} + +declare var Foo: FooConstructor; +``` + +If this option is set, the output will be: + +```rescript +module Foo = { + type t + @send external someMethod: (t, float) => unit = "someMethod" + + @module("package") @new external create: (string) => t = "Foo" + @module("package") @scope("Foo") @val external staticMethod: () => float = "staticMethod" +} + +/* usage */ +let x = Foo.create("foo") +let num = Foo.staticMethod() +x->Foo.someMethod(num) +``` + +Otherwise, the output will be: + +```rescript +module Foo = { + type t + @send external someMethod: (t, float) => unit = "someMethod" +} + +module FooConstructor = { + type t + @get external create: Newable.t1 = "Foo" + @send external staticMethod: (t, ()) => float = "staticMethod" +} + +@module("package") @val external foo: FooConstructor.t = "Foo" + +/* usage */ +let x = foo->FooConstructor.create->Newable.apply1("foo") +let num = foo->FooConstructor.staticMethod() +x->Foo.someMethod(num) +``` + +A notable example is the `ArrayConstructor` type in ES5 (https://github.com/microsoft/TypeScript/blob/main/lib/lib.es5.d.ts). + +### Feature: `anonymous-interface-value` + +Simplifies a value definition of an anonymous interface type to a module. + +Assume we have the following input: + +```typescript +declare var Foo: { + someMethod(value: number): void; +}; +``` + +If this option is set, the output will be: + +```rescript +module Foo = { + @module("package") @val external someMethod: (float) => unit = "someMethod" +} + +/* usage */ +Foo.someMethod(42.0) +``` + +Otherwise, the output will be: + +```rescript +module AnonymousInterface = { + type t + + @send external someMethod: (t, float) => unit = "someMethod" +} + +@module("package") @val external foo: AnonymousInterface.t = "Foo" + +/* usage */ +foo->AnonymousInterface.someMethod(42.0) +``` + +A notable example is the `Document` variable in DOM (https://github.com/microsoft/TypeScript/blob/main/lib/lib.dom.d.ts). + +### Feature: `named-interface-value` + +> **Note:** [`immediate-instance`](#feature-immediate-instance) and [`immediate-constructor`](#feature-immediate-constructor) will override this feature if the name of the value definition is the same as the corresponding interface. + +Defines additional module with a suffix `Static` for a value definition of some interface type. + +Assume we have the following input: + +```typescript +interface Foo = { + someMethod(value: number): void; +} + +declare var foo: Foo; +``` + +If this option is set, the output will be: + +```rescript +module Foo = { + type t + + @send external someMethod: (t, float) => unit = "someMethod" +} + +module FooStatic = { + @module("package") @scope("Foo") @val external someMethod: float => unit = "someMethod" +} + +@module("package") @val external foo: Foo.t = "Foo" + +/* usage */ +FooStatic.someMethod(42.0) +foo->Foo.someMethod(42.0) // "instance call" is also available +``` + +Otherwise, the output will be: + +```rescript +module Foo = { + type t + + @send external someMethod: (t, float) => unit = "someMethod" +} + +@module("package") @val external foo: Foo.t = "Foo" + +/* usage */ +foo->Foo.someMethod(42.0) +``` + +A notable example is the `document` variable in DOM (https://github.com/microsoft/TypeScript/blob/main/lib/lib.dom.d.ts). + +## `--readable-names` + +Try to use more readable names instead of `AnonymousInterface{N}`. + +- If the anonymous interface is an argument of a function, the name of the argument will be used. +- If the anonymous interface is the type of a field or the return type of a function, the name of the field/function will be used. + +## `--no-types-module` + +TypeScript code often has mutually recursive definitions. ReScript support defining recursive types by `type rec`, but there are some cases where `type rec` is not enough. As such, `ts2ocaml` emits a special recursive module named `Types` that contains all the types used in the file. You can use the `--no-types-module` option to disable this. + +> **Warning:** +> This option is intended for library authors who want a minimalistic output. It will generate a broken code if an input file contains mutually recursive types. A manual modification would be needed! +> +> Also, you wouldn't need this unless you're using the [`--no-resi`](#--no-resi) option, as the `Types` module is hidden by the `.resi` file and won't show up in the editor autocompletion. + diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 7cf40998..9b6b354c 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -66,12 +66,12 @@ type Options = // general options abstract preset: Preset option with get abstract createStdlib: bool with get - // JS options - abstract ``module``: ModuleKind with get - abstract name: string option with get // output options abstract outputDir: string option with get abstract resi: bool with get + // JS options + abstract ``module``: ModuleKind with get + abstract name: string option with get // typer options abstract numberAsInt: bool with get, set abstract subtyping: Subtyping list with get, set From 956b3ed40d9f219a63fac7db1fb6d4111e19b19c Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 27 Feb 2024 16:20:49 +0900 Subject: [PATCH 55/56] Implement --experimental-tagged-union --- build/build.fs | 2 +- dist/res/src/ts2ocaml.res | 18 +-- docs/rescript.md | 70 ++++++++++++ lib/Common.fs | 1 + lib/Extensions.fs | 14 +++ lib/Typer.fs | 149 +++++++++++++++---------- src/Targets/ReScript/Common.fs | 15 +++ src/Targets/ReScript/ReScriptHelper.fs | 6 +- src/Targets/ReScript/Writer.fs | 75 +++++++++++-- 9 files changed, 263 insertions(+), 87 deletions(-) diff --git a/build/build.fs b/build/build.fs index 55981837..748454b6 100644 --- a/build/build.fs +++ b/build/build.fs @@ -172,7 +172,7 @@ module Test = let packages = [ // "full" package involving a lot of inheritance - "full", !! "node_modules/typescript/lib/typescript.d.ts", []; + "full", !! "node_modules/typescript/lib/typescript.d.ts", ["--experimental-tagged-union"]; // "full" packages involving a lot of dependencies (which includes some "safe" packages) "safe", !! "node_modules/@types/scheduler/tracing.d.ts", []; diff --git a/dist/res/src/ts2ocaml.res b/dist/res/src/ts2ocaml.res index 6f4dcbb0..ce3c7ae6 100644 --- a/dist/res/src/ts2ocaml.res +++ b/dist/res/src/ts2ocaml.res @@ -125,14 +125,6 @@ module Primitive = { } } -module Interop = { - module PolyVariant = { - let name = (it: 'PolyVariant) : 'name => %raw(`it.NAME`) - let value = (it: 'PolyVariant) : 'value => %raw(`it.VAL`) - let make = (name: 'name, value: 'value) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`) - } -} - module Newable = { type t0<'t> type t1<'arg1, 't> @@ -222,4 +214,12 @@ module ThisType = { type t<'a> } module Uppercase = { type t<'s> = private intrinsic } module Lowercase = { type t<'s> = private intrinsic } module Capitalize = { type t<'s> = private intrinsic } -module Uncapitalize = { type t<'s> = private intrinsic } \ No newline at end of file +module Uncapitalize = { type t<'s> = private intrinsic } + +// utilities for experimental features +module Experimental = { + module Variant = { + let box = (it: 't, tag: string) : 'Variant => %raw(`{ [tag]: it[tag], _0: it }`) + let unbox = (it: 'Variant) : 't => %raw(`it._0`) + } +} \ No newline at end of file diff --git a/docs/rescript.md b/docs/rescript.md index 9172c8f6..956c421d 100644 --- a/docs/rescript.md +++ b/docs/rescript.md @@ -768,3 +768,73 @@ TypeScript code often has mutually recursive definitions. ReScript support defin > > Also, you wouldn't need this unless you're using the [`--no-resi`](#--no-resi) option, as the `Types` module is hidden by the `.resi` file and won't show up in the editor autocompletion. +# Experimental Options + +> **Warning:** +> These features are experimental and may be subject to change. + +## `--experimental-tagged-union` + +Emit additional variant type for tagged union. + +Assume we have the following input: + +```typescript +interface Foo { + kind: "foo"; + ... +} + +interface Bar { + kind: "bar"; + ... +} + +type FooBar = Foo | Bar; +``` + +Normally, `ts2ocaml` would generate the following code: + +```rescript +module Foo = { + type t + @get external get_kind: (t) => string = "kind" + ... +} + +module Bar = { + type t + @get external get_kind: (t) => string = "kind" + ... +} + +module FooBar = { + type t = Union.t2 +} +``` + +With this option, `ts2ocaml` will generate an additional type `FooBar.cases` and additional functions `FooBar.box` and `FooBar.unbox`: + +```rescript +module FooBar = { + type t = Union.t2 + + @tag("kind") type cases = + | @as("foo") Foo (Foo.t) + | @as("bar") Bar (Bar.t) + + let box: (t) => cases = ... + let unbox: (cases) => t = ... +} +``` + +Now you can match over the tagged union type by `box`ing it first: + +```rescript +let x : FooBar.t = ... + +switch x->FooBar.box { + | Foo(foo) => ... + | Bar(bar) => ... +} +``` \ No newline at end of file diff --git a/lib/Common.fs b/lib/Common.fs index b39d6428..b5318be1 100644 --- a/lib/Common.fs +++ b/lib/Common.fs @@ -35,6 +35,7 @@ type OverloadRenamer(?rename: string -> int -> string, ?used: Set m.[(category, name)] <- i + 1 diff --git a/lib/Extensions.fs b/lib/Extensions.fs index 7d1aa9c7..fcd9b8c1 100644 --- a/lib/Extensions.fs +++ b/lib/Extensions.fs @@ -105,6 +105,20 @@ module Map = | Some v1 -> m1 |> Map.add k (f v1 v2) ) m1 + let intersectWith f m1 m2 = + let getKeys = Map.keys >> Set.ofSeq + Set.intersect (getKeys m1) (getKeys m2) + |> Set.toSeq + |> Seq.choose (fun key -> + let v1 = m1 |> Map.tryFind key + let v2 = m2 |> Map.tryFind key + match v1, v2 with + | None, None -> None + | Some v, None + | None, Some v -> Some (key, v) + | Some v1, Some v2 -> f v1 v2 |> Option.map (fun v -> key, v)) + |> Map.ofSeq + type MutableMap<'k, 'v> = Collections.Generic.Dictionary<'k, 'v> type MutableSet<'v> = Collections.Generic.HashSet<'v> diff --git a/lib/Typer.fs b/lib/Typer.fs index ad0c466c..83e2f2bc 100644 --- a/lib/Typer.fs +++ b/lib/Typer.fs @@ -1071,6 +1071,69 @@ module Type = s1 + s2 | UnknownType _ -> "unknown" + module GetAnonymousInterfaces = + let rec treatFuncType (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (ft: FuncType) tps = + seq { + for arg in ft.args do + let ty, origin = + match arg with + | Choice1Of2 fl -> fl.value, { state.origin with argName = Some fl.name } + | Choice2Of2 t -> t, state.origin + yield! findTypes typeFinder {| state with origin = origin |} ty + yield! findTypes typeFinder state ft.returnType + yield! treatTypeParameters state tps + } + and treatTypeParameters (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (tps: TypeParam list) = + seq { + for tp in tps do + yield! tp.extends |> Option.map (findTypes typeFinder state) |? Seq.empty + yield! tp.defaultType |> Option.map (findTypes typeFinder state) |? Seq.empty + } + and treatNamed (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) name value = + findTypes typeFinder {| state with origin = { state.origin with valueName = Some name } |} value + and typeFinder (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) ty = + let inline resultMany xs = Some [], state, xs + match ty with + | App (AAnonymousInterface i, _, _) | AnonymousInterface i -> + let inner = + let state = {| state with origin = AnonymousInterfaceOrigin.Empty |} + treatClassLike state (i.MapName(ignore)) + None, {| state with origin = AnonymousInterfaceOrigin.Empty |}, Seq.append [i, state] inner + | Func (ft, tps, _) | NewableFunc (ft, tps, _) -> + treatFuncType state ft tps |> resultMany + | Union { types = types } | Intersection { types = types } -> + Some types, state, Seq.empty + | _ -> None, {| state with origin = AnonymousInterfaceOrigin.Empty |}, Seq.empty + and treatClassLike (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (c: Class) = + seq { + for _, m in c.members do + match m with + | Method (name, ft, tps) -> + yield! treatFuncType {| state with origin = { state.origin with valueName = Some name } |} ft tps + | Newable (ft, tps) | Callable (ft, tps) -> yield! treatFuncType state ft tps + | Field (fl, _) | Getter fl | Setter fl -> yield! treatNamed state fl.name fl.value + | Indexer (ft, _) -> yield! treatFuncType state ft [] + | SymbolIndexer (name, ft, _) -> + yield! treatFuncType {| state with origin = { state.origin with valueName = Some name } |} ft [] + | Constructor ft -> + for arg in ft.args do + let ty, origin = + match arg with + | Choice1Of2 fl -> fl.value, { state.origin with argName = Some fl.name } + | Choice2Of2 t -> t, state.origin + yield! findTypes typeFinder {| state with origin = origin |} ty + | UnknownMember _ -> () + for t in c.implements do + yield! findTypes typeFinder state t + yield! treatTypeParameters state c.typeParams + } + let getAnonymousInterfaces ty = + let state = {| + origin = AnonymousInterfaceOrigin.Empty + namespace_ = [] + |} + findTypes GetAnonymousInterfaces.typeFinder state ty + module Statement = open Type @@ -1145,62 +1208,6 @@ module Statement = () stmts |> Set.ofSeq let getAnonymousInterfaces stmts : Set = - let rec treatFuncType (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (ft: FuncType) tps = - seq { - for arg in ft.args do - let ty, origin = - match arg with - | Choice1Of2 fl -> fl.value, { state.origin with argName = Some fl.name } - | Choice2Of2 t -> t, state.origin - yield! findTypes typeFinder {| state with origin = origin |} ty - yield! findTypes typeFinder state ft.returnType - yield! treatTypeParameters state tps - } - and treatTypeParameters (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (tps: TypeParam list) = - seq { - for tp in tps do - yield! tp.extends |> Option.map (findTypes typeFinder state) |? Seq.empty - yield! tp.defaultType |> Option.map (findTypes typeFinder state) |? Seq.empty - } - and treatNamed (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) name value = - findTypes typeFinder {| state with origin = { state.origin with valueName = Some name } |} value - and typeFinder (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) ty = - let inline resultMany xs = Some [], state, xs - match ty with - | App (AAnonymousInterface i, _, _) | AnonymousInterface i -> - let inner = - let state = {| state with origin = AnonymousInterfaceOrigin.Empty |} - treatClassLike state (i.MapName(ignore)) - None, {| state with origin = AnonymousInterfaceOrigin.Empty |}, Seq.append [i, state] inner - | Func (ft, tps, _) | NewableFunc (ft, tps, _) -> - treatFuncType state ft tps |> resultMany - | Union { types = types } | Intersection { types = types } -> - Some types, state, Seq.empty - | _ -> None, {| state with origin = AnonymousInterfaceOrigin.Empty |}, Seq.empty - and treatClassLike (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (c: Class) = - seq { - for _, m in c.members do - match m with - | Method (name, ft, tps) -> - yield! treatFuncType {| state with origin = { state.origin with valueName = Some name } |} ft tps - | Newable (ft, tps) | Callable (ft, tps) -> yield! treatFuncType state ft tps - | Field (fl, _) | Getter fl | Setter fl -> yield! treatNamed state fl.name fl.value - | Indexer (ft, _) -> yield! treatFuncType state ft [] - | SymbolIndexer (name, ft, _) -> - yield! treatFuncType {| state with origin = { state.origin with valueName = Some name } |} ft [] - | Constructor ft -> - for arg in ft.args do - let ty, origin = - match arg with - | Choice1Of2 fl -> fl.value, { state.origin with argName = Some fl.name } - | Choice2Of2 t -> t, state.origin - yield! findTypes typeFinder {| state with origin = origin |} ty - | UnknownMember _ -> () - for t in c.implements do - yield! findTypes typeFinder state t - yield! treatTypeParameters state c.typeParams - } - findStatements (fun currentNamespace state stmt -> let inline result_ x = Some [], state, x let state = {| origin = state; namespace_ = currentNamespace |} @@ -1208,18 +1215,18 @@ module Statement = | TypeAlias ta -> let state = {| state with origin = { state.origin with typeName = Some ta.name } |} seq { - yield! findTypes typeFinder state ta.target - yield! treatTypeParameters state ta.typeParams + yield! findTypes GetAnonymousInterfaces.typeFinder state ta.target + yield! GetAnonymousInterfaces.treatTypeParameters state ta.typeParams } |> result_ | Variable v -> - treatNamed state v.name v.typ |> result_ + GetAnonymousInterfaces.treatNamed state v.name v.typ |> result_ | Function f -> - treatFuncType {| state with origin = { state.origin with valueName = Some f.name } |} f.typ f.typeParams |> result_ + GetAnonymousInterfaces.treatFuncType {| state with origin = { state.origin with valueName = Some f.name } |} f.typ f.typeParams |> result_ | Class c -> let typeName = match c.name with Name n -> Some n | _ -> None let state = {| state with namespace_ = currentNamespace; origin = { state.origin with typeName = typeName } |} - treatClassLike state (c.MapName(ignore)) |> result_ + GetAnonymousInterfaces.treatClassLike state (c.MapName(ignore)) |> result_ | _ -> None, state.origin, Seq.empty ) AnonymousInterfaceOrigin.Empty stmts |> Set.ofSeq @@ -1428,6 +1435,26 @@ module ResolvedUnion = ] cases |> String.concat " | " + let expand ctx (u: UnionType) : UnionType = + let (|Dummy|) _ = [] + let rec go (t: Type) = + match t with + | Union { types = types } -> + let types = types |> List.collect (fun ty -> go ty |? [ty]) + if types |> List.exists (function AnonymousInterface _ -> true | _ -> false) then None + else Some types + | (Ident ({ loc = loc } & i) & Dummy tyargs) + | App (AIdent i, tyargs, loc) -> + let finder = function + | Definition.TypeAlias a -> + let bindings = Type.createBindings i.name loc a.typeParams tyargs + go (a.target |> Type.substTypeVar bindings ()) + | _ -> None + i |> Ident.getDefinitions ctx + |> List.tryPick (finder) + | _ -> None + { u with types = u.types |> List.collect (fun ty -> go ty |? [ty]) |> List.distinct } + let checkNullOrUndefined (u: UnionType) : {| hasNull: bool; hasUndefined: bool; rest: Type list |} = let u = Type.normalizeUnion u let nullOrUndefined, rest = diff --git a/src/Targets/ReScript/Common.fs b/src/Targets/ReScript/Common.fs index 9b6b354c..7ea7ea39 100644 --- a/src/Targets/ReScript/Common.fs +++ b/src/Targets/ReScript/Common.fs @@ -80,6 +80,8 @@ type Options = abstract simplify: Simplify list with get, set abstract readableNames: bool with get, set abstract noTypesModule: bool with get, set + // experimental options + abstract experimentalTaggedUnion: bool with get, set module Options = open Fable.Core.JsInterop @@ -229,6 +231,19 @@ module Options = defaultValue = false ) + .group( + !^ResizeArray[ + "experimental-tagged-union" + ], + "Experimental Options:" + ) + .addFlag( + "experimental-tagged-union", + (fun (o: Options) -> o.experimentalTaggedUnion), + descr="Experimental. Emit additional variant type for tagged union.", + defaultValue=false + ) + .middleware(!^validate) diff --git a/src/Targets/ReScript/ReScriptHelper.fs b/src/Targets/ReScript/ReScriptHelper.fs index ca3b6956..fe2ed436 100644 --- a/src/Targets/ReScript/ReScriptHelper.fs +++ b/src/Targets/ReScript/ReScriptHelper.fs @@ -405,15 +405,13 @@ module Term = | _ :: [] -> failwith "1-ary tuple" | xs -> concat (str ", ") xs |> between "(" ")" - let appCurried t us = t + (us |> concat (str ", ") |> between "(" ")") - let appUncurried t us = t + (us |> concat (str ", ") |> between "(. " ")") + let app t us = t + (us |> concat (str ", ") |> between "(" ")") /// `(arg1, arg2) => ret` let arrow args ret = let lhs = match args with - | [] -> failwith "0-ary function" - | [x] -> x + | [] -> str "()" | xs -> concat (str ", ") xs |> between "(" ")" lhs +@ " => " + ret diff --git a/src/Targets/ReScript/Writer.fs b/src/Targets/ReScript/Writer.fs index 0f742195..8ecfcb64 100644 --- a/src/Targets/ReScript/Writer.fs +++ b/src/Targets/ReScript/Writer.fs @@ -1269,12 +1269,14 @@ let emitEnum (ctx: Context) (current: StructuredText) (e: Enum) = |> add [e.name] parentNode |> set {| StructuredTextNode.empty with exports = Option.toList exports |} -let emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (ta: TypeAlias) : StructuredText = +let rec emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (ta: TypeAlias) : StructuredText = let emitType = emitTypeImpl flags overrideFunc let comments = (ta :> ICommented<_>).getComments() |> emitComments false let knownTypes = Statement.getKnownTypes ctx [TypeAlias ta] + let renamer = new OverloadRenamer() + let inline rename s = renamer.Rename "ctor" s let items = let ctx = ctx |> Context.ofChildNamespace ta.name let isRec = knownTypes |> Set.contains (KnownType.Ident (ctx |> Context.getFullNameOfCurrentNamespace)) @@ -1284,20 +1286,18 @@ let emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (t [TypeDefText.Create ( x.name, x.tyargs, x.target, isRec=isRec, attrs=attrs, shouldAssert=shouldAssert, - comments=emitComments false ta.comments + comments=comments )] else [TypeAliasText (Statement.typeAlias false x.name (x.tyargs |> List.map snd) x.target)] ) let fallback () = emitTypeAliases [] false (emitType ctx ta.target) - let renamer = new OverloadRenamer() - let rename s = renamer.Rename "ctor" s let nameFromType t = Naming.constructorName [getHumanReadableName ctx t] |> rename match ta.target with | Union u -> // emit as variant if possible - let ru = ResolvedUnion.resolve ctx u + let ru = ResolvedUnion.resolve ctx (ResolvedUnion.expand ctx u) let isEnumOrUnboxed = ru.satisfies(hasDU=false, hasOther=false) && ru.typeofableTypes |> Set.contains Typeofable.BigInt |> not // not supported by res @@ -1306,7 +1306,6 @@ let emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (t let isTagged = ru.satisfies(hasDU=true, hasTypeofable=false, hasArray=false, hasOther=false) && Map.count ru.discriminatedUnions = 1 - && ru.discriminatedUnions |> Map.forall (fun _ -> Map.forall (fun _ -> function AnonymousInterface _ -> true | _ -> false)) let commonCases () = [ if ru.caseNull then @@ -1334,16 +1333,14 @@ let emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (t if Set.isEmpty ru.typeofableTypes && Option.isNone ru.caseArray then [] else [Attr.Variant.unboxed] emitTypeAliases attrs true ( - newline + concat newline [ + newline + indent (concat newline [ yield! commonCases () - match ru.caseArray with | None -> () | Some ts -> yield emitConstructor (rename "Array") [] [ Type.app Type.array [emitType ctx (Union { types = Set.toList ts })] ] - for t in ru.typeofableTypes do match t with | Typeofable.String -> yield emitConstructor (rename "String") [] [Type.string] @@ -1351,14 +1348,68 @@ let emitTypeAlias flags overrideFunc (ctx: Context) (current: StructuredText) (t | Typeofable.Boolean -> yield emitConstructor (rename "Boolean") [] [Type.boolean] | _ -> () ] - ) - else if isTagged then - fallback () // TODO: special case, or just contribute to res compiler for unboxed tagged union? + )) + + else if isTagged && ctx.options.experimentalTaggedUnion then + let tagName, cases = ru.discriminatedUnions |> Map.toSeq |> Seq.head + // skip if the result would contain anonymous interfaces + if cases |> Map.exists (fun _ t -> getAnonymousInterfaces t |> Seq.isEmpty |> not) then + fallback () + else + let tps = ta.typeParams |> List.map (fun x -> x, tprintf "'%s" x.name) + let variant = + let body = + newline + indent (concat newline [ + for i, (tag, t) in cases |> Map.toSeq |> Seq.indexed do + let name = + let rec go = function + | Ident { name = name } + | App (AIdent({ name = name }), _, _) -> + List.last name |> Some + | Union { types = types } -> + let names = types |> List.choose go |> List.distinct + match names with + | [name] -> Some name + | _ -> None + | _ -> None + match go t with + | Some name -> Naming.constructorName [name] + | None -> $"Case{i + 1}" + yield emitConstructor + (rename name) + [Attr.as_ (Term.literal tag)] + [emitType ctx t] + ]) + TypeDefText.Create ("cases", tps, Some body, isRec=isRec, attrs=[Attr.Variant.tag tagName], comments=comments, shouldAssert=true) + [ + yield! fallback () + yield variant + yield! + binding (fun rename _ -> + Binding.let_ [] [] (rename "box") + (Type.arrow + [Type.appOpt (str "t") (tps |> List.map snd)] + (Type.appOpt (str "cases") (tps |> List.map snd))) + (Term.arrow [str "it"] ( + Term.app (str "Experimental.Variant.box") [str "it"; Term.literal (LString tagName)])) + ) + yield! + binding (fun rename _ -> + Binding.let_ [] [] (rename "unbox") + (Type.arrow + [Type.appOpt (str "cases") (tps |> List.map snd)] + (Type.appOpt (str "t") (tps |> List.map snd))) + (Term.arrow [str "it"] ( + Term.app (str "Experimental.Variant.unbox") [str "it"])) + ) + ] else fallback () + | TypeLiteral l -> // emit as single-case variant emitTypeAliases [] true ( emitConstructor (nameFromType (TypeLiteral l)) [Attr.as_ (Term.literal l)] [] ) + | _ -> fallback () let node = {| StructuredTextNode.empty with items = items; comments = comments; knownTypes = knownTypes |} From c81af8ce5d522877fed8de3715c58186cdac24cf Mon Sep 17 00:00:00 2001 From: cannorin Date: Tue, 27 Feb 2024 16:36:31 +0900 Subject: [PATCH 56/56] Edit docs/development.md --- docs/development.md | 42 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 36 insertions(+), 6 deletions(-) diff --git a/docs/development.md b/docs/development.md index 39543cf6..eaefbbcf 100644 --- a/docs/development.md +++ b/docs/development.md @@ -5,6 +5,9 @@ Overview for Developers Modules with **\[\\]** does not require `open` to use. +- `build/` ... build scripts + - `BindingUpdater.fs` ... a utility to update bindings in `lib/Bindings/` + - `build.fs` ... the main build script - `lib/` ... target-agnostic part of the tool (will be separated to a different repo in near future) - `Bindings/` ... bindings to JS libraries (typescript, browser-or-node) - `Extensions.fs` ... **\[\\]** extensions for standard library and JS libraries @@ -26,17 +29,19 @@ Modules with **\[\\]** does not require `open` to use. - `Target.fs` ... generic definitions for each targets (`ITarget<_>`) - `Targets/` ... targets should be placed into here - `ParserTest.fs` ... debug target to test parser and typer - - `JsOfOCaml/` ... `js_of_ocaml` target specific codes - - `Common.fs` ... command line options for `js_of_ocaml` target - - `OCamlHelper.fs` ... helper functions to generate OCaml code - - `Writer.fs` ... functions for generating OCaml code from AST - - `Target.fs` ... `ITarget<_>` instance for `js_of_ocaml` target + - `{Target}/` ... target-specific codes + - `Common.fs` ... command line options for the target + - `{Target}Helper.fs` ... helper functions to generate code for the target language + - `Writer.fs` ... functions for generating the code from AST + - `Target.fs` ... `ITarget<_>` instance for the target - `Main.fs` ... entry point - `test/` - - `jsoo/` ... test for `js_of_ocaml` target + - `jsoo/` ... test for the `js_of_ocaml` target + - `res/` ... test for the `ReScript` target - `dist/` - `js/ `... output directory for NPM packaging - `jsoo/` ... output directory for OPAM packaging + - `jsoo/` ... output directory for NPM packaging of the stdlib for ReScript - `output/` ... temporary output directory for automated testing, etc ## Requirements @@ -53,6 +58,15 @@ Modules with **\[\\]** does not require `open` to use. - Node 14.0 or higher - [yarn](https://yarnpkg.com/) is required. +- ReScript 11.0.1 or higher + - Installed by `yarn`. + +## Updating TypeScript SDK + +- Run `yarn update --latest typescript` +- Run `./fake UpdateBindings` to update the Fable binding (`lib/Bindings/TypeScript.fs`) +- Run `./fake build` and fix type errors + ## Debugging `./fake watch` to live update `dist/js/ts2ocaml.js`. @@ -89,6 +103,22 @@ The resulting `dist/js/ts2ocaml.js` is then ready to run through `node`. - Copy the bindings to `test/jsoo/src/` - Perform `dune build` in `test/jsoo/` +### Test the tool for [`ReScript` target](rescript.md) + +- Generate bindings for the following packages: + - TypeScript standard libraries (`node_modules/typescript/lib/lib.*.d.ts`) + - `typescript` with the `full` preset (involving a lot of inheritance) + - `react` with the `full` preset (depending on both `full` packages and `safe` packages) + - `scheduler/tracing` (`safe`) + - `csstype` (`full`) + - `prop-types` (`safe`) + - `react-modal` with the `full` preset (depending on a `full` package) + - `yargs` with the `safe` preset (depending on a `safe` package) + - `yargs-parser` (`safe`) +- The bindings will be placed into `output/test_res/` +- Copy the bindings to `test/res/src/generated/` +- Perform `yarn build` in `test/res/` + > Tests for other targets will be added here ## Publishing