v0.17~preview.129.11+135

Author: public-release

runtime/expectation.ml

@@ -49,42 +49,38 @@ module Definitions = struct
   end
 
   module Behavior = struct
-    (** A [('output, 'behavior_type) behavior] describes how to handle a test node when
-        running tests and writing corrections.
-
-        ['output] determines the type of payload used when running tests and writing
-        corrections at that node; it is [Payload.String.t] for [expect_exact] nodes and
-        [Payload.Pretty.t] for all other nodes.
+    (** A ['behavior_type t] describes how to handle a test node when running tests
+        and writing corrections.
 
         ['behavior_type] determines the types of rewrites that are possible at this node.
         It is either [`Expect] (indicating that both corrections for unexpected output and
         rewrites for unreachability are possible) or [`Unreachable] (indicating that only
         corrections for unexpected output are possible).
     *)
-    type (_, _) t =
+    type _ t =
       | Expect :
-          { payload : 'output Payload.t
+          { payload : Output.Payload.t
           ; on_unreachable : On_unreachable.t
           ; reachability : Expect_reachability.t
           }
-          -> ('output, [ `Expect ]) t
+          -> [ `Expect ] t
       | Unreachable :
           { reachability_of_corrected : Expect_reachability.t
               (** The reachability of the node inserted if this unreachable node is
               unexpectedly reached *)
           }
-          -> (Payload.Pretty.Contents.t, [ `Unreachable ]) t
+          -> [ `Unreachable ] t
   end
 
-  (** A [('output, 'behavior_type) t] carries information about how to run tests for a
+  (** A [('behavior_type) t] carries information about how to run tests for a
       specific expect node and rewrite it in the source file if there are corrections. The
-      ['output] and ['behavior_type] type variables have the same meanings as in
-      [('output, 'behavior_type) behavior].
+      ['behavior_type] type variable has the same meanings as in
+      ['behavior_type Behavior.t].
   *)
-  type ('output, 'behavior_type) t =
+  type 'behavior_type t =
     { position : Insert_loc.t
-    ; behavior : ('output, 'behavior_type) Behavior.t
-    ; payload_type : (module Payload.Type with type Contents.t = 'output)
+    ; behavior : 'behavior_type Behavior.t
+    ; payload_type : Output.Type.t
     ; on_incorrect_output : String_node_format.Shape.t
         (** The name and syntax style of the extension point or attribute used to write
         corrections when receiving "incorrect" output for this test node. For each [t],
@@ -111,66 +107,57 @@ module type Expectation = sig
       include Insert_loc
     end
 
-    val loc : t -> Compact_loc.t
+    val loc : Insert_loc.t -> Compact_loc.t
   end
 
-  val with_behavior
-    :  ('output, 'old_behavior) t
-    -> ('output, 'new_behavior) Behavior.t
-    -> ('output, 'new_behavior) t
+  val with_behavior : 'old_behavior t -> 'new_behavior Behavior.t -> 'new_behavior t
 
   (** [formatter ~expect_node_formatting t] returns the [Output.Formatter.t] that formats
       test output according to the type ([exact] or [pretty]) of [t], using information
       about the location and payload of [t] for formatting. *)
   val formatter
     :  expect_node_formatting:Expect_node_formatting.t
-    -> (_, _) t
+    -> _ t
     -> Output.Formatter.t
 
-  val loc : _ t -> Compact_loc.t
-
   (** [[%expect _]] *)
   val expect
-    :  payload_loc:Compact_loc.t option
-    -> string Payload.t
-    -> Compact_loc.t
-    -> (Payload.Pretty.Contents.t, [ `Expect ]) t
+    :  formatting_flexibility:Expect_node_formatting.Flexibility.t
+    -> node_loc:Compact_loc.t
+    -> located_payload:(Output.Payload.t * Compact_loc.t) option
+    -> [ `Expect ] t
 
   (** [[%expect_exact _]] *)
   val expect_exact
-    :  payload_loc:Compact_loc.t option
-    -> string Payload.t
-    -> Compact_loc.t
-    -> (Payload.Exact.Contents.t, [ `Expect ]) t
+    :  formatting_flexibility:Expect_node_formatting.Flexibility.t
+    -> node_loc:Compact_loc.t
+    -> located_payload:(Output.Payload.t * Compact_loc.t) option
+    -> [ `Expect ] t
 
   (** [[%expect.unreachable]] *)
-  val expect_unreachable
-    :  Compact_loc.t
-    -> (Payload.Pretty.Contents.t, [ `Unreachable ]) t
+  val expect_unreachable : node_loc:Compact_loc.t -> [ `Unreachable ] t
 
   (** [[@@expect.uncaught_exn _]] *)
   val expect_uncaught_exn
-    :  payload_loc:Compact_loc.t option
-    -> string Payload.t
-    -> Compact_loc.t
-    -> (Payload.Pretty.Contents.t, [ `Expect ]) t
+    :  formatting_flexibility:Expect_node_formatting.Flexibility.t
+    -> node_loc:Compact_loc.t
+    -> located_payload:(Output.Payload.t * Compact_loc.t) option
+    -> [ `Expect ] t
 
   (** Runtime representation of the implicit [[%expect {||}]] at the end of every expect
       test. *)
-  val expect_trailing : Virtual_loc.t -> (Payload.Pretty.Contents.t, [ `Expect ]) t
+  val expect_trailing : insert_loc:Virtual_loc.t -> [ `Expect ] t
 
   (** Runtime representation of the assertion that a test does not produce uncaught
       exceptions, which a user implicitly makes by omitting an [[@@expect.uncaught_exn _]]
       attribute. *)
-  val expect_no_uncaught_exn
-    :  Virtual_loc.t
-    -> (Payload.Pretty.Contents.t, [ `Unreachable ]) t
+  val expect_no_uncaught_exn : insert_loc:Virtual_loc.t -> [ `Unreachable ] t
 
   module For_apply_style : sig
     type format_payload :=
       expect_node_formatting:Expect_node_formatting.t
       -> payload_loc:Compact_loc.t
-      -> loc:Compact_loc.t
+      -> node_loc:Compact_loc.t
       -> String_node_format.Delimiter.t
       -> string
       -> string option

runtime/expectation_intf.ml

@@ -45,6 +45,18 @@ module Payload = struct
     }
 
   let default contents = { contents; tag = String_node_format.Delimiter.default }
+
+  let to_source_code_string { contents; tag } =
+    let escape_lines test_output =
+      test_output
+      |> String.split ~on:'\n'
+      |> List.map ~f:String.escaped
+      |> String.concat ~sep:"\n"
+    in
+    match tag with
+    | T (Tag tag) -> Printf.sprintf "{%s|%s|%s}" tag contents tag
+    | T Quote -> Printf.sprintf {|"%s"|} (escape_lines contents)
+  ;;
 end
 
 let reconcile ~expected_output ~test_output : Test_result.t =
@@ -53,58 +65,57 @@ let reconcile ~expected_output ~test_output : Test_result.t =
 
 let fail error_output : Test_result.t = Fail error_output
 
+let fix_delimiter_conflicts
+  (type handedness)
+  ~contents
+  ~(delimiter : handedness String_node_format.Delimiter.unpacked)
+  : handedness String_node_format.Delimiter.unpacked
+  =
+  let rec fix_tag_conflicts ~contents ~tag =
+    let tag_conflicts_with fstr =
+      String.is_substring ~substring:(Printf.sprintf fstr tag) contents
+    in
+    if tag_conflicts_with "{%s|" || tag_conflicts_with "|%s}"
+    then fix_tag_conflicts ~contents ~tag:(tag ^ "xxx")
+    else tag
+  in
+  match delimiter with
+  | Quote -> Quote
+  | Tag tag -> Tag (fix_tag_conflicts ~contents ~tag)
+;;
+
+let to_formatted_payload ~tag:(T delimiter : String_node_format.Delimiter.t) contents
+  : Payload.t
+  =
+  { contents; tag = T (fix_delimiter_conflicts ~contents ~delimiter) }
+;;
+
 let to_source_code_string
   ~(expect_node_formatting : Expect_node_formatting.t)
-  ~(node_shape : String_node_format.Shape.t option)
+  ~node_shape:(T shape : String_node_format.Shape.t)
   ~(tag : String_node_format.Delimiter.t)
   contents
   =
-  let rec fix_tag_conflicts test_output tag =
-    let bad_tag tag fstr =
-      String.is_substring ~substring:(Printf.sprintf fstr tag) test_output
-    in
-    if bad_tag tag "{%s|" || bad_tag tag "|%s}"
-    then fix_tag_conflicts test_output (tag ^ "xxx")
-    else tag
-  in
-  let escape_lines test_output =
-    test_output
-    |> String.split ~on:'\n'
-    |> List.map ~f:String.escaped
-    |> String.concat ~sep:"\n"
+  let delimiter =
+    fix_delimiter_conflicts
+      ~contents
+      ~delimiter:(String_node_format.Delimiter.handed tag shape.hand)
   in
-  let tag, extension =
-    match node_shape with
-    | None -> tag, None
-    | Some (T shape) ->
-      let delimiter = String_node_format.Delimiter.handed tag shape.hand in
-      T delimiter, Some (String_node_format.T { shape; delimiter })
-  in
-  let payload_string =
-    lazy
-      (match tag with
-       | T (Tag tag) ->
-         let tag = fix_tag_conflicts contents tag in
-         Printf.sprintf "{%s|%s|%s}" tag contents tag
-       | T Quote -> Printf.sprintf {|"%s"|} (escape_lines contents))
-  in
-  match extension with
-  | None -> force payload_string
-  | Some (T { shape; delimiter }) ->
-    (match shape.hand with
-     | Longhand ->
-       let prefix =
-         match shape.kind with
-         | Extension -> expect_node_formatting.extension_sigil
-         | Attribute -> expect_node_formatting.attribute_sigil
-       in
-       Printf.sprintf "[%s%s %s]" prefix shape.name (force payload_string)
-     | Shorthand ->
-       let prefix =
-         match shape.kind with
-         | Extension -> expect_node_formatting.extension_sigil
-       in
-       (match delimiter with
-        | Tag "" -> Printf.sprintf "{%s%s|%s|}" prefix shape.name contents
-        | Tag tag -> Printf.sprintf "{%s%s %s|%s|%s}" prefix shape.name tag contents tag))
+  let payload : Payload.t = { contents; tag = T delimiter } in
+  match shape.hand with
+  | Longhand ->
+    let prefix =
+      match shape.kind with
+      | Extension -> expect_node_formatting.extension_sigil
+      | Attribute -> expect_node_formatting.attribute_sigil
+    in
+    Printf.sprintf "[%s%s %s]" prefix shape.name (Payload.to_source_code_string payload)
+  | Shorthand ->
+    let prefix =
+      match shape.kind with
+      | Extension -> expect_node_formatting.extension_sigil
+    in
+    (match delimiter with
+     | Tag "" -> Printf.sprintf "{%s%s|%s|}" prefix shape.name contents
+     | Tag tag -> Printf.sprintf "{%s%s %s|%s|%s}" prefix shape.name tag contents tag)
 ;;

runtime/output.ml

@@ -55,6 +55,9 @@ module Payload : sig
 
   (** Add the default tags to a payload. *)
   val default : string -> t
+
+  (** The source-code representation of a payload. *)
+  val to_source_code_string : t -> string
 end
 
 (** Returns [Pass] if [test_output] is considered to match [expected_output]; otherwise
@@ -66,15 +69,23 @@ val reconcile : expected_output:string -> test_output:Formatted.t -> Test_result
     "reconciled" output. *)
 val fail : Formatted.t -> Test_result.t
 
-(** The source-code representation of a payload.
+(** The new payload represented by a reconciled expectation.
+
+    If [tag] is not compatible with the new payload contents (for example, the tag
+    represents a [{x| delimited string |x}] and the new contents contain ["|x}"]), the tag
+    is adjusted so the resulting payload can be parsed.
+*)
+val to_formatted_payload : tag:String_node_format.Delimiter.t -> Reconciled.t -> Payload.t
+
+(** The source-code representation of a reconciled expect node.
 
-    If [node_shape] is [Some shape], then the produced string is an extension point or
-    attribute containing a payload with the reconciled contents, using the name and syntax
-    specified in [shape]. If [node_shape] is [None], the produced string is a string
-    literal. *)
+    If [tag] is not compatible with the new payload contents (for example, the tag
+    represents a [{x| delimited string |x}] and the new contents contain ["|x}"]), the tag
+    is adjusted so the resulting payload can be parsed.
+*)
 val to_source_code_string
   :  expect_node_formatting:Expect_node_formatting.t
-  -> node_shape:String_node_format.Shape.t option
+  -> node_shape:String_node_format.Shape.t
   -> tag:String_node_format.Delimiter.t
   -> Reconciled.t
   -> string