feat(dune_lang): format multi-line strings

doc/changes/added/13758.md

@@ -0,0 +1,2 @@
+- Preserve multiline block strings when formatting Dune files with language
+  version 3.25 or later (#13758, @Alizter)

src/dune_lang/format.ml

@@ -12,55 +12,131 @@ let parse lb =
   else Sexps (Parser.parse lb ~mode:Cst)
 ;;
 
-let can_be_displayed_wrapped =
-  List.for_all ~f:(fun (c : Cst.t) ->
-    match c with
-    | Atom _ | Quoted_string _ | Template _ | List (_, []) | List (_, [ _ ]) -> true
+let block_string_min_version = 3, 25
+
+let can_be_displayed_wrapped ~version =
+  List.for_all ~f:(fun (sexp : Cst.t) ->
+    match sexp with
+    | Atom _ | List (_, []) | List (_, [ _ ]) | Template _ | Quoted_string _ -> true
+    | Block_string _ -> version < block_string_min_version
     | List _ | Comment _ -> false)
 ;;
 
 let pp_simple t = Cst.abstract t |> Option.value_exn |> Ast.remove_locs |> Dune_sexp.pp
 
-let print_wrapped_list ~version x =
-  let inner = Pp.concat_map ~sep:Pp.space ~f:pp_simple x in
-  if version < (2, 8)
-  then Pp.char '(' ++ Pp.hovbox ~indent:1 inner ++ Pp.char ')'
-  else Pp.hvbox ~indent:1 (Pp.char '(' ++ inner ++ Pp.char ')')
+let escaped_block_line parts =
+  String.concat
+    ~sep:""
+    (List.map parts ~f:(function
+       | Template.Part.Text text -> Escape.escaped text
+       | Pform pform -> Template.Pform.to_string pform))
+;;
+
+let pp_block_line (kind, parts) =
+  let kind, contents =
+    match kind with
+    | Block_string.Kind.Escaped -> kind, escaped_block_line parts
+    | Raw ->
+      if
+        List.for_all parts ~f:(function
+          | Template.Part.Text text ->
+            not (String.exists text ~f:(fun char -> char = '\r' || char = '\n'))
+          | Pform _ -> false)
+      then kind, Template.Part.list_to_string parts
+      else Escaped, escaped_block_line parts
+  in
+  let prefix = "\"" ^ Block_string.Kind.delimiter kind in
+  Pp.verbatim
+    (if String.is_empty contents then prefix else Printf.sprintf "%s %s" prefix contents)
+;;
+
+let preserved_block_lines ~version lines =
+  if version < block_string_min_version
+  then None
+  else (
+    match List.rev lines with
+    | (_, [] | _, [ Template.Part.Text "" ]) :: (_ :: _ as lines) -> Some (List.rev lines)
+    | _ -> None)
+;;
+
+let sexp_ends_with_cut ~version : Cst.t -> bool = function
+  | Block_string (_, block_string) ->
+    Option.is_some (preserved_block_lines ~version block_string)
+  | Atom _ | Quoted_string _ | Template _ | List _ | Comment _ -> false
+;;
+
+let rec sexp_contains_preserved_block ~version : Cst.t -> bool = function
+  | Block_string (_, block_string) ->
+    Option.is_some (preserved_block_lines ~version block_string)
+  | List (_, sexps) -> List.exists sexps ~f:(sexp_contains_preserved_block ~version)
+  | Atom _ | Quoted_string _ | Template _ | Comment _ -> false
 ;;
 
 let pp_comment_line l = Pp.char ';' ++ Pp.verbatim l
 let pp_comment lines = Pp.vbox (Pp.concat_map ~sep:Pp.cut ~f:pp_comment_line lines)
 let pp_break attached = if attached then Pp.char ' ' else Pp.cut
 
-let pp_list_with_comments pp_sexp sexps =
-  let rec go (l : Cst.t list) =
-    match l with
-    | x :: Comment (loc, c) :: xs ->
-      let attached = Loc.on_same_line (Cst.loc x) loc in
-      pp_sexp x ++ pp_break attached ++ pp_comment c ++ Pp.cut ++ go xs
-    | Comment (_, c) :: xs -> pp_comment c ++ Pp.cut ++ go xs
-    | [ x ] -> pp_sexp x
-    | x :: xs -> pp_sexp x ++ Pp.cut ++ go xs
-    | [] -> Pp.nop
-  in
-  go sexps
-;;
-
 let rec pp_sexp ~version : Cst.t -> _ = function
-  | (Atom _ | Quoted_string _ | Template _) as sexp -> pp_simple sexp
+  | Quoted_string (_, string) -> Pp.verbatim (Escape.quoted string)
+  | Block_string (_, block_string) as sexp ->
+    (match preserved_block_lines ~version block_string with
+     | Some lines -> Pp.vbox (Pp.concat_map lines ~sep:Pp.cut ~f:pp_block_line ++ Pp.cut)
+     | None -> pp_simple sexp)
+  | (Atom _ | Template _) as sexp -> pp_simple sexp
   | List (_, sexps) ->
     Pp.vbox
       ~indent:1
-      (if can_be_displayed_wrapped sexps
+      (if can_be_displayed_wrapped ~version sexps
        then print_wrapped_list ~version sexps
        else pp_sexp_list ~version sexps)
   | Comment (_, c) -> pp_comment c
 
 and pp_sexp_list ~version sexps =
-  Pp.char '(' ++ pp_list_with_comments (pp_sexp ~version) sexps ++ Pp.char ')'
+  Pp.char '(' ++ pp_list_with_comments ~version sexps ++ Pp.char ')'
+
+and pp_list_with_comments ~version = function
+  | sexp :: Comment (loc, comment) :: sexps ->
+    let break =
+      if sexp_ends_with_cut ~version sexp
+      then Pp.nop
+      else pp_break (Loc.on_same_line (Cst.loc sexp) loc)
+    in
+    pp_sexp ~version sexp
+    ++ break
+    ++ pp_comment comment
+    ++ Pp.cut
+    ++ pp_list_with_comments ~version sexps
+  | Comment (_, comment) :: sexps ->
+    pp_comment comment ++ Pp.cut ++ pp_list_with_comments ~version sexps
+  | [ sexp ] -> pp_sexp ~version sexp
+  | sexp :: (next :: _ as sexps) ->
+    let break =
+      if sexp_ends_with_cut ~version sexp
+      then if sexp_ends_with_cut ~version next then Pp.newline else Pp.nop
+      else Pp.cut
+    in
+    pp_sexp ~version sexp ++ break ++ pp_list_with_comments ~version sexps
+  | [] -> Pp.nop
+
+and print_wrapped_list ~version sexps =
+  let inner =
+    Pp.concat_map sexps ~sep:Pp.space ~f:(fun sexp ->
+      match sexp with
+      | Quoted_string _ | Block_string _ -> pp_sexp ~version sexp
+      | List _ when sexp_contains_preserved_block ~version sexp -> pp_sexp ~version sexp
+      | Atom _ | Template _ | List _ -> pp_simple sexp
+      | Comment _ -> Code_error.raise "unexpected comment in a wrapped list" [])
+  in
+  if version < (2, 8)
+  then Pp.char '(' ++ Pp.hovbox ~indent:1 inner ++ Pp.char ')'
+  else Pp.hvbox ~indent:1 (Pp.char '(' ++ inner ++ Pp.char ')')
+;;
+
+let pp_top_sexp ~version sexp =
+  pp_sexp ~version sexp
+  ++ if sexp_ends_with_cut ~version sexp then Pp.nop else Pp.char '\n'
 ;;
 
-let pp_top_sexp ~version sexp = pp_sexp ~version sexp ++ Pp.char '\n'
 let pp_top_sexps ~version = Pp.concat_map ~sep:Pp.newline ~f:(pp_top_sexp ~version)
 
 let format_string ~version input =

src/dune_lang/import.ml

@@ -10,6 +10,8 @@ include struct
   module Parser = Parser
   module Ast = Ast
   module Template = Template
+  module Block_string = Block_string
+  module Escape = Escape
 end
 
 include struct

src/dune_lang/string_with_vars.ml

@@ -93,7 +93,7 @@ let decode_manually f =
   | Atom (loc, A s) -> literal ~quoted:false ~loc s
   | Quoted_string (loc, s) -> literal ~quoted:true ~loc s
   | List (loc, _) -> User_error.raise ~loc [ Pp.text "Unexpected list" ]
-  | Template { quoted; loc; parts } ->
+  | Template { quoted; loc; parts; _ } ->
     { quoted
     ; loc
     ; parts =

src/dune_sexp/block_string.ml

@@ -0,0 +1,58 @@
+open Import
+
+module Kind = struct
+  type t =
+    | Escaped
+    | Raw
+
+  let delimiter = function
+    | Escaped -> "\\|"
+    | Raw -> "\\>"
+  ;;
+
+  let repr =
+    Repr.variant
+      "dune-sexp-block-string-kind"
+      [ Repr.case0 "Escaped" ~test:(function
+          | Escaped -> true
+          | Raw -> false)
+      ; Repr.case0 "Raw" ~test:(function
+          | Raw -> true
+          | Escaped -> false)
+      ]
+  ;;
+end
+
+type t = (Kind.t * Template.Part.t list) list
+
+let repr = Repr.list (Repr.pair Kind.repr (Repr.list Template.Part.repr))
+
+let to_ast ~loc lines =
+  let text = Buffer.create 16 in
+  let parts = ref [] in
+  let flush_text () =
+    if Buffer.length text > 0
+    then (
+      parts := Template.Part.Text (Buffer.contents text) :: !parts;
+      Buffer.clear text)
+  in
+  let add_part = function
+    | Template.Part.Text string -> Buffer.add_string text string
+    | Pform _ as pform ->
+      flush_text ();
+      parts := pform :: !parts
+  in
+  let rec collect first = function
+    | [] -> ()
+    | (_, line) :: lines ->
+      if not first then Buffer.add_char text '\n';
+      List.iter line ~f:add_part;
+      collect false lines
+  in
+  collect true lines;
+  match !parts with
+  | [] -> Ast.Quoted_string (loc, Buffer.contents text)
+  | _ ->
+    flush_text ();
+    Ast.Template { Template.quoted = true; parts = List.rev !parts; loc }
+;;

src/dune_sexp/block_string.mli

@@ -0,0 +1,19 @@
+open Import
+
+(** Block strings as represented in the concrete syntax tree. *)
+
+module Kind : sig
+  type t =
+    | Escaped
+    | Raw
+
+  val delimiter : t -> string
+end
+
+(** The kind and template parts of each logical line. *)
+type t = (Kind.t * Template.Part.t list) list
+
+val repr : t Repr.t
+
+(** Convert a block string to its abstract representation. *)
+val to_ast : loc:Loc.t -> t -> Ast.t

src/dune_sexp/cst.ml

@@ -3,6 +3,7 @@ open Stdune
 type t =
   | Atom of Loc.t * Atom.t
   | Quoted_string of Loc.t * string
+  | Block_string of Loc.t * Block_string.t
   | Template of Template.t
   | List of Loc.t * t list
   | Comment of Loc.t * string list
@@ -11,7 +12,9 @@ let rec to_dyn =
   let open Dyn in
   function
   | Atom (_, a) -> variant "Atom" [ Atom.to_dyn a ]
-  | Quoted_string (_, s) -> variant "Quoted_string" [ string s ]
+  | Quoted_string (_, contents) -> variant "Quoted_string" [ string contents ]
+  | Block_string (_, block_string) ->
+    variant "Block_string" [ Repr.to_dyn Block_string.repr block_string ]
   | Template t -> variant "Template" [ Template.to_dyn t ]
   | List (_, l) -> variant "List" [ list to_dyn l ]
   | Comment (_, c) -> variant "Comment" [ Dyn.(list string) c ]
@@ -20,6 +23,7 @@ let rec to_dyn =
 let loc
       ( Atom (loc, _)
       | Quoted_string (loc, _)
+      | Block_string (loc, _)
       | List (loc, _)
       | Template { loc; _ }
       | Comment (loc, _) )
@@ -29,15 +33,16 @@ let loc
 
 let rec abstract : t -> Ast.t option = function
   | Atom (loc, atom) -> Some (Atom (loc, atom))
-  | Quoted_string (loc, s) -> Some (Quoted_string (loc, s))
+  | Quoted_string (loc, string) -> Some (Quoted_string (loc, string))
+  | Block_string (loc, block_string) -> Some (Block_string.to_ast ~loc block_string)
   | Template t -> Some (Template t)
   | List (loc, l) -> Some (List (loc, List.filter_map ~f:abstract l))
   | Comment _ -> None
 ;;
 
 let rec concrete : Ast.t -> t = function
   | Atom (loc, atom) -> Atom (loc, atom)
-  | Quoted_string (loc, s) -> Quoted_string (loc, s)
+  | Quoted_string (loc, string) -> Quoted_string (loc, string)
   | Template t -> Template t
   | List (loc, l) -> List (loc, List.map ~f:concrete l)
 ;;
@@ -46,7 +51,7 @@ let to_sexp c = abstract c |> Option.map ~f:Ast.remove_locs
 
 let extract_comments =
   let rec loop acc = function
-    | Atom _ | Quoted_string _ | Template _ -> acc
+    | Atom _ | Quoted_string _ | Block_string _ | Template _ -> acc
     | List (_, l) -> List.fold_left l ~init:acc ~f:loop
     | Comment (loc, comment) -> (loc, comment) :: acc
   in
@@ -58,7 +63,8 @@ let tokenize ts =
   let emit loc (token : Lexer.Token.t) = tokens := (loc, token) :: !tokens in
   let rec iter = function
     | Atom (loc, s) -> emit loc (Atom s)
-    | Quoted_string (loc, s) -> emit loc (Quoted_string s)
+    | Quoted_string (loc, string) -> emit loc (Quoted_string string)
+    | Block_string (loc, block_string) -> emit loc (Block_string block_string)
     | Template ({ loc; _ } as template) -> emit loc (Template template)
     | Comment (loc, comment) -> emit loc (Comment comment)
     | List (loc, l) ->

src/dune_sexp/cst.mli

@@ -5,6 +5,7 @@ open Stdune
 type t =
   | Atom of Loc.t * Atom.t
   | Quoted_string of Loc.t * string
+  | Block_string of Loc.t * Block_string.t
   | Template of Template.t
   | List of Loc.t * t list
   | Comment of Loc.t * string list

src/dune_sexp/dune_sexp.ml

@@ -3,11 +3,13 @@ module Atom = Atom
 module Combinators = Combinators
 module Decoder = Decoder
 module Encoder = Encoder
+module Escape = Escape
 module Syntax = Syntax
 module Versioned_file = Versioned_file
 module Versioned_file_first_line = Versioned_file_first_line
 module Cst = Cst
 module Parser = Parser
 module Conv = Conv
 module Template = Template
+module Block_string = Block_string
 include T

src/dune_sexp/lexer.mli

@@ -2,6 +2,7 @@ module Token : sig
   type t =
     | Atom of Atom.t
     | Quoted_string of string
+    | Block_string of Block_string.t
     | Lparen
     | Rparen
     | Eof