Sync up outcome printer (#70)

No new changes really.
Tracking rescript-lang/syntax@9907b82

src/rescript-editor-support/vendor/res_outcome_printer/res_comment.ml

@@ -57,17 +57,16 @@ let trimSpaces s =
   let len = String.length s in
   if len = 0 then s
   else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' then (
-    let b = Bytes.of_string s in
     let i = ref 0 in
-    while !i < len && (Bytes.unsafe_get b !i) = ' ' do
+    while !i < len && (String.unsafe_get s !i) = ' ' do
       incr i
     done;
     let j = ref (len - 1) in
-    while !j >= !i && (Bytes.unsafe_get b !j) = ' ' do
+    while !j >= !i && (String.unsafe_get s !j) = ' ' do
       decr j
     done;
     if !j >= !i then
-      (Bytes.sub [@doesNotRaise]) b !i (!j - !i + 1) |> Bytes.to_string
+      (String.sub [@doesNotRaise]) s !i (!j - !i + 1)
     else
       ""
   ) else s

src/rescript-editor-support/vendor/res_outcome_printer/res_doc.ml

@@ -28,7 +28,20 @@ let hardLine = LineBreak Hard
 let softLine = LineBreak Soft
 let literalLine = LineBreak Literal
 let text s = Text s
-let concat l = Concat l
+
+(* Optimization. We eagerly collapse and reduce whatever allocation we can *)
+let rec _concat acc l =
+  match l with
+  | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest
+  | Nil :: rest -> _concat acc rest
+  | Concat l2 :: rest -> _concat (_concat acc rest) l2 (* notice the order here *)
+  | x :: rest ->
+    let rest1 = _concat acc rest in
+    if rest1 == rest then l else x :: rest1
+  | [] -> acc
+
+let concat l = Concat(_concat [] l)
+
 let indent d = Indent d
 let ifBreaks t f = IfBreaks {yes = t; no = f}
 let lineSuffix d = LineSuffix d
@@ -118,39 +131,53 @@ let join ~sep docs =
     | [x] -> List.rev (x::acc)
     | x::xs -> loop (sep::x::acc) sep xs
   in
-  Concat(loop [] sep docs)
+  concat(loop [] sep docs)
+
+let fits w stack =
+  let width = ref w in
+  let result = ref None in
 
-let rec fits w doc = match doc with
-  | _ when w < 0 -> false
-  | [] -> true
-  | (_ind, _mode, Text txt)::rest -> fits (w - String.length txt) rest
-  | (ind, mode, Indent doc)::rest -> fits w ((ind + 2, mode, doc)::rest)
-  | (_ind, Flat, LineBreak break)::rest ->
-      if break = Hard || break = Literal then true
-      else
-        let w = if break = Classic then w - 1 else w in
-        fits w rest
-  | (_ind, _mode, Nil)::rest -> fits w rest
-  | (_ind, Break, LineBreak _break)::_rest -> true
-  | (ind, mode, Group {shouldBreak = forceBreak; doc})::rest ->
-    let mode = if forceBreak then Break else mode in
-    fits w ((ind, mode, doc)::rest)
-  | (ind, mode, IfBreaks {yes = breakDoc; no = flatDoc})::rest ->
-      if mode = Break then
-        fits w ((ind, mode, breakDoc)::rest)
-      else
-        fits w ((ind, mode, flatDoc)::rest)
-  | (ind, mode, Concat docs)::rest ->
-    let ops = List.map (fun doc -> (ind, mode, doc)) docs in
-    fits w (List.append ops rest)
-  (* | (_ind, _mode, Cursor)::rest -> fits w rest *)
-  | (_ind, _mode, LineSuffix _)::rest -> fits w rest
-  | (_ind, _mode, BreakParent)::rest -> fits w rest
-  | (ind, mode, CustomLayout (hd::_))::rest ->
-    (* TODO: if we have nested custom layouts, what we should do here? *)
-    fits w ((ind, mode, hd)::rest)
-  | (_ind, _mode, CustomLayout _)::rest ->
-    fits w rest
+  let rec calculate indent mode doc =
+    match mode, doc with
+    | _ when result.contents != None -> ()
+    | _ when width.contents < 0 -> result := Some false
+    | _, Nil
+    | _, LineSuffix _
+    | _, BreakParent -> ()
+    | _, Text txt -> width := width.contents - (String.length txt)
+    | _, Indent doc -> calculate (indent + 2) mode doc
+    | Flat, LineBreak Hard
+    | Flat, LineBreak Literal -> result := Some true
+    | Flat, LineBreak Classic -> width := width.contents - 1
+    | Flat, LineBreak Soft -> ()
+    | Break, LineBreak _ -> result := Some true
+    | _, Group {shouldBreak = true; doc} -> calculate indent Break doc
+    | _, Group {doc} -> calculate indent mode doc
+    | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc
+    | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc
+    | _, Concat docs -> calculateConcat indent mode docs
+    | _, CustomLayout (hd::_) ->
+      (* TODO: if we have nested custom layouts, what we should do here? *)
+        calculate indent mode hd
+    | _, CustomLayout [] -> ()
+  and calculateConcat indent mode docs =
+    if result.contents == None then (
+      match docs with
+      | [] -> ()
+      | doc::rest ->
+        calculate indent mode doc;
+        calculateConcat indent mode rest
+    )
+  in
+  let rec calculateAll stack =
+    match result.contents, stack with
+    | Some r, _ -> r
+    | None, [] -> !width >= 0
+    | None, (indent, mode, doc)::rest ->
+      calculate indent mode doc;
+      calculateAll rest
+  in
+  calculateAll stack
 
 let toString ~width doc =
   let doc = propagateForcedBreaks doc in
@@ -226,7 +253,7 @@ let toString ~width doc =
         process ~pos:0 [] (List.rev suffices)
       end
   in
-  process ~pos:0 [] [0, Flat, doc];
+  process ~pos:0 [] [(0, Flat, doc)];
   MiniBuffer.contents buffer
 
 

src/rescript-editor-support/vendor/res_outcome_printer/res_doc.mli

@@ -36,7 +36,7 @@ val question: t
 val tilde: t
 val equal: t
 val trailingComma: t
-val doubleQuote: t
+val doubleQuote: t [@@live]
 
 (*
  * `willBreak doc` checks whether `doc` contains forced line breaks.

src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.ml

@@ -9,7 +9,7 @@ let create n =
  let s = (Bytes.create [@doesNotRaise]) n in
  {buffer = s; position = 0; length = n}
 
-let contents b = Bytes.sub_string b.buffer 0 b.position
+let contents b = (Bytes.sub_string [@doesNotRaise]) b.buffer 0 b.position
 
 (* Can't be called directly, don't add to the interface *)
 let resize_internal b more =

src/rescript-editor-support/vendor/res_outcome_printer/res_outcome_printer.ml

@@ -29,7 +29,7 @@ let classifyIdentContent ~allowUident txt =
       let c = String.unsafe_get txt i in
       if i == 0 && not (
         (allowUident && (c >= 'A' && c <= 'Z')) ||
-        (c >= 'a' && c <= 'z') || c = '_' || (c >= '0' && c <= '9')) then
+        (c >= 'a' && c <= 'z') || c = '_') then
         ExoticIdent
       else if not (
            (c >= 'a' && c <= 'z')
@@ -56,6 +56,15 @@ let printIdentLike ~allowUident txt =
     ]
   | NormalIdent -> Doc.text txt
 
+let printPolyVarIdent txt =
+  match classifyIdentContent ~allowUident:true txt with
+  | ExoticIdent -> Doc.concat [
+     Doc.text "\"";
+     Doc.text txt;
+     Doc.text"\""
+   ]
+  | NormalIdent -> Doc.text txt
+
   (* ReScript doesn't have parenthesized identifiers.
    * We don't support custom operators. *)
    let parenthesized_ident _name = true
@@ -301,6 +310,8 @@ let printIdentLike ~allowUident txt =
            Doc.join ~sep:Doc.space (
              List.map (fun var -> Doc.text ("'" ^ var)) vars
            );
+           Doc.dot;
+           Doc.space;
            printOutTypeDoc outType;
          ]
        )
@@ -376,7 +387,7 @@ let printIdentLike ~allowUident txt =
              Doc.group (
                Doc.concat [
                  Doc.text "#";
-                 printIdentLike ~allowUident:true name;
+                 printPolyVarIdent name;
                  match types with
                  | [] -> Doc.nil
                  | types ->
@@ -1023,7 +1034,7 @@ let printIdentLike ~allowUident txt =
            Doc.rparen;
          ]
        )
-     (* Not supported by NapkinScript *)
+     (* Not supported by ReScript *)
      | Oval_variant _ -> Doc.nil
 
    let printOutExceptionDoc exc outValue =
@@ -1130,7 +1141,7 @@ let printIdentLike ~allowUident txt =
 
 
 
-(* Not supported in Napkin *)
+(* Not supported in ReScript *)
 (* Oprint.out_class_type *)
    let setup  = lazy begin
     Oprint.out_value := printOutValue;