Strip tilde prefixes from WordTildePrefix

dune-project

@@ -30,8 +30,8 @@
   (ocaml                (>= "4.04"))
   (odoc                 :with-doc)
    ppx_deriving_yojson
-  (qcheck               (and :with-test (>= "0.9")))
-  (qcheck-alcotest      (and :with-test (>= "0.9")))
+  (qcheck               (and :with-test (>= "0.18")))
+  (qcheck-alcotest      (and :with-test (>= "0.18")))
   (visitors             (>= "20200207"))
   (yojson               (>= "1.6.0"))))
 

morbig.opam

@@ -26,8 +26,8 @@ depends: [
   "ocaml" {>= "4.04"}
   "odoc" {with-doc}
   "ppx_deriving_yojson"
-  "qcheck" {with-test & >= "0.9"}
-  "qcheck-alcotest" {with-test & >= "0.9"}
+  "qcheck" {with-test & >= "0.18"}
+  "qcheck-alcotest" {with-test & >= "0.18"}
   "visitors" {>= "20200207"}
   "yojson" {>= "1.6.0"}
 ]

src/CST_derivings_generator.ml

@@ -38,6 +38,11 @@ let placeholders_content =
       intro_derivers = "[@@deriving yojson]" ;
       cst_derivers = "[@@deriving yojson]" }
 
+  | "printers" ->
+    { prelude = "" ;
+      intro_derivers = "[@@deriving show {with_path=false}]" ;
+      cst_derivers = "[@@deriving show {with_path=false}]" }
+
   | "visitors" ->
     {
       prelude = {|

src/dune

@@ -32,12 +32,20 @@
    %{targets}
    (run ./CST_derivings_generator.exe visitors))))
 
+(rule
+ (targets CSTPrinters.ml)
+ (deps CST.mli)
+ (action
+  (with-stdout-to
+   %{targets}
+   (run ./CST_derivings_generator.exe printers))))
+
 (library
  (name morbig)
  (public_name morbig)
  (libraries str menhirLib ppx_deriving_yojson.runtime visitors.runtime)
  (preprocess
-  (pps ppx_deriving_yojson visitors.ppx))
+  (pps ppx_deriving_yojson visitors.ppx ppx_deriving.std))
  (flags :standard -w -3) ; FIXME: remove this when Yojson and its PPX are fixed.
  (modules :standard \ morbigDriver CST_derivings_generator)
  (modules_without_implementation CST))

src/extPervasives.ml

@@ -94,10 +94,16 @@ let string_cut_at k s = String.(
 
 exception InvalidSuffix of string * string
 
+(** [string_split k s] cuts the string [s] in two, returning a pair of strings
+    consisting of the [k] first elements of [s] and the rest. Raises [Failure
+    "string_split"] if [s] does not have length at least [k]. *)
 let string_split k s =
   let n = String.length s in
   let k = min k n in
-  try String.sub s 0 k, String.sub s k (n - k) with _ -> assert false
+  try
+    (String.sub s 0 k, String.sub s k (n - k))
+  with
+    _ -> failwith "string_split"
 
 let string_remove_suffix suffix s = String.(
     let k = length s - length suffix in
@@ -281,3 +287,31 @@ let lines s =
 
 let string_last_line s =
   lines s |> list_last
+
+module List = struct
+  include List
+
+  (** Returns the “foot” of the list, that is the last element. Linear in the
+      size of the list. Raises [Failure "ft"] if the list is empty. *)
+  let rec ft = function
+    | [] -> failwith "ft"
+    | [e] -> e
+    | _ :: t -> ft t
+
+  (** Returns the “body” of the list, that is the list without its last element.
+      Linear in the size of the list. Raises [Failure "bd"] if the list is
+      empty. *)
+  let bd l =
+    let rec bd acc = function
+      | [] -> failwith "bd"
+      | [_] -> rev acc
+      | h :: t -> bd (h :: acc) t
+    in
+    bd [] l
+
+  (** Returns the “core” of the list, that is the list without its first and
+      last elements. Linear in the size of the list. Raises [Failure "cr"] if
+      the list does not have at least two elements. *)
+  let cr l =
+    try tl (bd l) with Failure _ -> failwith "cr"
+end

src/tildePrefix.ml

@@ -9,6 +9,8 @@
 (*  the POSIX standard. Please refer to the file COPYING for details.     *)
 (**************************************************************************)
 
+open ExtPervasives
+
 (*specification
 
   A "tilde-prefix" consists of an unquoted <tilde> character at the
@@ -37,25 +39,109 @@
 *)
 open CST
 
-let find_login s =
-  match String.split_on_char '/' s with
-  | login :: rem -> [WordTildePrefix login; WordLiteral (String.concat "/" rem)]
-  | _ -> assert false (* Because there is slash, or not. *)
-
-let rec make_tilde_prefix_explicit rhs_assignment = function
-  | (WordLiteral s) as cst when s <> "" ->
-    if s.[0] = '~' then (
-      if rhs_assignment then
-        let s = String.split_on_char ':' s in
-        List.(flatten (map find_login s))
-      else
-        find_login s
-    ) else [cst]
-  | WordAssignmentWord (name, Word (s, csts)) ->
-    let csts = recognize ~rhs_assignment:true csts in
-    [WordAssignmentWord (name, Word (s, csts))]
-  | cst ->
-    [cst]
-
-and recognize ?(rhs_assignment=false) csts =
-  List.(flatten (map (make_tilde_prefix_explicit rhs_assignment) csts))
+(** Tests whether the given string starts with a tilde character. *)
+let starts_with_tilde string =
+  string != "" && string.[0] = '~'
+
+(** Removes the ['~'] character at the beginning of the given string or fail
+    with [Invalid_arg] if the string does not start with a tilde. *)
+let strip_tilde string =
+  if not (starts_with_tilde string) then
+    invalid_arg "strip_tilde";
+  String.(sub string 1 (length string - 1))
+
+(** Extracts the tilde-prefix at the beginning of the given literal string or
+    fail with [Invalid_arg] if it does not start with a tilde. *)
+let extract_tilde_prefix_from_literal (literal : string) : word_cst =
+  if not (starts_with_tilde literal) then
+    invalid_arg "extract_tilde_prefix_from_literal";
+  match String.index_opt literal '/' with
+  | None -> [WordTildePrefix (strip_tilde literal)]
+  | Some i ->
+    let (first, rest) = ExtPervasives.string_split i literal in
+    [WordTildePrefix (strip_tilde first); WordLiteral rest]
+
+(** Merges several leading [WordLiteral] into one. *)
+let merge_leading_literals : word_cst -> word_cst =
+  let buf = Buffer.create 80 in
+  let rec extract_leading_literals = function
+    | WordLiteral lit :: rest ->
+      Buffer.add_string buf lit;
+      extract_leading_literals rest
+    | rest -> rest
+  in
+  fun word ->
+    let rest = extract_leading_literals word in
+    let lit = Buffer.contents buf in
+    Buffer.reset buf;
+    if lit = "" then word else WordLiteral lit :: rest
+
+(** Extracts the tilde-prefix at the beginning of the given word CST if there is
+    one. Otherwise, returns the word as-is. *)
+let extract_tilde_prefix_from_word_if_present (word : word_cst) : word_cst =
+  match merge_leading_literals word with
+  | WordLiteral literal :: word when starts_with_tilde literal ->
+    extract_tilde_prefix_from_literal literal @ word
+  | word -> word
+
+(** Splits the given word on each literal colon character, returning a list of
+    words. A word semantically equivalent can be re-obtained by interspersing a
+    [WordLiteral ":"] between all the words. *)
+(* REVIEW: this might make sense on its own as one of the CST helpers. *)
+let split_word_on_colon (word_to_process : word_cst) : word_cst list =
+  let rec split_word_component_on_colon
+      ~(processed_words_rev : word_cst list)
+      ~(current_word_rev : word_cst)
+      ~(word_to_process : word_cst)
+    : word_cst list
+    =
+    match word_to_process with
+    | WordLiteral literal :: word_to_process when String.contains literal ':' ->
+      (* Because [literal] contains [':'], then [subliterals] is guaranteed to
+         be of size at least 2, and therefore [List.hd], [List.cr], and
+         [List.tl] will not fail. *)
+      let subliterals = String.split_on_char ':' literal in
+      let processed_words_rev =
+        List.rev_map (fun literal -> [WordLiteral literal]) (List.cr subliterals)
+        @ [List.rev (WordLiteral (List.hd subliterals) :: current_word_rev)]
+        @ processed_words_rev
+      in
+      split_word_component_on_colon
+        ~processed_words_rev
+        ~current_word_rev:[WordLiteral (List.ft subliterals)]
+        ~word_to_process
+
+    | word_component :: word_to_process ->
+      split_word_component_on_colon
+        ~processed_words_rev
+        ~current_word_rev:(word_component :: current_word_rev)
+        ~word_to_process
+
+    | [] ->
+      List.rev ((List.rev current_word_rev) :: processed_words_rev)
+  in
+  split_word_component_on_colon
+    ~processed_words_rev:[]
+    ~current_word_rev:[]
+    ~word_to_process
+
+(** Concatenates the given list of words into one, interspersing it with literal
+    colon characters. *)
+let rec concat_words_with_colon (words : word_cst list) : word_cst =
+  match words with
+  | [] -> []
+  | [word] -> word
+  | word :: words -> word @ [WordLiteral ":"] @ concat_words_with_colon words
+
+(** Recognises tilde prefixes in a word, that is recognises eg. [WordLiteral
+    "~foo"] and replaces it by [WordTildePrefix "foo"] when in the right
+    position. *)
+let recognize (word : word_cst) =
+  match word with
+  | [WordAssignmentWord (name, Word (s, word))] ->
+    let words = split_word_on_colon word in
+    let words = List.map extract_tilde_prefix_from_word_if_present words in
+    let word = concat_words_with_colon words in
+    [WordAssignmentWord (name, Word (s, word))]
+  | _ ->
+    extract_tilde_prefix_from_word_if_present word