Improve the handling of Coq path.

This includes:
- A more robust behaviour of [refinedc init], including suggestions.
- A new [Coq_path] module to convert between strings and module paths.

frontend/coq_path.ml

+open Extra
+
+type member = string
+
+let member_of_string : string -> member = fun s ->
+  let invalid r =
+    let f = "Name \"%s\" is invalid as a Coq path member: it " ^^ r ^^ "." in
+    invalid_arg f s
+  in
+  (* Empty string is invalid. *)
+  if String.length s = 0 then invalid "is empty";
+  (* Only accept characters, digits and underscores. *)
+  let check_char c =
+    match c with
+    | 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' -> ()
+    | _ when Char.printable_ascii c        ->
+        invalid "contains '%c'" c;
+    | _                                    ->
+        invalid "uses non-printable ASCII characters" c;
+  in
+  String.iter check_char s;
+  (* Should not start with a letter. *)
+  match s.[0] with
+  | 'a'..'z' | 'A'..'Z' -> s
+  | c                   -> invalid "starts with '%c'" c
+
+let fixup_string_member : string -> string option = fun s ->
+  (* Remove non-ASCII characters. *)
+  let s = Ubase.from_utf8 ~malformed:"" ~strip:"" s in
+  (* Use underscores for invalid characters. *)
+  let fn c =
+    match c with
+    | 'a'..'z' | 'A'..'Z' | '0'..'9' -> c
+    | _                              -> '_'
+  in
+  let s = String.map fn s in
+  (* Remove leading underscores. *)
+  let s = String.trim_leading '_' s in
+  (* Check non-empty. *)
+  if String.length s = 0 then None else
+  (* Check starts with letter. *)
+  match s.[0] with
+  | 'a'..'z' | 'A'..'Z' -> Some(s)
+  | _                   -> None
+
+type path = Path of member * member list
+type t = path
+
+let path_of_members : member list -> path = fun ms ->
+  match ms with
+  | []    -> invalid_arg "Coq_path.path_of_members requires a non-empty list."
+  | m::ms -> Path(m, ms)
+
+let path_of_string : string -> path = fun s ->
+  let members = String.split_on_char '.' s in
+  try
+    match List.map member_of_string members with
+    | m :: ms -> Path(m, ms)
+    | []      -> invalid_arg "The empty module path is forbidden."
+  with Invalid_argument(msg) ->
+  invalid_arg "String \"%s\" is not a valid Coq module path.\n%s" s msg
+
+let fixup_string_path : string -> string option = fun s ->
+  let rec build ms acc =
+    match (ms, acc) with
+    | ([]     , []) -> None
+    | ([]     , _ ) -> Some(String.concat "." (List.rev acc))
+    | (m :: ms, _ ) ->
+    match fixup_string_member m with
+    | None    -> None
+    | Some(m) -> build ms (m :: acc)
+  in
+  build (String.split_on_char '.' s) []
+
+type suffix = member list
+
+let append : t -> suffix -> t = fun (Path(m, ms)) suff -> Path(m, ms @ suff)
+
+let to_string : path -> string = fun (Path(m, ms)) ->
+  String.concat "." (m :: ms)
+
+let pp : path pp = fun ff path ->
+  Format.pp_print_string ff (to_string path)

frontend/coq_path.mli

+(** Management of Coq module paths.
+
+    Coq modules path identifiers and file names are restricted to be valid Coq
+    identifiers, with further restrictions (only ASCII letters, digits and the
+    underscore symbol). This module provides types that encapsulate components
+    of Coq module paths into abstract types, to enforces that they are valid.
+
+    Useful links:
+    - https://coq.inria.fr/refman/practical-tools/coq-commands.html
+    - https://coq.inria.fr/refman/language/core/basic.html#lexical-conventions
+*)
+
+open Extra
+
+(** Coq module path member. *)
+type member
+
+(** [member_of_string s] converts string [s] into a Coq module path member. If
+    the given string does not correspond to a valid path member, the exception
+    [Invalid_argument] is raised with an explanatory error message formed of a
+    full sentence, to be displayed directly (and ideally on its own line). *)
+val member_of_string : string -> member
+
+(** [fixup_string_member s] tries to build a resonable (valid) Coq module path
+    member name from the string [s]. This is done by replacing diacritic marks
+    by corresponding ASCII sequences if applicable, and by using ['_'] instead
+    of invalid characters like ['-']. If a result string is produced, applying
+    the [member_of_string] function to it is guaranteed to succeed. *)
+val fixup_string_member : string -> string option
+
+(** Coq module path. *)
+type path
+
+(** Short synonym for [path]. *)
+type t = path
+
+(** [path_of_members ms] turns the (non-empty) list of members [ms] into a Coq
+    module path. If [ms] is empty then [Invalid_argument] is raised. *)
+val path_of_members : member list -> path
+
+(** [path_of_string s] parses string [s] into a Coq module path. In case where
+    [s] does not denote a valid module path, then exception [Invalid_argument]
+    is raised with a full, explanatory error message. *)
+val path_of_string : string -> path
+
+(** [fixup_string_path s] is similar to [fixup_string_member] but for full Coq
+    module paths. If a result string is produced, applying [path_of_string] to
+    it it guaranteed to succeed (no exception is produced). *)
+val fixup_string_path : string -> string option
+
+(** Coq path suffix. *)
+type suffix = member list
+
+(** [append path suff] extends the Coq path [path] with suffix [suff]. *)
+val append : t -> suffix -> t
+
+(** [to_string path] converts the path [path] into a string directly usable as
+    the Coq representation of the path. *)
+val to_string : path -> string
+
+(** [pp ff path] prints the string representation of [path] (as obtained using
+    [to_string]) to the [ff] formatter. *)
+val pp : path pp

frontend/coq_pp.ml

@@ -808,9 +808,9 @@ let collect_invs : func_def -> (string * loop_annot) list = fun def ->
   in
   SMap.fold fn def.func_blocks []
 
-let pp_spec : string -> import list -> inlined_code ->
+let pp_spec : Coq_path.t -> import list -> inlined_code ->
       typedef list -> string list -> Coq_ast.t pp =
-    fun import_path imports inlined typedefs ctxt ff ast ->
+    fun coq_path imports inlined typedefs ctxt ff ast ->
 
   (* Formatting utilities. *)
   let pp fmt = Format.fprintf ff fmt in
@@ -830,7 +830,7 @@ let pp_spec : string -> import list -> inlined_code ->
 
   (* Printing some header. *)
   pp "@[<v 0>From refinedc.typing Require Import typing.@;";
-  pp "From %s Require Import generated_code.@;" import_path;
+  pp "From %a Require Import generated_code.@;" Coq_path.pp coq_path;
   List.iter (pp_import ff) imports;
   pp "Set Default Proof Using \"Type\".\n";
 
@@ -1150,8 +1150,9 @@ let pp_spec : string -> import list -> inlined_code ->
   pp_inlined false (Some "final") inlined.ic_final;
   pp "@]"
 
-let pp_proof : string -> func_def -> import list -> string list -> proof_kind
-    -> Coq_ast.t pp = fun import_path def imports ctxt proof_kind ff ast ->
+let pp_proof : Coq_path.t -> func_def -> import list -> string list
+    -> proof_kind -> Coq_ast.t pp =
+    fun coq_path def imports ctxt proof_kind ff ast ->
   (* Formatting utilities. *)
   let pp fmt = Format.fprintf ff fmt in
 
@@ -1172,8 +1173,8 @@ let pp_proof : string -> func_def -> import list -> string list -> proof_kind
 
   (* Printing some header. *)
   pp "@[<v 0>From refinedc.typing Require Import typing.@;";
-  pp "From %s Require Import generated_code.@;" import_path;
-  pp "From %s Require Import generated_spec.@;" import_path;
+  pp "From %a Require Import generated_code.@;" Coq_path.pp coq_path;
+  pp "From %a Require Import generated_spec.@;" Coq_path.pp coq_path;
   List.iter (pp_import ff) imports;
   pp "Set Default Proof Using \"Type\".@;@;";
 
@@ -1417,18 +1418,18 @@ let pp_proof : string -> func_def -> import list -> string list -> proof_kind
 
 type mode =
   | Code of string * import list
-  | Spec of string * import list * inlined_code * typedef list * string list
-  | Fprf of string * func_def * import list * string list * proof_kind
+  | Spec of Coq_path.t * import list * inlined_code * typedef list * string list
+  | Fprf of Coq_path.t * func_def * import list * string list * proof_kind
 
 let write : mode -> string -> Coq_ast.t -> unit = fun mode fname ast ->
   let pp =
     match mode with
     | Code(root_dir,imports)                 ->
         pp_code root_dir imports
-    | Spec(path,imports,inlined,tydefs,ctxt) ->
-        pp_spec path imports inlined tydefs ctxt
-    | Fprf(path,def,imports,ctxt,kind)       ->
-        pp_proof path def imports ctxt kind
+    | Spec(coq_path,imports,inlined,tydefs,ctxt) ->
+        pp_spec coq_path imports inlined tydefs ctxt
+    | Fprf(coq_path,def,imports,ctxt,kind)       ->
+        pp_proof coq_path def imports ctxt kind
   in
   (* We write to a buffer. *)
   let buffer = Buffer.create 4096 in

frontend/dune

@@ -5,7 +5,7 @@
  (preprocess (per_module ((action (run pa_ocaml %{input-file})) rc_annot)))
  (flags (:standard -w -27 -I +../cerberus/frontend)) ; FIXME crazy hack.
  (foreign_stubs (language c) (names stubs))
- (libraries cmdliner str unix toml earley.core cerberus.frontend
+ (libraries cmdliner str unix toml ubase earley.core cerberus.frontend
   cerberus.backend_common cerberus.mem.concrete cerberus.util))
 
 (rule

frontend/extra.ml

@@ -15,6 +15,14 @@ module Int =
     let compare = (-)
   end
 
+module Char =
+  struct
+    include Char
+
+    let printable_ascii : char -> bool = fun c ->
+      ' ' <= c && c <= '~'
+  end
+
 module Option =
   struct
     type 'a t = 'a option
@@ -183,6 +191,15 @@ module String =
     let for_all : (char -> bool) -> string -> bool = fun p s ->
       try iter (fun c -> if not (p c) then raise Exit) s; true
       with Exit -> false
+
+    let sub_from : string -> int -> string = fun s i ->
+      sub s i (length s - i)
+
+    let trim_leading : char -> string -> string = fun c s ->
+      let len = length s in
+      let index = ref 0 in
+      while !index < len && s.[!index] = '_' do incr index done;
+      sub_from s !index
   end
 
 (** [outut_lines oc ls] prints the lines [ls] to the output channel [oc]. Note

frontend/panic.ml

@@ -26,6 +26,8 @@ let blu fmt = with_color "34" fmt
 let mag fmt = with_color "35" fmt
 let cya fmt = with_color "36" fmt
 
+let info : 'a outfmt -> 'a = Format.printf
+
 (** [wrn loc_opt fmt] outputs a waning to [stderr] using [Format] format [fmt]
     and the correponding arguments. If [loc_opt] is [Some(loc)], then location
     [loc] is shown as a prefix of the warning. Note that a newline is added to
@@ -51,4 +53,5 @@ module Simple =
   struct
     let panic : ('a,'b) koutfmt -> 'a = panic_no_pos
     let wrn   : 'a outfmt -> 'a = fun fmt -> wrn None fmt
+    let info  : 'a outfmt -> 'a = info
   end

frontend/project.ml

 open Extra
 open Panic.Simple
 
-(** Representation of a Coq module path. *)
-type coq_path = string list
-
-let coq_path_to_string : coq_path -> string = String.concat "."
-
 (** Project configuration (read from and written to a Toml file). *)
 type project_config =
-  { project_coq_root    : coq_path  (** Coq path of the project root. *)
-  ; project_theories    : coq_path list (** Extra Coq (dune) theories. *)
+  { project_coq_root    : Coq_path.t (** Coq root path for the project. *)
+  ; project_theories    : Coq_path.t list (** Extra Coq (dune) theories. *)
   ; project_cpp_include : string list (** CPP include directories. *)
   ; project_cpp_with_rc : bool (** Use global RefinedC include directory? *)
   ; project_no_build    : bool (** Do not run the Coq compilation. *) }
 
-(** [default_project_config coq_path] builds a default configuration for a new
-    RefinedC project under Coq logical directory [coq_path]. *)
-let default_project_config : coq_path -> project_config = fun coq_path ->
-  { project_coq_root    = coq_path
+(** [default_project_config coq_root] builds a default configuration for a new
+    RefinedC project under Coq logical directory [coq_root]. *)
+let default_project_config : Coq_path.t -> project_config = fun coq_root ->
+  { project_coq_root    = coq_root
   ; project_theories    = []
   ; project_cpp_include = []
   ; project_cpp_with_rc = true
@@ -85,12 +80,18 @@ let read_project_file : string -> project_config = fun file ->
   in
   TomlTypes.Table.iter handle_entry toml;
   let project_coq_root =
-    match !coq_root with
-    | None    -> panic "a [coq_root] entry is mandatory" file
-    | Some(s) -> String.split_on_char '.' s
+    let root =
+      match !coq_root with
+      | None    -> panic "a [coq_root] entry is mandatory" file
+      | Some(s) -> s
+    in
+    try Coq_path.path_of_string root with Invalid_argument(msg) ->
+      panic "Ill-formed [coq_root] entry.\n%s" msg
   in
   let project_theories =
-    List.map (String.split_on_char '.') (Option.get [] !theories)
+    try List.map Coq_path.path_of_string (Option.get [] !theories)
+    with Invalid_argument(msg) ->
+      panic "Ill-formed entry in [coq.extra_theories].\n%s" msg
   in
   let project_cpp_include = Option.get [] !cpp_include in
   let project_cpp_with_rc = Option.get true !cpp_with_rc in
@@ -103,9 +104,9 @@ let read_project_file : string -> project_config = fun file ->
     opening the file for writing. *)
 let write_project_file : string -> project_config -> unit = fun file pc ->
   let open TomlTypes in
-  let coq_root = TString(coq_path_to_string pc.project_coq_root) in
+  let coq_root = TString(Coq_path.to_string pc.project_coq_root) in
   let theories =
-    TArray(NodeString(List.map coq_path_to_string pc.project_theories))
+    TArray(NodeString(List.map Coq_path.to_string pc.project_theories))
   in
   let cpp_include = TArray(NodeString(pc.project_cpp_include)) in
   let cpp_with_rc = TBool(pc.project_cpp_with_rc) in

refinedc.opam

@@ -23,6 +23,7 @@ depends: [
   "cmdliner" {>= "1.0.4"}
   "earley" {= "3.0.0"}
   "toml" {= "5.0.0"}
+  "ubase" {= "0.04"}
 ]
 
 build: [