fix: Candid repros and fixes for issues #5504, #5543

Changelog.md

@@ -74,6 +74,9 @@
 
   * bugfix: escape `composite_query` fields on the Candid side, as it is a keyword (#5617).
 
+  * bugfix: implement Candid spec improvements (#5504, #5543, #5505).
+    May now cause cause rejection of certain type-incorrect Candid messages that were accepted before.
+
 ## 0.16.3 (2025-09-29)
 
 * motoko (`moc`)

src/codegen/compile_classical.ml

@@ -8098,22 +8098,15 @@ module MakeSerialization (Strm : Stream) = struct
                 ]
             end
             begin
-              (* this check corresponds to `not (null <: <t>)` in the spec *)
-              match normalize t with
-              | Prim Null | Opt _ | Any ->
-                (* Ignore and return null *)
-                skip get_idltyp ^^
-                Opt.null_lit env
-              | _ ->
-                (* Try constituent type *)
-                let (set_val, get_val) = new_local env "val" in
-                get_idltyp ^^ go_can_recover env t ^^ set_val ^^
-                get_val ^^ compile_eq_const (coercion_error_value env) ^^
-                G.if1 I32Type
-                  (* decoding failed, but this is opt, so: return null *)
-                  (Opt.null_lit env)
-                  (* decoding succeeded, return opt value *)
-                  (Opt.inject env get_val)
+              (* Try constituent type *)
+              let (set_val, get_val) = new_local env "val" in
+              get_idltyp ^^ go_can_recover env t ^^ set_val ^^
+              get_val ^^ compile_eq_const (coercion_error_value env) ^^
+              G.if1 I32Type
+                (* decoding failed, but this is opt, so: return null *)
+                (Opt.null_lit env)
+                (* decoding succeeded, return opt value *)
+                (Opt.inject env get_val)
             end
           end
         end
@@ -8329,21 +8322,25 @@ module MakeSerialization (Strm : Stream) = struct
         ReadBuf.read_leb128 env get_main_typs_buf ^^ set_arg_count ^^
 
         G.concat_map (fun t ->
-          let can_recover, default_or_trap = Type.(
+          let can_recover, argument_default_or_trap, coercion_default_or_trap = Type.(
+            let null_result _ = Opt.null_lit env in
             match normalize t with
-            | Prim Null | Opt _ | Any ->
-              (Bool.lit true, fun msg -> Opt.null_lit env)
+            | Prim Null ->
+              (get_can_recover, null_result, fun _ -> compile_unboxed_const (coercion_error_value env))
+            | Opt _ | Any ->
+              (Bool.lit true, null_result, null_result)
             | _ ->
-              (get_can_recover, fun msg ->
+              let default_or_trap msg =
                 get_can_recover ^^
                 G.if1 I32Type
                    (compile_unboxed_const (coercion_error_value env))
-                   (E.trap_with env msg)))
+                   (E.trap_with env msg) in
+              (get_can_recover, default_or_trap, default_or_trap))
           in
           get_arg_count ^^
           compile_eq_const 0l ^^
           G.if1 I32Type
-           (default_or_trap ("IDL error: too few arguments " ^ ts_name))
+           (argument_default_or_trap ("IDL error: too few arguments " ^ ts_name))
            (begin
               (* set up variable frame arguments *)
               Stack.with_frame env "frame_ptr" 3l (fun () ->
@@ -8362,7 +8359,7 @@ module MakeSerialization (Strm : Stream) = struct
              get_arg_count ^^ compile_sub_const 1l ^^ set_arg_count ^^
              get_val ^^ compile_eq_const (coercion_error_value env) ^^
              (G.if1 I32Type
-               (default_or_trap "IDL error: coercion failure encountered")
+               (coercion_default_or_trap "IDL error: coercion failure encountered")
                get_val)
             end)
         ) ts ^^

src/codegen/compile_enhanced.ml

@@ -8573,22 +8573,15 @@ module Serialization = struct
                 ]
             end
             begin
-              (* this check corresponds to `not (null <: <t>)` in the spec *)
-              match normalize t with
-              | Prim Null | Opt _ | Any ->
-                (* Ignore and return null *)
-                skip get_idltyp ^^
-                Opt.null_lit env
-              | _ ->
-                (* Try constituent type *)
-                let (set_val, get_val) = new_local env "val" in
-                get_idltyp ^^ go_can_recover env t ^^ set_val ^^
-                get_val ^^ compile_eq_const (coercion_error_value env) ^^
-                E.if1 I64Type
-                  (* decoding failed, but this is opt, so: return null *)
-                  (Opt.null_lit env)
-                  (* decoding succeeded, return opt value *)
-                  (Opt.inject env get_val)
+              (* Try constituent type *)
+              let (set_val, get_val) = new_local env "val" in
+              get_idltyp ^^ go_can_recover env t ^^ set_val ^^
+              get_val ^^ compile_eq_const (coercion_error_value env) ^^
+              E.if1 I64Type
+                (* decoding failed, but this is opt, so: return null *)
+                (Opt.null_lit env)
+                (* decoding succeeded, return opt value *)
+                (Opt.inject env get_val)
             end
           end
         end
@@ -8827,21 +8820,25 @@ module Serialization = struct
         ReadBuf.read_leb128 env get_main_typs_buf ^^ set_arg_count ^^
 
         G.concat_map (fun t ->
-          let can_recover, default_or_trap = Type.(
+          let can_recover, argument_default_or_trap, coercion_default_or_trap = Type.(
+            let null_result _ = Opt.null_lit env in
             match normalize t with
-            | Prim Null | Opt _ | Any ->
-              (Bool.lit true, fun msg -> Opt.null_lit env)
+            | Prim Null ->
+              (get_can_recover, null_result, fun _ -> compile_unboxed_const (coercion_error_value env))
+            | Opt _ | Any ->
+              (Bool.lit true, null_result, null_result)
             | _ ->
-              (get_can_recover, fun msg ->
+              let default_or_trap msg =
                 get_can_recover ^^
                 E.if1 I64Type
                    (compile_unboxed_const (coercion_error_value env))
-                   (E.trap_with env msg)))
+                   (E.trap_with env msg) in
+              (get_can_recover, default_or_trap, default_or_trap))
           in
           get_arg_count ^^
           compile_eq_const 0L ^^
           E.if1 I64Type
-           (default_or_trap ("IDL error: too few arguments " ^ ts_name))
+           (argument_default_or_trap ("IDL error: too few arguments " ^ ts_name))
            (begin
               (* set up variable frame arguments *)
               Stack.with_frame env "frame_ptr" 3L (fun () ->
@@ -8860,7 +8857,7 @@ module Serialization = struct
              get_arg_count ^^ compile_sub_const 1L ^^ set_arg_count ^^
              get_val ^^ compile_eq_const (coercion_error_value env) ^^
              (E.if1 I64Type
-               (default_or_trap "IDL error: coercion failure encountered")
+               (coercion_default_or_trap "IDL error: coercion failure encountered")
                get_val)
             end)
         ) ts ^^

src/exes/candid_tests.ml

@@ -4,7 +4,7 @@
 *)
 open Idllib
 open Source
-open Idllib.Syntax
+open Syntax
 open Mo_idl
 open Printf
 open Mo_types
@@ -21,6 +21,7 @@ let _WASMTIME_OPTIONS_ = "-C cache=n -W nan-canonicalization,memory64,multi-memo
 let test_dir = ref ""
 let pattern = ref ""
 let expect_fail_pats = ref []
+let diagnose = ref false
 
 let print_banner () =
   printf "%s\n" banner;
@@ -35,6 +36,7 @@ let argspec = Arg.align
 [
   "-i", Arg.Set_string test_dir, " candid test directory";
   "-p", Arg.Set_string pattern, " test selector (substring/regex)";
+  "--diag", Arg.Unit (fun () -> diagnose := true), " dump generated Motoko code for the tests to stderr";
   "--expect-fail", Arg.String (fun s -> expect_fail_pats := s :: !expect_fail_pats), " tests expected to fail";
   "--version", Arg.Unit print_banner, " show version";
 ]
@@ -49,7 +51,7 @@ let write_file f s =
   close_out oc_
 
 let print_type = function
-  | [t] -> "(" ^ Pretty.string_of_typ t ^ ")" (* add parens to make this unary *)
+  | [t] -> Pretty.string_of_typ t |> Idl_to_mo_value.parens (* add parens to make this unary *)
   | ts -> Pretty.string_of_typ (Type.Tup ts)
 
 type expected_behaviour = ShouldPass | ShouldTrap
@@ -65,18 +67,18 @@ let mo_of_test tenv test : (string * expected_behaviour, string) result =
     | TextualInput x ->
       match Pipeline.parse_values x with
       | Error msgs -> raise (TextualParseError (x, msgs))
-      | Ok (vals, _) -> "(" ^ Idl_to_mo_value.args vals ts ^ " : " ^ print_type ts ^ ")"
+      | Ok (vals, _) -> Idl_to_mo_value.(args vals ts ^ " : " ^ print_type ts |> parens)
   in
-  let equal e1 e2     = "assert (" ^ e1 ^ " == " ^ e2 ^ ")\n" in
-  let not_equal e1 e2 = "assert (" ^ e1 ^ " != " ^ e2 ^ ")\n" in
+  let equal e1 e2     = "assert " ^ e1 ^ " == " ^ e2 ^ "\n" in
+  let not_equal e1 e2 = "assert " ^ e1 ^ " != " ^ e2 ^ "\n" in
   let ignore ts e =
     let open Type in
     if sub (seq ts) unit then e (* avoid warning about redundant ignore *)
-    else "ignore (" ^ e ^ ")\n" in
+    else "ignore " ^ e ^ "\n" in
 
   try
     let defs =
-      "import _Prim \"mo:⛔\";" ^
+      "import _Prim \"mo:⛔\";\n" ^
       String.concat "" (List.map (fun (n,candid_typ) ->
         let mo_typ = Idl_to_mo.check_typ tenv candid_typ in
         "type " ^ n ^ " = " ^ Pretty.string_of_typ mo_typ ^ ";\n"
@@ -249,12 +251,12 @@ let () =
           match mo_of_test tenv test with
           | Error why -> Ignored why
           | Ok (src, must_not_trap) ->
-            (* Printf.printf "\n%s" src *)
+            if !diagnose then Printf.eprintf "## %s\n\n``` Motoko\n%s```\n" testname src;
             Unix.putenv "MOC_UNLOCK_PRIM" "yesplease";
             write_file "tmp.mo" src;
-            match run_cmd "moc -Werror -wasi-system-api tmp.mo -o tmp.wasm" with
-            | ((Fail | Timeout), stdout, stderr) -> CantCompile (stdout, stderr, src)
-            | (Ok, _, _) ->
+            match run_cmd "moc -A M0215 -Werror -wasi-system-api tmp.mo -o tmp.wasm" with
+            | (Fail | Timeout), stdout, stderr -> CantCompile (stdout, stderr, src)
+            | Ok, _, _ ->
               match must_not_trap, run_cmd ("timeout 10s wasmtime "^ _WASMTIME_OPTIONS_ ^" tmp.wasm") with
               | ShouldPass, (Ok, _, _) -> WantedPass
               | ShouldTrap, (Fail, _, _) -> WantedTrap

src/idllib/idlHash.ml

@@ -1,8 +1,7 @@
-(* IDL field hashes *)
+(* IDL field hashes, called by unescape_hash *)
 let idl_hash : string -> Lib.Uint32.t = fun s ->
   let open Lib.Uint32 in
   List.fold_left
     (fun s c -> add (mul s (of_int 223)) (of_int (Char.code c)))
     zero
-    (* TODO: also unescape the string, once #465 is approved *)
     (Lib.String.explode s)

src/lib/lib.ml

@@ -344,18 +344,22 @@ struct
          grouping ((hd::l1)::acc) l2
     in grouping [] l
 
-  let rec take n xs =
+  let rec take n xs = (* present in OCaml 5.3 *)
     match n, xs with
     | _ when n <= 0 -> []
     | n, x::xs' when n > 0 -> x :: take (n - 1) xs'
     | _ -> failwith "take"
 
-  let rec drop n xs =
+  let rec drop n xs = (* present in OCaml 5.3 *)
     match n, xs with
     | 0, _ -> xs
     | n, _::xs' when n > 0 -> drop (n - 1) xs'
     | _ -> failwith "drop"
 
+  let rec replicate e = function
+    | 0 -> []
+    | n -> e :: replicate e (n - 1)
+
   let split_at n xs =
     if n <= List.length xs
     then (take n xs, drop n xs)

src/lib/lib.mli

@@ -26,6 +26,7 @@ sig
   val group : ('a -> 'a -> bool) -> 'a list -> 'a list list
   val take : int -> 'a list -> 'a list (* raises Failure *)
   val drop : int -> 'a list -> 'a list (* raises Failure *)
+  val replicate : 'a -> int -> 'a list
   val split_at : int -> 'a list -> ('a list * 'a list)
   val mapi2 : (int -> 'a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
 

src/mo_idl/idl_to_mo.ml

@@ -38,8 +38,7 @@ let check_modes ms =
 let check_label lab : M.lab =
   match lab.it with
   | Named name -> Idllib.Escape.escape name
-  | Id id -> Idllib.Escape.escape_num id
-  | Unnamed id -> Idllib.Escape.escape_num id
+  | Id id | Unnamed id -> Idllib.Escape.escape_num id
 
 let is_tuple fs =
   List.length fs > 1 &&

src/mo_idl/idl_to_mo_value.ml

@@ -32,11 +32,21 @@ let is_tuple_rec fs =
 (* We are lazy and encode text values like blobs. Output not pretty, but works. *)
 let text_lit s = "\"" ^ Mo_values.Value.Blob.escape s ^ "\""
 
-let find_typ tfs f =
+let find_typ ?(infer=fun _ -> None) tfs f =
   try T.lookup_val_field (Idl_to_mo.check_label (fst (f.it))) tfs
   with Invalid_argument _ ->
-    raise (UnsupportedCandidFeature
-      (Diag.error_message f.at "M0164" "import" "unknown record or variant label in textual representation"))
+    match infer (snd (f.it)).it with
+    | Some t -> t
+    | _ ->
+      raise (UnsupportedCandidFeature
+               (Diag.error_message f.at "M0164" "import" "unknown record or variant label in textual representation"))
+
+let infer_typ = function
+  | NullV -> Some (T.(Prim Null))
+  | NumV n when int_of_string n < 0 -> Some (T.(Prim Int))
+  | NumV _ -> Some (T.(Prim Nat))
+  | _ -> None
+
 
 (* Also compare with Mo_values.Show.show_val, which we cannot use here, because
    we don’t have the full type (although we could have that), and we have
@@ -53,9 +63,9 @@ let rec value v t =
   | BlobV b, T.Array _ ->
     brackets_comma (List.of_seq (Seq.map (fun c -> Printf.sprintf "%d" (Char.code c)) (String.to_seq b)))
   | TextV s, _ -> text_lit s
-  | RecordV fs, T.Obj (T.Object, tfs) ->
+  | RecordV fs, T.(Obj (Object, tfs)) ->
     "{" ^ String.concat "; " (List.map (fun f ->
-      Idl_to_mo.check_label (fst f.it) ^ " = " ^ value (snd f.it) (find_typ tfs f)
+      Idl_to_mo.check_label (fst f.it) ^ " = " ^ value (snd f.it) (find_typ ~infer:infer_typ tfs f)
     ) fs) ^ "}"
   | RecordV fs, T.Tup ts ->
     (* this will only line up if the record is written in tuple short hand order *)
@@ -79,4 +89,26 @@ let rec value v t =
   | _ -> raise (UnsupportedCandidFeature
     (Diag.error_message v.at "M0165" "import" "odd expected type"))
 
-let args vs ts = parens_comma (List.map2 value vs.it ts)
+let rec args vs = function
+  | ts when List.(compare_lengths vs.it ts < 0 && for_all is_defaultable (Lib.List.drop (length vs.it) ts)) ->
+    let vs' = vs.it @ Lib.List.replicate { vs with it = NullV } List.(length ts - length vs.it) in
+    args {vs with it = vs'} ts
+  | ts when List.(exists (fun (t, v) -> apart t v.it) (combine ts vs.it)) ->
+    args {vs with it = List.map2 enrich ts vs.it} ts
+  | ts -> parens_comma (List.map2 value vs.it ts)
+and is_defaultable t =
+  match T.normalize t with
+  | T.(Prim Null) | T.Opt _ | T.Any -> true
+  | _ -> false
+and apart t v = match t, v with
+  | T.(Obj (Object, tfs)), RecordV vfs ->
+       let defaultable = diff tfs (List.map (fun {it; _} -> Idl_to_mo.check_label (fst it)) vfs) in
+       defaultable <> [] && List.for_all (fun {T.typ; _} -> is_defaultable typ) defaultable
+  | _ -> false
+and enrich t v = match t, v.it with
+  | T.(Obj (Object, tfs)), RecordV vfs ->
+    let defaultable = diff tfs (List.map (fun {it; _} -> Idl_to_mo.check_label (fst it)) vfs) in
+    let defaulted = List.map (fun T.{lab; _} -> { v with it = { v with it = Id (Idllib.Escape.unescape_hash lab) }, { v with it = NullV } }) defaultable in
+    { v with it = RecordV (vfs @ defaulted) }
+  | _ -> v
+and diff tfs vls = List.filter (fun T.{lab; _} -> not (List.mem lab vls)) tfs