maybe fixed something

serde-ml · Mar 1, 2024 · aea69a8 · aea69a8
1 parent 703cebd
commit aea69a8
Show file tree

Hide file tree

Showing 2 changed files with 68 additions and 33 deletions.
diff --git a/derive/de.ml b/derive/de.ml
@@ -138,7 +138,6 @@ module Record_deserializer = struct
   let deserialize_with_unordered_fields ~ctxt type_attributes labels final_expr
       =
     let open Attributes in
-    let _ = type_attributes.deny_unknown_fields in
     let loc = loc ~ctxt in
     let labels = List.rev labels in
     let labels = List.map Attributes.of_field_attributes labels in
@@ -243,16 +242,16 @@ module Record_deserializer = struct
        ]}
     *)
     let field_visitor next =
-      let visit_string =
-        let invalid_tag_case =
-          let rhs =
-            match type_attributes.deny_unknown_fields with
-            | true -> [%expr Error `invalid_tag]
-            | false -> [%expr Ok `invalid_tag]
-          in
-          Ast.case ~lhs:(Ast.ppat_any ~loc) ~guard:None ~rhs
+      let invalid_tag_case =
+        let rhs =
+          match type_attributes.deny_unknown_fields with
+          | true -> [%expr Error `invalid_tag]
+          | false -> [%expr Ok `invalid_tag]
         in
+        Ast.case ~lhs:(Ast.ppat_any ~loc) ~guard:None ~rhs
+      in
 
+      let visit_string =
         let cases =
           List.map
             (fun (field, attr) ->
@@ -280,10 +279,7 @@ module Record_deserializer = struct
               in
               Ast.case ~lhs ~rhs ~guard:None)
             labels
-          @ [
-              Ast.case ~lhs:(Ast.ppat_any ~loc) ~guard:None
-                ~rhs:[%expr Ok `invalid_tag];
-            ]
+          @ [ invalid_tag_case ]
         in
         let body = Ast.pexp_match ~loc [%expr str] cases in
         [%expr fun _ctx str -> [%e body]]
@@ -501,7 +497,7 @@ let gen_deserialize_variant_impl ~ctxt ptype_name type_attributes
         cstr_declarations
       @ [
           Ast.case ~lhs:(Ast.ppat_any ~loc) ~guard:None
-            ~rhs:[%expr Ok `invalid_tag];
+            ~rhs:[%expr Error `invalid_tag];
         ]
     in
 

diff --git a/derive/ppx.t/run.t b/derive/ppx.t/run.t
@@ -422,23 +422,62 @@
 Now we test the variants:
 
   $ dune exec ./variant_test.exe | jq .
-  File "variant_test.ml", lines 3-8, characters 0-35:
-  3 | type rank =
-  4 |   | Captain of { name : string; ship : string }
-  5 |   | Commander of string * int32 * float
-  6 |   | Lt of bool option
-  7 |   | Ensign
-  8 | [@@deriving serialize, deserialize]
-  Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
-  Here is an example of a case that is not matched:
-  `invalid_tag
-
-  File "variant_test.ml", line 10, characters 0-67:
-  10 | type ranks = Ranks of rank list [@@deriving serialize, deserialize]
-       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-  Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
-  Here is an example of a case that is not matched:
-  `invalid_tag
+  [
+    {
+      "Ranks": [
+        "Ensign",
+        {
+          "Commander": [
+            "riker",
+            2112,
+            3.14159265359
+          ]
+        },
+        {
+          "Lt": null
+        },
+        {
+          "Lt": false
+        },
+        {
+          "Lt": true
+        },
+        {
+          "Captain": {
+            "name": "janeway",
+            "ship": "voyager"
+          }
+        }
+      ]
+    },
+    {
+      "Ranks": [
+        "Ensign",
+        {
+          "Commander": [
+            "riker",
+            2112,
+            3.14159265359
+          ]
+        },
+        {
+          "Lt": null
+        },
+        {
+          "Lt": false
+        },
+        {
+          "Lt": true
+        },
+        {
+          "Captain": {
+            "name": "janeway",
+            "ship": "voyager"
+          }
+        }
+      ]
+    }
+  ]
   $ dune describe pp ./variant_test.ml
   [@@@ocaml.ppx.context
     {
@@ -509,7 +548,7 @@ Now we test the variants:
                                    | "Commander" -> Ok `Commander
                                    | "Lt" -> Ok `Lt
                                    | "Ensign" -> Ok `Ensign
-                                   | _ -> Ok `invalid_tag) () in
+                                   | _ -> Error `invalid_tag) () in
             (variant ctx "rank" ["Captain"; "Commander"; "Lt"; "Ensign"]) @@
               (fun ctx ->
                  let* tag = identifier ctx field_visitor
@@ -623,7 +662,7 @@ Now we test the variants:
                                  fun str ->
                                    match str with
                                    | "Ranks" -> Ok `Ranks
-                                   | _ -> Ok `invalid_tag) () in
+                                   | _ -> Error `invalid_tag) () in
             (variant ctx "ranks" ["Ranks"]) @@
               (fun ctx ->
                  let* tag = identifier ctx field_visitor