Commit d84c5e66 authored by Rodolphe Lepigre's avatar Rodolphe Lepigre
Browse files

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.
parent a8710147
Pipeline #53845 passed with stage
in 13 minutes and 28 seconds
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)
(** 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
......@@ -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
......
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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
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
......
......@@ -23,6 +23,7 @@ depends: [
"cmdliner" {>= "1.0.4"}
"earley" {= "3.0.0"}
"toml" {= "5.0.0"}
"ubase" {= "0.04"}
]
build: [
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment