Merge pull request #96 from reasonml-labs/murphy/add-record-spreads

Support spreading in record types

.gitignore

@@ -7,6 +7,8 @@
 *.cmx
 *.cmxs
 *.cmxa
+*.cmt
+*.cmj
 
 # ocamlbuild working directory
 _build/

CONTRIBUTING.md

@@ -54,7 +54,7 @@ If you want to see what's really going on under the hood, read more:
 
 ### Inspect the Parsetree (AST)
 
-See a text representation of the tree you're really operating on, and the real results of your PPX by running `yarn run print-parse-tree-with-ppx`
+See a text representation of the tree you're really operating on, and the real results of your PPX by running `yarn run print-parse-tree-with-ppx <file name>`
 
 You'll probably get compiler errors, because that's calling a private API of bsc that isn't including dependencies. But your goal here is really just to inspect the tree.
 

bin/preview-ppx-watch.sh

@@ -7,10 +7,10 @@ if [ -z "$file_path" ]; then
 	exit 1
 fi
 
-if ! command -v watch &>/dev/null; then
-	echo "watch command not found. Please install it using Homebrew:"
-	echo "brew install watch"
+if ! command -v viddy &>/dev/null; then
+	echo "viddy command not found. Please install it using Homebrew:"
+	echo "brew install viddy"
 	exit 1
 fi
 
-/opt/homebrew/bin/watch -n 1 -c -d "./node_modules/rescript/bsc -ppx ./ppx -bs-no-builtin-ppx -reprint-source $file_path"
+/opt/homebrew/bin/viddy -n 1 -c -d "./node_modules/rescript/bsc -ppx ./ppx -bs-no-builtin-ppx -reprint-source $file_path"

ppx_src/src/BatOption.ml

@@ -1,4 +1,4 @@
 let get = function
   | None -> failwith "Expected Some. got None"
-  | ((Some v) [@explicit_arity]) -> v
-let some v = (Some v [@explicit_arity])
+  | Some v -> v
+let some v = Some v

ppx_src/src/Codecs.ml

@@ -2,10 +2,10 @@ open Ppxlib
 open Parsetree
 open Ast_helper
 open Utils
-let rec parameterizeCodecs typeArgs encoderFunc decoderFunc generatorSettings =
+let rec parameterizeCodecs typeArgs encoderFunc decoderFunc encodeDecodeFlags =
   let subEncoders, subDecoders =
     typeArgs
-    |> List.map (fun core_type -> generateCodecs generatorSettings core_type)
+    |> List.map (fun core_type -> generateCodecs encodeDecodeFlags core_type)
     |> List.split
   in
   ( (match encoderFunc with
@@ -29,199 +29,208 @@ let rec parameterizeCodecs typeArgs encoderFunc decoderFunc generatorSettings =
       |> Exp.apply ~attrs:uncurriedApplicationAttrs decoderFunc
       |> BatOption.some )
 
-and generateConstrCodecs {doEncode; doDecode} {Location.txt = identifier; loc} =
+(* The optional expressions that are returned from this function should be codec functions themselves.
+   Not bindings. The receiver will invoke them with the value when it decides to. *)
+and generateCodecsFromTypeConstructor {doEncode; doDecode}
+    {Location.txt = identifier; loc} =
   let open Longident in
   match identifier with
-  | ((Lident "string") [@explicit_arity]) ->
+  | Lident "string" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.stringToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.stringToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.stringFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.stringFromJson]
       | false -> None )
-  | ((Lident "int") [@explicit_arity]) ->
+  | Lident "int" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.intToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.intToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.intFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.intFromJson]
       | false -> None )
-  | ((Lident "int64") [@explicit_arity]) ->
+  | Lident "int64" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.int64ToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.int64ToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.int64FromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.int64FromJson]
       | false -> None )
-  | ((Lident "float") [@explicit_arity]) ->
+  | Lident "float" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.floatToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.floatToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.floatFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.floatFromJson]
       | false -> None )
-  | ((Lident "bool") [@explicit_arity]) ->
+  | Lident "bool" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.boolToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.boolToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.boolFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.boolFromJson]
       | false -> None )
-  | ((Lident "unit") [@explicit_arity]) ->
+  | Lident "unit" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.unitToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.unitToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.unitFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.unitFromJson]
       | false -> None )
-  | ((Lident "array") [@explicit_arity]) ->
+  | Lident "array" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.arrayToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.arrayToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.arrayFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.arrayFromJson]
       | false -> None )
-  | ((Lident "list") [@explicit_arity]) ->
+  | Lident "list" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.listToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.listToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.listFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.listFromJson]
       | false -> None )
-  | ((Lident "option") [@explicit_arity]) ->
+  | Lident "option" ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.optionToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.optionToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.optionFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.optionFromJson]
       | false -> None )
-  | ((Ldot
-       ( ((Ldot (((Lident "Belt") [@explicit_arity]), "Result"))
-         [@explicit_arity]),
-         "t" ))
-  [@explicit_arity]) ->
+  | Ldot (Ldot (Lident "Belt", "Result"), "t") ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.resultToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.resultToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.resultFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.resultFromJson]
       | false -> None )
-  | ((Ldot
-       ( ((Ldot (((Lident "Js") [@explicit_arity]), "Dict")) [@explicit_arity]),
-         "t" ))
-  [@explicit_arity]) ->
+  | Ldot (Ldot (Lident "Js", "Dict"), "t") ->
     ( (match doEncode with
-      | true -> Some [%expr Decco.dictToJson] [@explicit_arity]
+      | true -> Some [%expr Decco.dictToJson]
       | false -> None),
       match doDecode with
-      | true -> Some [%expr Decco.dictFromJson] [@explicit_arity]
+      | true -> Some [%expr Decco.dictFromJson]
       | false -> None )
-  | ((Ldot
-       ( ((Ldot (((Lident "Js") [@explicit_arity]), "Json")) [@explicit_arity]),
-         "t" ))
-  [@explicit_arity]) ->
+  | Ldot (Ldot (Lident "Js", "Json"), "t") ->
     ( (match doEncode with
       | true ->
         Some
           (Utils.wrapFunctionExpressionForUncurrying ~arity:1
              [%expr fun v -> v])
-        [@explicit_arity]
       | false -> None),
       match doDecode with
       | true ->
         Some
           (Utils.wrapFunctionExpressionForUncurrying ~arity:1
-             [%expr fun v -> (Belt.Result.Ok v [@explicit_arity])])
-        [@explicit_arity]
+             [%expr fun v -> Belt.Result.Ok v])
       | false -> None )
-  | ((Lident s) [@explicit_arity]) ->
+  | Lident s ->
+    (* Lident is such an abstract name. This is when we're handling a reference to something
+       that isn't some special syntactic construct. For example, in type blah = string, the
+       'string' part is a Lident. Same thing if we had `type blah = user`. The `user` part
+        would be a Lident. *)
     ( (match doEncode with
-      | true ->
-        Some (makeIdentExpr (s ^ Utils.encoderFuncSuffix)) [@explicit_arity]
+      | true -> Some (makeIdentExpr (s ^ Utils.encoderFuncSuffix))
       | false -> None),
       match doDecode with
-      | true ->
-        Some (makeIdentExpr (s ^ Utils.decoderFuncSuffix)) [@explicit_arity]
+      | true -> Some (makeIdentExpr (s ^ Utils.decoderFuncSuffix))
       | false -> None )
-  | ((Ldot (left, right)) [@explicit_arity]) ->
+  | Ldot (left, right) ->
     ( (match doEncode with
       | true ->
         Some
-          (Exp.ident
-             (mknoloc
-                (Ldot (left, right ^ Utils.encoderFuncSuffix) [@explicit_arity])))
-        [@explicit_arity]
+          (Exp.ident (mknoloc (Ldot (left, right ^ Utils.encoderFuncSuffix))))
       | false -> None),
       match doDecode with
       | true ->
         Some
-          (Exp.ident
-             (mknoloc
-                (Ldot (left, right ^ Utils.decoderFuncSuffix) [@explicit_arity])))
-        [@explicit_arity]
+          (Exp.ident (mknoloc (Ldot (left, right ^ Utils.decoderFuncSuffix))))
       | false -> None )
-  | ((Lapply (_, _)) [@explicit_arity]) ->
-    fail loc "Lapply syntax not yet handled by decco"
+  | Lapply (_, _) -> fail loc "Lapply syntax not yet handled by decco"
+
+(* This gets called when a type declaration has a @decco.codec decorator with
+   custom functions. *)
+and generateCustomCodecs attribute {doEncode; doDecode} =
+  let expr = Utils.getExpressionFromPayload attribute in
+  ( (match doEncode with
+    | true ->
+      Some
+        [%expr
+          let e, _ = [%e expr] in
+          e]
+    | false -> None),
+    match doDecode with
+    | true ->
+      Some
+        [%expr
+          let _, d = [%e expr] in
+          d]
+    | false -> None )
 
-and generateCodecs ({doEncode; doDecode} as generatorSettings)
+(* This is a recursive function that operates on core types to make generators. core types
+   might not be what you think, like strings and ints. Core types as far as the AST is
+   concerned are, I think, basic elements of the parse tree. So this is going to be called
+   not only with type declarations like 'type foo = string', but also with smaller parts of
+   that declaration, like just 'string' *)
+and generateCodecs ({doEncode; doDecode} as encodeDecodeFlags)
     {ptyp_desc; ptyp_loc; ptyp_attributes} =
   match ptyp_desc with
   | Ptyp_any -> fail ptyp_loc "Can't generate codecs for `any` type"
-  | ((Ptyp_arrow (_, _, _)) [@explicit_arity]) ->
+  | Ptyp_arrow (_, _, _) ->
     fail ptyp_loc "Can't generate codecs for function type"
   | Ptyp_package _ -> fail ptyp_loc "Can't generate codecs for module type"
-  | ((Ptyp_tuple types) [@explicit_arity]) -> (
-    let compositeCodecs = List.map (generateCodecs generatorSettings) types in
+  | Ptyp_tuple types -> (
+    let compositeCodecs = List.map (generateCodecs encodeDecodeFlags) types in
     ( (match doEncode with
       | true ->
         Some
           (compositeCodecs
           |> List.map (fun (e, _) -> BatOption.get e)
           |> Tuple.generateEncoder)
-        [@explicit_arity]
       | false -> None),
       match doDecode with
       | true ->
         Some
           (compositeCodecs
           |> List.map (fun (_, d) -> BatOption.get d)
           |> Tuple.generateDecoder)
-        [@explicit_arity]
       | false -> None ))
-  | ((Ptyp_var s) [@explicit_arity]) ->
+  | Ptyp_var s ->
+    (* In this branch we're handling a type variable, like 'a in option<'a> *)
     ( (match doEncode with
-      | true -> Some (makeIdentExpr (encoderVarPrefix ^ s)) [@explicit_arity]
+      | true -> Some (makeIdentExpr (encoderVarPrefix ^ s))
       | false -> None),
       match doDecode with
-      | true -> Some (makeIdentExpr (decoderVarPrefix ^ s)) [@explicit_arity]
+      | true -> Some (makeIdentExpr (decoderVarPrefix ^ s))
       | false -> None )
-  | ((Ptyp_constr (constr, typeArgs)) [@explicit_arity]) -> (
+  | Ptyp_constr (constr, typeArgs) -> (
+    (* Here we're handling a type constructor. This might be a type constructor with
+       a name, like `type blah = string`, or it might be a nameless type constructor,
+       like `string`, or `pizza`. When you read "constructor" here, don't think
+       of only a type definition, but think of any time a type is mentioned at all,
+       syntactically, mentioning a type is "constructing" that type. *)
     let customCodec = getAttributeByName ptyp_attributes "decco.codec" in
     let encode, decode =
       match customCodec with
-      | ((Ok None) [@explicit_arity]) ->
-        generateConstrCodecs generatorSettings constr
-      | ((Ok ((Some attribute) [@explicit_arity])) [@explicit_arity]) -> (
-        let expr = getExpressionFromPayload attribute in
-        ( (match doEncode with
-          | true ->
-            Some
-              [%expr
-                let e, _ = [%e expr] in
-                e]
-            [@explicit_arity]
-          | false -> None),
-          match doDecode with
-          | true ->
-            Some
-              [%expr
-                let _, d = [%e expr] in
-                d]
-            [@explicit_arity]
-          | false -> None ))
-      | ((Error s) [@explicit_arity]) -> fail ptyp_loc s
+      (* Shortcut! We're handling a type where the user has specified their own
+         codec functions. Just return their settings instead of generating more
+         of our own. *)
+      | Ok (Some attribute) -> generateCustomCodecs attribute encodeDecodeFlags
+      (* Hey! 👉 This is the most common branch. We're going to go generate codecs here based
+         on the type constructor we're handling 👈 *)
+      | Ok None -> generateCodecsFromTypeConstructor encodeDecodeFlags constr
+      (* Arg, we couldn't even see if there was a custom codec to handle because
+         of some unexpected error. *)
+      | Error s -> fail ptyp_loc s
     in
     match List.length typeArgs = 0 with
-    | true -> (encode, decode)
-    | false -> parameterizeCodecs typeArgs encode decode generatorSettings)
+    | true ->
+      (* We've got a simple type here with no parameters! Just return the functions
+         generated above *)
+      (encode, decode)
+    | false ->
+      (* Looks like there are some params for this type. Let's handle
+         those now. *)
+      parameterizeCodecs typeArgs encode decode encodeDecodeFlags)
   | _ -> fail ptyp_loc "This syntax is not yet handled by decco"