CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 00:15:39 +03:00
Code Issues Projects Releases Wiki Activity

Reformat

Browse Source
This commit is contained in:
Louis Gesbert 2023-09-19 18:21:14 +02:00
parent 094c5f94f6
commit 4bce4e6322
24 changed files with 954 additions and 681 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

884
build_system/clerk_driver.ml
View File

File diff suppressed because it is too large Load Diff

13
build_system/clerk_runtest.ml
View File

@ -196,7 +196,8 @@ let run_inline_tests
output_string oc test.text_before;
let cmd_out_rd, cmd_out_wr = Unix.pipe () in
let ic = Unix.in_channel_of_descr cmd_out_rd in
(* let file_dir, file = Filename.dirname file, Filename.basename file in *)
(* let file_dir, file = Filename.dirname file, Filename.basename file
in *)
let catala_exe =
(* If the exe name contains directories, make it absolute. Otherwise
don't modify it so that it can be looked up in PATH. *)
@ -206,8 +207,10 @@ let run_inline_tests
in
let cmd =
match test.params with
| cmd0 :: flags -> Array.of_list (catala_exe :: cmd0 :: catala_opts @ flags @ [file])
| [] -> Array.of_list (catala_exe :: catala_opts @ [file])
| cmd0 :: flags ->
Array.of_list
((catala_exe :: cmd0 :: catala_opts) @ flags @ [file])
| [] -> Array.of_list ((catala_exe :: catala_opts) @ [file])
in
let env =
Unix.environment ()
@ -236,7 +239,9 @@ let run_inline_tests
Unix.close cmd_out_wr;
let rec process_cmd_out () =
let s = input_line ic in
let s = Re.(replace_string (compile (str File.(file /../ ""))) ~by:"" s) in
let s =
Re.(replace_string (compile (str File.(file /../ ""))) ~by:"" s)
in
if s = "```" || String.starts_with ~prefix:"#return code" s then
output_char oc '\\';
let rec trail s i =

92
build_system/ninja_utils.ml
View File

@ -19,11 +19,8 @@ module Var = struct
type t = V of string
let make s = V s
let name (V v) = v
let v (V v) = Printf.sprintf "${%s}" v
end
module Expr = struct
@ -33,18 +30,18 @@ module Expr = struct
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_char fmt ' ')
(fun fmt s ->
Format.pp_print_string fmt
(Re.replace_string Re.(compile space) ~by:"$ " s))
Format.pp_print_string fmt
(Re.replace_string Re.(compile space) ~by:"$ " s))
end
module Binding = struct
type t = Var.t * Expr.t
let make var e = var, e
let format ~global ppf (v, e) =
if not global then Format.pp_print_string ppf " ";
Format.fprintf ppf "%s = %a"
(Var.name v)
Expr.format e;
Format.fprintf ppf "%s = %a" (Var.name v) Expr.format e;
if global then Format.pp_print_newline ppf ()
let format_list ~global ppf l =
@ -52,19 +49,29 @@ module Binding = struct
end
module Rule = struct
type t = { name : string; command : Expr.t; description : Expr.t option; vars : Binding.t list }
type t = {
name : string;
command : Expr.t;
description : Expr.t option;
vars : Binding.t list;
}
let make ?(vars=[]) name ~command ~description =
let make ?(vars = []) name ~command ~description =
{ name; command; description = Option.some description; vars }
let format fmt rule =
let bindings =
Binding.make (Var.make "command") rule.command ::
Option.(to_list (map (fun d -> Binding.make (Var.make "description") d) rule.description)) @
rule.vars
Binding.make (Var.make "command") rule.command
:: Option.(
to_list
(map
(fun d -> Binding.make (Var.make "description") d)
rule.description))
@ rule.vars
in
Format.fprintf fmt "rule %s\n%a"
rule.name (Binding.format_list ~global:false) bindings
Format.fprintf fmt "rule %s\n%a" rule.name
(Binding.format_list ~global:false)
bindings
end
module Build = struct
@ -77,7 +84,8 @@ module Build = struct
vars : Binding.t list;
}
let make ?inputs ?(implicit_in=[]) ~outputs ?implicit_out ?(vars=[]) rule =
let make ?inputs ?(implicit_in = []) ~outputs ?implicit_out ?(vars = []) rule
=
{ rule; inputs; implicit_in; outputs; implicit_out; vars }
let empty = make ~outputs:["empty"] "phony"
@ -86,52 +94,66 @@ module Build = struct
Re.Pcre.(substitute ~rex:(regexp "/") ~subst:(fun _ -> sep)) path
let format fmt t =
Format.fprintf fmt "build %a%a: %s%a%a%a%a"
Expr.format t.outputs
(Format.pp_print_option
(fun fmt i ->
Format.pp_print_string fmt " | ";
Expr.format fmt i))
t.implicit_out
t.rule
(Format.pp_print_option
(fun ppf e -> Format.pp_print_char ppf ' '; Expr.format ppf e))
Format.fprintf fmt "build %a%a: %s%a%a%a%a" Expr.format t.outputs
(Format.pp_print_option (fun fmt i ->
Format.pp_print_string fmt " | ";
Expr.format fmt i))
t.implicit_out t.rule
(Format.pp_print_option (fun ppf e ->
Format.pp_print_char ppf ' ';
Expr.format ppf e))
t.inputs
(fun ppf -> function [] -> () | e -> Format.pp_print_string ppf " | "; Expr.format ppf e)
(fun ppf -> function
| [] -> ()
| e ->
Format.pp_print_string ppf " | ";
Expr.format ppf e)
t.implicit_in
(if t.vars = [] then fun _ () -> () else Format.pp_print_newline) ()
(if t.vars = [] then fun _ () -> () else Format.pp_print_newline)
()
(Binding.format_list ~global:false)
t.vars
end
module Default = struct
type t = Expr.t
let make rules = rules
let format ppf t = Format.fprintf ppf "default %a" Expr.format t
end
type def = Comment of string | Binding of Binding.t | Rule of Rule.t | Build of Build.t | Default of Default.t
type def =
| Comment of string
| Binding of Binding.t
| Rule of Rule.t
| Build of Build.t
| Default of Default.t
let comment s = Comment s
let binding v e = Binding (Binding.make v e)
let rule ?vars name ~command ~description =
Rule (Rule.make ?vars name ~command ~description)
let build ?inputs ?implicit_in ~outputs ?implicit_out ?vars rule =
Build (Build.make ?inputs ?implicit_in ~outputs ?implicit_out ?vars rule)
let default rules =
Default (Default.make rules)
let default rules = Default (Default.make rules)
let format_def ppf def =
let () = match def with
let () =
match def with
| Comment s ->
Format.pp_print_list ~pp_sep:Format.pp_print_newline
(fun ppf s ->
if s <> "" then Format.pp_print_string ppf "# ";
Format.pp_print_string ppf s)
if s <> "" then Format.pp_print_string ppf "# ";
Format.pp_print_string ppf s)
ppf
(String.split_on_char '\n' s)
| Binding b -> Binding.format ~global:true ppf b
| Rule r -> Rule.format ppf r; Format.pp_print_newline ppf ()
| Rule r ->
Rule.format ppf r;
Format.pp_print_newline ppf ()
| Build b -> Build.format ppf b
| Default d -> Default.format ppf d
in

56
build_system/ninja_utils.mli
View File

@ -34,35 +34,37 @@
(** {1 Ninja expressions} *)
(** Ninja variable names, distinguishing binding name ("x") from references in expressions ("$x") *)
(** Ninja variable names, distinguishing binding name ("x") from references in
expressions ("$x") *)
module Var : sig
type t
val make: string -> t
val make : string -> t
val name : t -> string
(** Var base name, used when binding it *)
val name: t -> string
val v : t -> string
(** Var reference with a preceding "$", for use in expressoins *)
val v: t -> string
end
(** Helper module to build ninja expressions. *)
module Expr : sig
(** Ninja expressions are represented as raw string lists, which may contain variables or "$-escapes" *)
type t = string list
(** Ninja expressions are represented as raw string lists, which may contain
variables or "$-escapes" *)
val format : Format.formatter -> t -> unit
(** [format fmt exp] outputs in [fmt] the string representation of the ninja
expression [exp]. Spaces in individual elements are escaped (but no check is made for e.g. newlines) *)
expression [exp]. Spaces in individual elements are escaped (but no check
is made for e.g. newlines) *)
end
module Binding : sig
type t = Var.t * Expr.t
val make: Var.t -> Expr.t -> t
val format: global:bool -> Format.formatter -> t -> unit
val make : Var.t -> Expr.t -> t
val format : global:bool -> Format.formatter -> t -> unit
end
(** {1 Ninja rules} *)
@ -79,7 +81,8 @@ module Rule : sig
[description = <description>]
]} *)
val make : ?vars:Binding.t list -> string -> command:Expr.t -> description:Expr.t -> t
val make :
?vars:Binding.t list -> string -> command:Expr.t -> description:Expr.t -> t
(** [make name ~command ~description] returns the corresponding ninja
{!type:Rule.t}. *)
@ -125,18 +128,27 @@ module Build : sig
[build]. *)
end
module Default: sig
module Default : sig
type t
val make: Expr.t -> t
val format: Format.formatter -> t -> unit
val make : Expr.t -> t
val format : Format.formatter -> t -> unit
end
type def = Comment of string | Binding of Binding.t | Rule of Rule.t | Build of Build.t | Default of Default.t
type def =
| Comment of string
| Binding of Binding.t
| Rule of Rule.t
| Build of Build.t
| Default of Default.t
val comment: string -> def
val binding: Var.t -> Expr.t -> def
val rule: ?vars:Binding.t list -> string -> command:Expr.t -> description:Expr.t -> def
val build:
val comment : string -> def
val binding : Var.t -> Expr.t -> def
val rule :
?vars:Binding.t list -> string -> command:Expr.t -> description:Expr.t -> def
val build :
?inputs:Expr.t ->
?implicit_in:Expr.t ->
outputs:Expr.t ->
@ -144,10 +156,10 @@ val build:
?vars:(Var.t * Expr.t) list ->
string ->
def
val default: Expr.t -> def
val format_def: Format.formatter -> def -> unit
val default : Expr.t -> def
val format_def : Format.formatter -> def -> unit
type ninja = def Seq.t
val format: Format.formatter -> ninja -> unit
val format : Format.formatter -> ninja -> unit

7
compiler/catala_utils/cli.ml
View File

@ -194,7 +194,11 @@ module Flags = struct
let build_dir =
value
& opt (some string) None
& info ["build-dir"] ~docv:"DIR" ~doc:"Directory where build artefacts are expected to be found. This doesn't affect outptuts, but is used when looking up compiled modules."
& info ["build-dir"] ~docv:"DIR"
~doc:
"Directory where build artefacts are expected to be found. This \
doesn't affect outptuts, but is used when looking up compiled \
modules."
let disable_warnings =
value
@ -330,7 +334,6 @@ module Flags = struct
"Disables the search for counterexamples. Useful when you want a \
deterministic output from the Catala compiler, since provers can \
have some randomness in them."
end
(* Retrieve current version from dune *)

2
compiler/catala_utils/cli.mli
View File

@ -20,7 +20,7 @@ type backend_lang = En | Fr | Pl
(** The usual auto/always/never option argument *)
type when_enum = Auto | Always | Never
val when_opt: when_enum Cmdliner.Arg.conv
val when_opt : when_enum Cmdliner.Arg.conv
type message_format_enum =
| Human

10
compiler/catala_utils/dune
View File

@ -1,7 +1,15 @@
(library
(name catala_utils)
(public_name catala.catala_utils)
(libraries unix cmdliner ubase ocolor re bindlib catala.runtime_ocaml dune-build-info))
(libraries
unix
cmdliner
ubase
ocolor
re
bindlib
catala.runtime_ocaml
dune-build-info))
(documentation
(package catala)

12
compiler/catala_utils/file.ml
View File

@ -121,14 +121,14 @@ let ( / ) = Filename.concat
let dirname = Filename.dirname
let ( /../ ) a b = dirname a / b
let ( -.- ) file ext = Filename.chop_extension file ^ "." ^ ext
let equal = String.equal
let compare = String.compare
let format ppf t = Format.fprintf ppf "\"@{<cyan>%s@}\"" t
module Set = Set.Make(struct
type nonrec t = t
let compare = compare
module Set = Set.Make (struct
type nonrec t = t
let compare = compare
end)
let scan_tree f t =
@ -147,9 +147,7 @@ let scan_tree f t =
|> do_files
and do_files flist =
let dirs, files =
flist
|> List.sort (fun a b -> -compare a b)
|> List.partition is_dir
flist |> List.sort (fun a b -> -compare a b) |> List.partition is_dir
in
Seq.append
(Seq.concat (Seq.map do_dir (List.to_seq dirs)))

5
compiler/catala_utils/file.mli
View File

@ -96,7 +96,8 @@ val ( /../ ) : t -> t -> t
(** Sugar for [Filename.dirname "a" / b] *)
val ( -.- ) : t -> string -> t
(** Extension replacement: chops the given filename extension, and replaces it with the given one (which shouldn't contain a dot) *)
(** Extension replacement: chops the given filename extension, and replaces it
with the given one (which shouldn't contain a dot) *)
val equal : t -> t -> bool
(** String comparison no fancy file resolution *)
@ -108,7 +109,7 @@ val format : Format.formatter -> t -> unit
(** Formats a filename in a consistent style, with double-quotes and color (when
the output supports) *)
module Set: Set.S with type elt = t
module Set : Set.S with type elt = t
val scan_tree : (t -> 'a option) -> t -> 'a Seq.t
(** Recursively scans a directory for files. Directories or files matching ".*"

5
compiler/catala_utils/uid.ml
View File

@ -95,14 +95,15 @@ module Module = struct
let compare = Mark.compare String.compare
let format ppf m = Format.fprintf ppf "@{<blue>%s@}" (Mark.remove m)
end
include Ordering
let to_string m = Mark.remove m
let of_string m = m
let pos m = Mark.get m
module Set = Set.Make(Ordering)
module Map = Map.Make(Ordering)
module Set = Set.Make (Ordering)
module Map = Map.Make (Ordering)
end
(* TODO: should probably be turned into an uid once we implement module import
directives; that will incur an additional resolution work on all paths though

2
compiler/catala_utils/uid.mli
View File

@ -75,7 +75,7 @@ module Module : sig
val to_string : t -> string
val format : Format.formatter -> t -> unit
val pos: t -> Pos.t
val pos : t -> Pos.t
val equal : t -> t -> bool
val compare : t -> t -> int
val of_string : string * Pos.t -> t

14
compiler/desugared/from_surface.ml
View File

@ -172,8 +172,8 @@ let rec disambiguate_constructor
let modname = ModuleName.of_string modname in
match ModuleName.Map.find_opt modname ctxt.modules with
| None ->
Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found"
ModuleName.format modname
Message.raise_spanned_error (ModuleName.pos modname)
"Module \"%a\" not found" ModuleName.format modname
| Some ctxt ->
let constructor =
List.map (Mark.map (fun (_, c) -> path, c)) constructor0
@ -419,8 +419,8 @@ let rec translate_expr
let modname = ModuleName.of_string modname in
match ModuleName.Map.find_opt modname ctxt.modules with
| None ->
Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found"
ModuleName.format modname
Message.raise_spanned_error (ModuleName.pos modname)
"Module \"%a\" not found" ModuleName.format modname
| Some ctxt -> get_str ctxt path)
in
Expr.edstructaccess ~e ~field:(Mark.remove x)
@ -1470,7 +1470,8 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
{
Ast.program_lang = surface.program_lang;
Ast.program_module_name =
Option.map ModuleName.of_string surface.Surface.Ast.program_module_name;
Option.map ModuleName.of_string
surface.Surface.Ast.program_module_name;
Ast.program_ctx =
{
(* After name resolution, type definitions (structs and enums) are
@ -1526,8 +1527,7 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
(fun prgm child -> process_structure prgm child)
prgm children
| S.CodeBlock (block, _, _) -> process_code_block ctxt prgm block
| S.LawInclude _ | S.LawText _
| S.ModuleUse _ | S.ModuleDef _ -> prgm
| S.LawInclude _ | S.LawText _ | S.ModuleUse _ | S.ModuleDef _ -> prgm
in
let desugared =
List.fold_left

236
compiler/desugared/linting.ml
View File

@ -103,123 +103,129 @@ let detect_unused_struct_fields (p : program) : unit =
(* TODO: this analysis should be finer grained: a false negative is if the
field is used to define itself, for passing data around but that never gets
really used or defined. *)
if p.program_module_name <> None then () else (* Disabled on modules *)
let struct_fields_used =
Ast.fold_exprs
~f:(fun struct_fields_used e ->
let rec structs_fields_used_expr e struct_fields_used =
match Mark.remove e with
| EDStructAccess { name_opt = Some name; e = e_struct; field } ->
let field =
StructName.Map.find name
(Ident.Map.find field p.program_ctx.ctx_struct_fields)
in
StructField.Set.add field
(structs_fields_used_expr e_struct struct_fields_used)
| EStruct { name = _; fields } ->
StructField.Map.fold
(fun field e_field struct_fields_used ->
StructField.Set.add field
(structs_fields_used_expr e_field struct_fields_used))
fields struct_fields_used
| _ -> Expr.shallow_fold structs_fields_used_expr e struct_fields_used
in
structs_fields_used_expr e struct_fields_used)
~init:StructField.Set.empty p
in
let scope_out_structs_fields =
ScopeName.Map.fold
(fun _ out_struct acc ->
ScopeVar.Map.fold
(fun _ field acc -> StructField.Set.add field acc)
out_struct.out_struct_fields acc)
p.program_ctx.ctx_scopes StructField.Set.empty
in
StructName.Map.iter
(fun s_name fields ->
if StructName.path s_name <> [] then
(* Only check structs from the current module *)
()
else if
(not (StructField.Map.is_empty fields))
&& StructField.Map.for_all
(fun field _ ->
(not (StructField.Set.mem field struct_fields_used))
&& not (StructField.Set.mem field scope_out_structs_fields))
fields
then
Message.emit_spanned_warning
(snd (StructName.get_info s_name))
"The structure \"%a\" is never used; maybe it's unnecessary?"
StructName.format s_name
else
StructField.Map.iter
(fun field _ ->
if
(not (StructField.Set.mem field struct_fields_used))
&& not (StructField.Set.mem field scope_out_structs_fields)
then
Message.emit_spanned_warning
(snd (StructField.get_info field))
"The field \"%a\" of struct @{<yellow>\"%a\"@} is never used; \
maybe it's unnecessary?"
StructField.format field StructName.format s_name)
fields)
p.program_ctx.ctx_structs
if p.program_module_name <> None then ()
else
(* Disabled on modules *)
let struct_fields_used =
Ast.fold_exprs
~f:(fun struct_fields_used e ->
let rec structs_fields_used_expr e struct_fields_used =
match Mark.remove e with
| EDStructAccess { name_opt = Some name; e = e_struct; field } ->
let field =
StructName.Map.find name
(Ident.Map.find field p.program_ctx.ctx_struct_fields)
in
StructField.Set.add field
(structs_fields_used_expr e_struct struct_fields_used)
| EStruct { name = _; fields } ->
StructField.Map.fold
(fun field e_field struct_fields_used ->
StructField.Set.add field
(structs_fields_used_expr e_field struct_fields_used))
fields struct_fields_used
| _ ->
Expr.shallow_fold structs_fields_used_expr e struct_fields_used
in
structs_fields_used_expr e struct_fields_used)
~init:StructField.Set.empty p
in
let scope_out_structs_fields =
ScopeName.Map.fold
(fun _ out_struct acc ->
ScopeVar.Map.fold
(fun _ field acc -> StructField.Set.add field acc)
out_struct.out_struct_fields acc)
p.program_ctx.ctx_scopes StructField.Set.empty
in
StructName.Map.iter
(fun s_name fields ->
if StructName.path s_name <> [] then
(* Only check structs from the current module *)
()
else if
(not (StructField.Map.is_empty fields))
&& StructField.Map.for_all
(fun field _ ->
(not (StructField.Set.mem field struct_fields_used))
&& not (StructField.Set.mem field scope_out_structs_fields))
fields
then
Message.emit_spanned_warning
(snd (StructName.get_info s_name))
"The structure \"%a\" is never used; maybe it's unnecessary?"
StructName.format s_name
else
StructField.Map.iter
(fun field _ ->
if
(not (StructField.Set.mem field struct_fields_used))
&& not (StructField.Set.mem field scope_out_structs_fields)
then
Message.emit_spanned_warning
(snd (StructField.get_info field))
"The field \"%a\" of struct @{<yellow>\"%a\"@} is never \
used; maybe it's unnecessary?"
StructField.format field StructName.format s_name)
fields)
p.program_ctx.ctx_structs
let detect_unused_enum_constructors (p : program) : unit =
if p.program_module_name <> None then () else (* Disabled on modules *)
let enum_constructors_used =
Ast.fold_exprs
~f:(fun enum_constructors_used e ->
let rec enum_constructors_used_expr e enum_constructors_used =
match Mark.remove e with
| EInj { name = _; e = e_enum; cons } ->
EnumConstructor.Set.add cons
(enum_constructors_used_expr e_enum enum_constructors_used)
| EMatch { e = e_match; name = _; cases } ->
let enum_constructors_used =
enum_constructors_used_expr e_match enum_constructors_used
in
EnumConstructor.Map.fold
(fun cons e_cons enum_constructors_used ->
EnumConstructor.Set.add cons
(enum_constructors_used_expr e_cons enum_constructors_used))
cases enum_constructors_used
| _ ->
Expr.shallow_fold enum_constructors_used_expr e
enum_constructors_used
in
enum_constructors_used_expr e enum_constructors_used)
~init:EnumConstructor.Set.empty p
in
EnumName.Map.iter
(fun e_name constructors ->
if EnumName.path e_name <> [] then
(* Only check enums from the current module *)
()
else if
EnumConstructor.Map.for_all
(fun cons _ ->
not (EnumConstructor.Set.mem cons enum_constructors_used))
constructors
then
Message.emit_spanned_warning
(snd (EnumName.get_info e_name))
"The enumeration \"%a\" is never used; maybe it's unnecessary?"
EnumName.format e_name
else
EnumConstructor.Map.iter
(fun constructor _ ->
if not (EnumConstructor.Set.mem constructor enum_constructors_used)
then
Message.emit_spanned_warning
(snd (EnumConstructor.get_info constructor))
"The constructor \"%a\" of enumeration \"%a\" is never used; \
maybe it's unnecessary?"
EnumConstructor.format constructor EnumName.format e_name)
constructors)
p.program_ctx.ctx_enums
if p.program_module_name <> None then ()
else
(* Disabled on modules *)
let enum_constructors_used =
Ast.fold_exprs
~f:(fun enum_constructors_used e ->
let rec enum_constructors_used_expr e enum_constructors_used =
match Mark.remove e with
| EInj { name = _; e = e_enum; cons } ->
EnumConstructor.Set.add cons
(enum_constructors_used_expr e_enum enum_constructors_used)
| EMatch { e = e_match; name = _; cases } ->
let enum_constructors_used =
enum_constructors_used_expr e_match enum_constructors_used
in
EnumConstructor.Map.fold
(fun cons e_cons enum_constructors_used ->
EnumConstructor.Set.add cons
(enum_constructors_used_expr e_cons enum_constructors_used))
cases enum_constructors_used
| _ ->
Expr.shallow_fold enum_constructors_used_expr e
enum_constructors_used
in
enum_constructors_used_expr e enum_constructors_used)
~init:EnumConstructor.Set.empty p
in
EnumName.Map.iter
(fun e_name constructors ->
if EnumName.path e_name <> [] then
(* Only check enums from the current module *)
()
else if
EnumConstructor.Map.for_all
(fun cons _ ->
not (EnumConstructor.Set.mem cons enum_constructors_used))
constructors
then
Message.emit_spanned_warning
(snd (EnumName.get_info e_name))
"The enumeration \"%a\" is never used; maybe it's unnecessary?"
EnumName.format e_name
else
EnumConstructor.Map.iter
(fun constructor _ ->
if
not (EnumConstructor.Set.mem constructor enum_constructors_used)
then
Message.emit_spanned_warning
(snd (EnumConstructor.get_info constructor))
"The constructor \"%a\" of enumeration \"%a\" is never used; \
maybe it's unnecessary?"
EnumConstructor.format constructor EnumName.format e_name)
constructors)
p.program_ctx.ctx_enums
(* Reachability in a graph can be implemented as a simple fixpoint analysis with
backwards propagation. *)

4
compiler/desugared/name_resolution.ml
View File

@ -258,8 +258,8 @@ let rec module_ctx ctxt path =
let modname = ModuleName.of_string modname in
match ModuleName.Map.find_opt modname ctxt.modules with
| None ->
Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found"
ModuleName.format modname
Message.raise_spanned_error (ModuleName.pos modname)
"Module \"%a\" not found" ModuleName.format modname
| Some ctxt -> module_ctx ctxt path)
(** {1 Declarations pass} *)

53
compiler/driver.ml
View File

@ -46,12 +46,9 @@ let load_module_interfaces options program files =
let module MS = ModuleName.Set in
let to_set intf_list =
MS.of_list
(List.map (fun (mname, _) -> ModuleName.of_string mname)
intf_list)
in
let used_modules =
to_set program.Surface.Ast.program_modules
(List.map (fun (mname, _) -> ModuleName.of_string mname) intf_list)
in
let used_modules = to_set program.Surface.Ast.program_modules in
let load_file f =
let lang = get_lang options (FileName f) in
let (mname, intf), using =
@ -62,38 +59,44 @@ let load_module_interfaces options program files =
let module_interfaces = List.map load_file files in
let rec check (required, acc) interfaces =
let required, acc, remaining =
List.fold_left (fun (required, acc, skipped) ((modname, intf), using as modl) ->
List.fold_left
(fun (required, acc, skipped) (((modname, intf), using) as modl) ->
if MS.mem modname required then
let required =
List.fold_left (fun req m -> MS.add (ModuleName.of_string m) req) required using
List.fold_left
(fun req m -> MS.add (ModuleName.of_string m) req)
required using
in
required, (((modname :> string Mark.pos), intf) :: acc), skipped
else
required, acc, (modl :: skipped))
(required, acc, [])
interfaces
required, ((modname :> string Mark.pos), intf) :: acc, skipped
else required, acc, modl :: skipped)
(required, acc, []) interfaces
in
if List.length remaining < List.length interfaces then
(* Loop until fixpoint *)
check (required, acc) remaining
else
required, acc, remaining
else required, acc, remaining
in
let required, loaded, unused = check (used_modules, []) module_interfaces in
let missing =
MS.diff required (MS.of_list (List.map (fun (m,_) -> ModuleName.of_string m) loaded)) in
if not (MS.is_empty missing) || unused <> [] then
MS.diff required
(MS.of_list (List.map (fun (m, _) -> ModuleName.of_string m) loaded))
in
if (not (MS.is_empty missing)) || unused <> [] then
Message.raise_multispanned_error
(List.map (fun m ->
Some (Format.asprintf "Required module not found: %a"
(List.map
(fun m ->
( Some
(Format.asprintf "Required module not found: %a"
ModuleName.format m),
ModuleName.pos m ))
(ModuleName.Set.elements missing)
@ List.map
(fun ((m, _), _) ->
( Some
(Format.asprintf "No use was found for this module: %a"
ModuleName.format m),
ModuleName.pos m)
(ModuleName.Set.elements missing) @
List.map (fun ((m, _), _) ->
Some (Format.asprintf "No use was found for this module: %a"
ModuleName.format m),
ModuleName.pos m)
unused)
ModuleName.pos m ))
unused)
"Modules used from the program don't match the command-line";
loaded

7
compiler/lcalc/closure_conversion.ml
View File

@ -356,9 +356,12 @@ let transform_closures_program (p : 'm program) : 'm program Bindlib.box =
in
Bindlib.box_apply
(fun new_code_items ->
{ code_items = new_code_items; decl_ctx = new_decl_ctx;
{
code_items = new_code_items;
decl_ctx = new_decl_ctx;
module_name = p.module_name;
lang = p.lang; })
lang = p.lang;
})
new_code_items
(** {1 Hoisting closures}*)

8
compiler/lcalc/to_ocaml.ml
View File

@ -245,8 +245,9 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit =
| ConflictError ->
let pos = Mark.get exc in
Format.fprintf fmt
"(ConflictError@ @[<hov 2>{filename = \"%s\";@\nstart_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@])"
"(ConflictError@ @[<hov 2>{filename = \"%s\";@\n\
start_line=%d;@ start_column=%d;@ end_line=%d; end_column=%d;@ \
law_headings=%a}@])"
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos)
@ -647,7 +648,8 @@ let format_module_registration
Format.pp_print_string fmt "let () =";
Format.pp_print_space fmt ();
Format.pp_open_hvbox fmt 2;
Format.fprintf fmt "Runtime_ocaml.Runtime.register_module \"%a\"" ModuleName.format modname;
Format.fprintf fmt "Runtime_ocaml.Runtime.register_module \"%a\""
ModuleName.format modname;
Format.pp_print_space fmt ();
Format.pp_open_vbox fmt 2;
Format.pp_print_string fmt "[ ";

7
compiler/plugins/modules.ml
View File

@ -51,8 +51,7 @@ let gen_ocaml options link_modules optimize check_invariants main =
in
with_output
@@ fun ppf ->
Lcalc.To_ocaml.format_program ppf ?exec_scope prg
type_ordering;
Lcalc.To_ocaml.format_program ppf ?exec_scope prg type_ordering;
Option.get filename
let run_process cmd args =
@ -130,9 +129,7 @@ let compile options link_modules optimize check_invariants =
| _ -> Message.raise_error "Input must be a file name for this command"
in
let basename = String.uncapitalize_ascii modname in
let ml_file =
gen_ocaml options link_modules optimize check_invariants None
in
let ml_file = gen_ocaml options link_modules optimize check_invariants None in
let flags = ["-I"; Lazy.force runtime_dir] in
let shared_out = File.((ml_file /../ basename) ^ ".cmxs") in
Message.emit_debug "Compiling OCaml shared object file @{<bold>%s@}..."

31
compiler/shared_ast/interpreter.ml
View File

@ -949,19 +949,20 @@ let load_runtime_modules prg =
prg.decl_ctx.ctx_modules;
List.iter
(fun m ->
let srcfile = Pos.get_file (ModuleName.pos m) in
let obj_file =
File.(srcfile /../ ModuleName.to_string m ^ ".cmo")
|> Dynlink.adapt_filename
in
let obj_file = match Cli.globals.build_dir with
| None -> obj_file
| Some d -> File.(d / obj_file)
in
try Dynlink.loadfile obj_file
with Dynlink.Error dl_err ->
Message.raise_error
"Could not load module %a, has it been suitably compiled?@;\
<1 2>@[<hov>%a@]" ModuleName.format m Format.pp_print_text
(Dynlink.error_message dl_err))
let srcfile = Pos.get_file (ModuleName.pos m) in
let obj_file =
File.((srcfile /../ ModuleName.to_string m) ^ ".cmo")
|> Dynlink.adapt_filename
in
let obj_file =
match Cli.globals.build_dir with
| None -> obj_file
| Some d -> File.(d / obj_file)
in
try Dynlink.loadfile obj_file
with Dynlink.Error dl_err ->
Message.raise_error
"Could not load module %a, has it been suitably compiled?@;\
<1 2>@[<hov>%a@]" ModuleName.format m Format.pp_print_text
(Dynlink.error_message dl_err))
modules

6
compiler/shared_ast/interpreter.mli
View File

@ -73,5 +73,7 @@ val interpret_program_lcalc :
the computed values for the scope variables of the executed scope. *)
val load_runtime_modules : _ program -> unit
(** Dynlink the runtime modules required by the given program, in order to make them callable by the
interpreter. If Cli.globals.build_dir is specified, the runtime module names (as obtained by looking up the positions in the program's module bindings) are assumed to be relative and looked up there. *)
(** Dynlink the runtime modules required by the given program, in order to make
them callable by the interpreter. If Cli.globals.build_dir is specified, the
runtime module names (as obtained by looking up the positions in the
program's module bindings) are assumed to be relative and looked up there. *)

3
compiler/surface/ast.ml
View File

@ -320,8 +320,7 @@ and program = {
program_module_name : uident Mark.pos option;
program_items : law_structure list;
program_source_files : (string[@opaque]) list;
program_modules : interface list;
(** Modules being used by the program *)
program_modules : interface list; (** Modules being used by the program *)
program_lang : Cli.backend_lang; [@opaque]
}

4
compiler/surface/lexer_common.mli
View File

@ -74,5 +74,7 @@ module type LocalisedLexer = sig
depending of the current {!val:Surface.Lexer_common.context}. *)
val lex_line : Sedlexing.lexbuf -> (string * line_token) option
(** Low-level lexer intended for dependency extraction. The whole line (including ["\n"] is always returned together with the token. [None] for EOF. *)
(** Low-level lexer intended for dependency extraction. The whole line
(including ["\n"] is always returned together with the token. [None] for
EOF. *)
end

164
compiler/surface/parser_driver.ml
View File

@ -206,7 +206,8 @@ let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function
(** Lightweight lexer for dependency *)
let lines (file : File.t) (language : Cli.backend_lang) =
let lex_line = match language with
let lex_line =
match language with
| En -> Lexer_en.lex_line
| Fr -> Lexer_fr.lex_line
| Pl -> Lexer_pl.lex_line
@ -218,7 +219,9 @@ let lines (file : File.t) (language : Cli.backend_lang) =
let rec aux () =
match lex_line lexbuf with
| Some line -> Seq.Cons (line, aux)
| None -> close_in input; Seq.Nil
| None ->
close_in input;
Seq.Nil
in
aux
with exc ->
@ -267,58 +270,73 @@ and expand_includes
let rprg =
List.fold_left
(fun acc command ->
match command with
| Ast.ModuleDef id ->
(match acc.Ast.program_module_name with
| None -> { acc with Ast.program_module_name = Some id }
| Some id2 ->
Message.raise_multispanned_error
[None, Mark.get id; None, Mark.get id2]
"Multiple definitions of the module name")
| Ast.ModuleUse (id, _alias) ->
{ acc with
Ast.program_modules = (id, []) :: acc.Ast.program_modules;
Ast.program_items = command :: acc.Ast.program_items }
| Ast.LawInclude (Ast.CatalaFile inc_file) ->
let source_dir = Filename.dirname source_file in
let sub_source = File.(source_dir / Mark.remove inc_file) in
let includ_program = parse_source_file (FileName sub_source) language in
let () =
includ_program.Ast.program_module_name |> Option.iter @@ fun id ->
Message.raise_multispanned_error
[ Some "File include", Mark.get inc_file;
Some "Module declaration", Mark.get id ]
"A file that declares a module cannot be used through the raw '@{<yellow>> Include@}' directive. You should use it as a module with '@{<yellow>> Use %a@}' instead." Uid.Module.format (Uid.Module.of_string id)
in
{
Ast.program_module_name = None;
Ast.program_source_files =
List.rev_append includ_program.program_source_files acc.Ast.program_source_files;
Ast.program_items =
List.rev_append includ_program.program_items acc.Ast.program_items;
Ast.program_modules =
List.rev_append includ_program.program_modules acc.Ast.program_modules;
Ast.program_lang = language;
}
| Ast.LawHeading (heading, commands') ->
let {
Ast.program_module_name;
Ast.program_items = commands';
Ast.program_source_files = new_sources;
Ast.program_modules = new_modules;
Ast.program_lang = _;
} =
expand_includes source_file commands' language
in
{
Ast.program_module_name;
Ast.program_source_files = List.rev_append new_sources acc.Ast.program_source_files;
Ast.program_items =
Ast.LawHeading (heading, commands') :: acc.Ast.program_items;
Ast.program_modules = List.rev_append new_modules acc.Ast.program_modules;
Ast.program_lang = language;
}
| i -> { acc with Ast.program_items = i :: acc.Ast.program_items })
match command with
| Ast.ModuleDef id -> (
match acc.Ast.program_module_name with
| None -> { acc with Ast.program_module_name = Some id }
| Some id2 ->
Message.raise_multispanned_error
[None, Mark.get id; None, Mark.get id2]
"Multiple definitions of the module name")
| Ast.ModuleUse (id, _alias) ->
{
acc with
Ast.program_modules = (id, []) :: acc.Ast.program_modules;
Ast.program_items = command :: acc.Ast.program_items;
}
| Ast.LawInclude (Ast.CatalaFile inc_file) ->
let source_dir = Filename.dirname source_file in
let sub_source = File.(source_dir / Mark.remove inc_file) in
let includ_program =
parse_source_file (FileName sub_source) language
in
let () =
includ_program.Ast.program_module_name
|> Option.iter
@@ fun id ->
Message.raise_multispanned_error
[
Some "File include", Mark.get inc_file;
Some "Module declaration", Mark.get id;
]
"A file that declares a module cannot be used through the raw \
'@{<yellow>> Include@}' directive. You should use it as a \
module with '@{<yellow>> Use %a@}' instead."
Uid.Module.format (Uid.Module.of_string id)
in
{
Ast.program_module_name = None;
Ast.program_source_files =
List.rev_append includ_program.program_source_files
acc.Ast.program_source_files;
Ast.program_items =
List.rev_append includ_program.program_items acc.Ast.program_items;
Ast.program_modules =
List.rev_append includ_program.program_modules
acc.Ast.program_modules;
Ast.program_lang = language;
}
| Ast.LawHeading (heading, commands') ->
let {
Ast.program_module_name;
Ast.program_items = commands';
Ast.program_source_files = new_sources;
Ast.program_modules = new_modules;
Ast.program_lang = _;
} =
expand_includes source_file commands' language
in
{
Ast.program_module_name;
Ast.program_source_files =
List.rev_append new_sources acc.Ast.program_source_files;
Ast.program_items =
Ast.LawHeading (heading, commands') :: acc.Ast.program_items;
Ast.program_modules =
List.rev_append new_modules acc.Ast.program_modules;
Ast.program_lang = language;
}
| i -> { acc with Ast.program_items = i :: acc.Ast.program_items })
{
Ast.program_module_name = None;
Ast.program_source_files = [];
@ -336,25 +354,23 @@ and expand_includes
Ast.program_modules = List.rev rprg.Ast.program_modules;
}
(** {2 Handling interfaces} *)
let get_interface program =
let rec filter (req, acc) = function
| Ast.LawInclude _ | Ast.LawText _ | Ast.ModuleDef _ ->
req, acc
| Ast.LawInclude _ | Ast.LawText _ | Ast.ModuleDef _ -> req, acc
| Ast.LawHeading (_, str) -> List.fold_left filter (req, acc) str
| Ast.ModuleUse (m, _) -> (m::req), acc
| Ast.ModuleUse (m, _) -> m :: req, acc
| Ast.CodeBlock (code, _, true) ->
req,
List.fold_left
(fun acc -> function
| Ast.ScopeUse _, _ -> acc
| ((Ast.ScopeDecl _ | StructDecl _ | EnumDecl _), _) as e ->
e :: acc
| Ast.Topdef def, m ->
(Ast.Topdef { def with topdef_expr = None }, m) :: acc)
acc code
( req,
List.fold_left
(fun acc -> function
| Ast.ScopeUse _, _ -> acc
| ((Ast.ScopeDecl _ | StructDecl _ | EnumDecl _), _) as e ->
e :: acc
| Ast.Topdef def, m ->
(Ast.Topdef { def with topdef_expr = None }, m) :: acc)
acc code )
| Ast.CodeBlock (_, _, false) ->
(* Non-metadata blocks are ignored *)
req, acc
@ -370,15 +386,15 @@ let load_interface source_file language =
| Some mname -> mname
| None ->
Message.raise_error
"%s doesn't define a module name. It should contain a '@{<cyan>> Module \
%s@}' directive."
"%s doesn't define a module name. It should contain a '@{<cyan>> \
Module %s@}' directive."
(match source_file with
| FileName s -> "File " ^ s
| Contents _ -> "Source input")
| FileName s -> "File " ^ s
| Contents _ -> "Source input")
(match source_file with
| FileName s ->
String.capitalize_ascii Filename.(basename (remove_extension s))
| Contents _ -> "Module_name")
| FileName s ->
String.capitalize_ascii Filename.(basename (remove_extension s))
| Contents _ -> "Module_name")
in
let used_modules, intf = get_interface program in
(modname, intf), used_modules

10
compiler/surface/parser_driver.mli
View File

@ -19,13 +19,17 @@
open Catala_utils
val lines : File.t -> Cli.backend_lang -> (string * Lexer_common.line_token) Seq.t
val lines :
File.t -> Cli.backend_lang -> (string * Lexer_common.line_token) Seq.t
(** Raw file parser that doesn't interpret any includes and returns the flat law
structure as is *)
val load_interface : Cli.input_file -> Cli.backend_lang -> Ast.interface * string Mark.pos list
val load_interface :
Cli.input_file -> Cli.backend_lang -> Ast.interface * string Mark.pos list
(** Reads only declarations in metadata in the supplied input file, and only
keeps type information ; returns the modules used as well *)
val parse_top_level_file : Cli.input_file -> Cli.backend_lang -> Ast.program
(** Parses a catala file (handling file includes) and returns a program. Interfaces of the used modules are returned empty, use [load_interface] to fill them. *)
(** Parses a catala file (handling file includes) and returns a program.
Interfaces of the used modules are returned empty, use [load_interface] to
fill them. *)