ahrefs · koonwen · Dec 30, 2024 · Dec 30, 2024 · Dec 30, 2024 · Dec 30, 2024
@@ -3,6 +3,7 @@ Unreleased
 
 * atdgen: Add option `-j-gen-modules` to generate JSON generic submodules (#420)
 * atd-parser: improve (syntax) error messages (#426)
+* atdts: support <ts from...> annotation
 
 2.16.0 (2025-01-22)
 -------------------
@@ -33,7 +34,7 @@ Unreleased
 2.14.1 (2023-10-20)
 -------------------
 
-* atddiff: Fixed reports for new variant cases. They are now correctly 
+* atddiff: Fixed reports for new variant cases. They are now correctly
   reported as forward incompatibilities (#373)
 
 2.14.0 (2023-10-19)
@@ -42,8 +43,8 @@ Unreleased
 * atdd: Fix various issues with the interoperability of user defined types,
   used in or outside of records (#355)
 * atdd: Generated `.d` files now have the suffix `_atd.d` (#355)
-* atddiff now supports options for filtering the findings based on the 
-  direction of the incompatibility (`--backward`, `--forward`) or based on the  
+* atddiff now supports options for filtering the findings based on the
+  direction of the incompatibility (`--backward`, `--forward`) or based on the
   name of the affected types (`--types`) (#365)
 * atddiff: new option `--output-format json` for exporting the results to
   JSON (#360)
@@ -57,7 +58,7 @@ Unreleased
   definitions without `wrap` constructs (#353)
 * atdd: Add `dlang` backend to generate D code from ATD definitions (#349)
 * new tool: atddiff. Compares two versions of an ATD file and reports
-  possible incompatibilities in the JSON data. Atddiff ships as part of the 
+  possible incompatibilities in the JSON data. Atddiff ships as part of the
   `atd` package together with `atdcat` (#352, #358)
 
 2.12.0 (2023-05-12)

@@ -16,21 +16,18 @@ build:
 # generated code.
 .PHONY: test
 test:
-	$(MAKE) clean-for-dune
 	# Run atdts to convert ATD -> TypeScript
 	$(DUNE) runtest -f; status=$$?; \
           if [ "$$status" != 0 ]; then \
             echo "Run 'dune promote' to accept diffs, if any."; \
           fi; \
-	  ln -s ../../../_build/default/atdts/test/ts-tests/everything.ts \
-	    test/ts-tests/everything.ts && \
 	  exit "$$status"
 	# Compile and run the TypeScript code
 	$(MAKE) -C test/ts-tests
 
 .PHONY: clean-for-dune
 clean-for-dune:
-	rm -f test/ts-tests/everything.ts
+
 
 .PHONY: clean
 clean:

@@ -2,9 +2,4 @@
  (name Atdts_main)
  (public_name atdts)
  (package atdts)
- (libraries
-   cmdliner
-   atdts
-   atd
- )
-)
+ (libraries cmdliner atdts atd))
@@ -25,6 +25,8 @@ let annot_schema_ts : Atd.Annot.schema_section =
     fields = [
       Type_expr, "repr";
       Field, "default";
+      Type_def, "from";
+      Type_def, "t";
     ]
   }
 
@@ -95,7 +97,7 @@ let init_env () : env =
      may not be a reserved word.
   *)
   let keywords = [
-   (* Reserved Words *)
+    (* Reserved Words *)
     "break"; "case"; "catch"; "class"; "const"; "continue"; "debugger";
     "default"; "delete"; "do"; "else"; "enum"; "export"; "extends"; "false";
     "finally"; "for"; "function"; "if"; "import"; "in"; "instanceof";
@@ -578,7 +580,7 @@ let assoc_kind loc (e : type_expr) an : assoc_kind =
 (* Map ATD built-in types to built-in TypeScript types *)
 let ts_type_name env (name : string) =
   match name with
-  | "unit" -> "Null"
+  | "unit" -> "null"
   | "bool" -> "boolean"
   | "int" -> "number /*int*/"
   | "float" -> "number"
@@ -648,6 +650,15 @@ let get_ts_default (e : type_expr) (an : annot) : string option =
   | Some s -> Some s
   | None -> get_default_default e
 
+let get_export_from ~default_t an = function
+  | Name (loc, (_loc2, "abstract", _params), _) ->
+      (* For abstract types, require the 'from' annotation *)
+      (match TS_annot.get_ts_from an, TS_annot.get_ts_type an with
+       | Some from, Some t -> Some (from,t)
+       | Some from, None -> Some (from,default_t)
+       | _ -> None)
+  | _ -> None
+
 (* If the field is '?foo: bar option', its ts or json value has type
    'bar' rather than 'bar option'. *)
 let unwrap_field_type loc field_name kind e =
@@ -691,7 +702,7 @@ let rec json_reader env e =
   | Wrap (loc, e, an) -> json_reader env e
   | Name (loc, (loc2, name, []), an) ->
       (match name with
-       | "bool" | "int" | "float" | "string" -> sprintf "_atd_read_%s" name
+       | "bool" | "int" | "float" | "string" | "unit" -> sprintf "_atd_read_%s" name
        | "abstract" -> "((x: any, context): any => x)"
        | _ -> reader_name env name)
   | Name (loc, _, _) -> assert false
@@ -708,7 +719,7 @@ and tuple_reader env cells =
     |> String.concat ", "
   in
   sprintf "((x, context): %s => \
-            { _atd_check_json_tuple(%d, x, context); return [%s] })"
+           { _atd_check_json_tuple(%d, x, context); return [%s] })"
     (type_name_of_tuple env cells)
     (List.length cells)
     tuple_body
@@ -739,7 +750,7 @@ let rec json_writer env e =
   | Wrap (loc, e, an) -> json_writer env e
   | Name (loc, (loc2, name, []), an) ->
       (match name with
-       | "bool" | "int" | "float" | "string" -> sprintf "_atd_write_%s" name
+       | "bool" | "int" | "float" | "string" | "unit" -> sprintf "_atd_write_%s" name
        | "abstract" -> "((x: any, context): any => x)"
        | _ -> writer_name env name)
   | Name (loc, _, _) -> not_implemented loc "parametrized types"
@@ -789,12 +800,19 @@ let record_type env loc name (fields : field list) an =
     Line "}";
   ]
 
-let alias_type env name type_expr =
+let alias_type env name an type_expr =
   let ts_type_name = type_name env name in
-  let value_type = type_name_of_expr env type_expr in
-  [
-    Line (sprintf "export type %s = %s" ts_type_name value_type)
-  ]
+  match get_export_from ~default_t:name an type_expr with
+  | None ->
+      let value_type = type_name_of_expr env type_expr in
+      [
+        Line (sprintf "export type %s = %s" ts_type_name value_type)
+      ]
+  | Some (from,t) ->
+      [
+        Line (sprintf "import { type %s as %s } from \"./%s\"" (type_name env t) ts_type_name (String.lowercase_ascii from));
+        Line (sprintf "export { type %s }" ts_type_name)
+      ]
 
 let string_of_case_name name =
   sprintf "'%s'" (escape_string_content Single name)
@@ -850,7 +868,7 @@ let make_type_def env ((loc, (name, param, an), e) : A.type_def) : B.t =
   | List _
   | Option _
   | Nullable _
-  | Name _ -> alias_type env name e
+  | Name _ -> alias_type env name an e
   | Shared (loc, e, an) -> assert false
   | Wrap (loc, e, an) -> assert false
   | Tvar _ -> assert false
@@ -975,7 +993,7 @@ let read_root_expr env ~ts_type_name e =
                | Required ->
                    Line (
                      sprintf "%s: _atd_read_required_field(\
-                               '%s', '%s', %s, x['%s'], x),"
+                              '%s', '%s', %s, x['%s'], x),"
                        ts_name
                        (single_esc ts_type_name)
                        json_name_lit
@@ -1046,15 +1064,15 @@ let write_root_expr env ~ts_type_name e =
               (match kind with
                | Required ->
                    Line (sprintf "%s: _atd_write_required_field\
-                                    ('%s', '%s', %s, x.%s, x),"
+                                  ('%s', '%s', %s, x.%s, x),"
                            json_name_lit
                            (single_esc ts_type_name)
                            (single_esc name)
                            (json_writer env unwrapped_e)
                            ts_name)
                | Optional ->
                    Line (sprintf "%s: _atd_write_optional_field\
-                                    (%s, x.%s, x),"
+                                  (%s, x.%s, x),"
                            json_name_lit
                            (json_writer env unwrapped_e)
                            ts_name)
@@ -1063,12 +1081,12 @@ let write_root_expr env ~ts_type_name e =
                      match get_ts_default e an with
                      | None ->
                          A.error_at loc
-                          "a default field value must be specified with \
-                           <ts default=\"...\">"
+                           "a default field value must be specified with \
+                            <ts default=\"...\">"
                      | Some x -> x
                    in
                    Line (sprintf "%s: _atd_write_field_with_default\
-                                    (%s, %s, x.%s, x),"
+                                  (%s, %s, x.%s, x),"
                            json_name_lit
                            (json_writer env unwrapped_e)
                            ts_default
@@ -1096,24 +1114,38 @@ let write_root_expr env ~ts_type_name e =
 let make_reader env loc name an e =
   let ts_type_name = type_name env name in
   let ts_name = reader_name env name in
-  let read = read_root_expr env ~ts_type_name e in
-  [
-    Line (sprintf "export function %s(x: any, context: any = x): %s {"
-            ts_name ts_type_name);
-    Block read;
-    Line "}";
-  ]
+  match get_export_from ~default_t:name an e with
+  | Some (from,t) ->
+      [
+        Line (sprintf "import { %s as %s } from \"./%s\"" (reader_name env t) ts_name (String.lowercase_ascii from));
+        Line (sprintf "export { %s }" ts_name)
+      ]
+  | None ->
+      let read = read_root_expr env ~ts_type_name e in
+      [
+        Line (sprintf "export function %s(x: any, context: any = x): %s {"
+                ts_name ts_type_name);
+        Block read;
+        Line "}";
+      ]
 
 let make_writer env loc name an e =
   let ts_type_name = type_name env name in
   let ts_name = writer_name env name in
-  let write = write_root_expr env ~ts_type_name e in
-  [
-    Line (sprintf "export function %s(x: %s, context: any = x): any {"
-            ts_name ts_type_name);
-    Block write;
-    Line "}";
-  ]
+  match get_export_from ~default_t:name an e with
+  | Some (from,t) ->
+      [
+        Line (sprintf "import { %s as %s } from \"./%s\"" (writer_name env t) ts_name (String.lowercase_ascii from));
+        Line (sprintf "export { %s }" ts_name)
+      ]
+  | None ->
+      let write = write_root_expr env ~ts_type_name e in
+      [
+        Line (sprintf "export function %s(x: %s, context: any = x): any {"
+                ts_name ts_type_name);
+        Block write;
+        Line "}";
+      ]
 
 let make_functions env ((loc, (name, param, an), e) : A.type_def) : B.t =
   if param <> [] then

@@ -26,3 +26,17 @@ let get_ts_assoc_repr an : assoc_repr =
     ~sections:["ts"]
     ~field:"repr"
     an
+
+let get_ts_from an : string option =
+  Atd.Annot.get_opt_field
+    ~parse:(fun s -> Some s)
+    ~sections:["ts"]
+    ~field:"from"
+    an
+
+let get_ts_type an : string option =
+  Atd.Annot.get_opt_field
+    ~parse:(fun s -> Some s)
+    ~sections:["ts"]
+    ~field:"t"
+    an
@@ -25,3 +25,13 @@ val get_ts_default : Atd.Annot.t -> string option
     The default is ["array"].
 *)
 val get_ts_assoc_repr : Atd.Annot.t -> assoc_repr
+
+(** Extract ["ModuleName"] from [<ts from="ModuleName">].
+    This is used to identify the source module for imported types.
+*)
+val get_ts_from : Atd.Annot.t -> string option
+
+(** Extract ["TypeName"] from [<ts t="TypeName">].
+    This is used to identify the original type name in the source module.
+*)
+val get_ts_type : Atd.Annot.t -> string option
@@ -1,7 +1,3 @@
 (library
  (name atdts)
- (libraries
-   re
-   atd
- )
-)
+ (libraries re atd))
@@ -1,12 +1,8 @@
 (executable
-  (name Main)
-  (libraries
-     atdts
-     alcotest
-  )
-)
+ (name Main)
+ (libraries atdts alcotest))
 
 (rule
-  (alias runtest)
-  (action (run ./Main.exe))
-)
+ (alias runtest)
+ (action
+  (run ./Main.exe)))
@@ -0,0 +1,35 @@
+;
+; Convert ATD -> TypeScript
+;
+
+(rule
+ (deps everything.atd)
+ (targets everything.ts)
+ (action
+  (run %{bin:atdts} %{deps})))
+
+(rule
+ (deps import.atd)
+ (targets import.ts)
+ (action
+  (run %{bin:atdts} %{deps})))
+
+;
+; We test in two phases:
+;
+; 1. Check that the generated TypeScript code is what we expect.
+;
+
+(rule
+ (alias runtest)
+ (package atdts)
+ (deps everything.ts import.ts)
+ (action
+  (progn
+   (diff import.ts.expected import.ts)
+   (diff everything.ts.expected everything.ts))))
+
+; 2. Run the generated TypeScript code and check that is reads or writes JSON
+;    data as expected.
+;
+; See ../ts-tests/dune
@@ -60,3 +60,6 @@ type foo = {
 }
 
 type special_string = string wrap
+
+type import_default <ts from="Import"> = abstract
+type import <ts from="Import" t="import"> = abstract