catala/compiler/desugared/print.ml

Ignoring revisions in .git-blame-ignore-revs. Click here to bypass and see the normal blame view.

108 lines
3.8 KiB
OCaml
Raw Normal View History

(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2023 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Shared_ast
2023-04-07 17:35:09 +03:00
open Catala_utils
type exception_tree =
| Leaf of Dependency.ExceptionVertex.t
| Node of exception_tree list * Dependency.ExceptionVertex.t
open Format
2023-04-07 17:45:45 +03:00
(* Original credits for this printing code: Jean-Christophe Filiâtre *)
2023-04-07 17:35:09 +03:00
let format_exception_tree (fmt : Format.formatter) (t : exception_tree) =
2023-07-07 15:48:53 +03:00
let blue fmt n s =
Format.fprintf fmt "@{<blue>%a@}" (fun fmt -> Format.pp_print_as fmt n) s
in
let rec print_node pref prefsz (t : exception_tree) =
2023-06-07 19:10:50 +03:00
let label, sons =
match t with
| Leaf l -> l.Dependency.ExceptionVertex.label, []
| Node (sons, l) -> l.Dependency.ExceptionVertex.label, sons
2023-04-07 17:35:09 +03:00
in
Format.fprintf fmt "\"%a\"" LabelName.format label;
2023-07-07 15:48:53 +03:00
let w = String.width (fst (LabelName.get_info label)) + 2 in
2023-04-07 17:35:09 +03:00
if sons != [] then
2023-07-07 15:48:53 +03:00
let pref', prefsz' = pref ^ String.make (w + 1) ' ', prefsz + w + 2 in
2023-04-07 17:35:09 +03:00
match sons with
| [t'] ->
2023-07-07 15:48:53 +03:00
blue fmt 3 "───";
print_node (pref' ^ " ") (prefsz' + 1) t'
2023-04-07 17:35:09 +03:00
| _ ->
2023-07-07 15:48:53 +03:00
blue fmt 1 "";
print_sons pref' prefsz' "─┬──" sons
and print_sons pref prefsz start = function
2023-04-07 17:35:09 +03:00
| [] -> assert false
| [s] ->
2023-07-07 15:48:53 +03:00
blue fmt 4 " └──";
print_node (pref ^ " ") (prefsz + 1) s
2023-04-07 17:35:09 +03:00
| s :: sons ->
2023-07-07 15:48:53 +03:00
blue fmt 4 start;
print_node (pref ^ "| ") (prefsz + 2) s;
2023-06-07 19:10:50 +03:00
pp_print_cut fmt ();
2023-07-07 15:48:53 +03:00
blue fmt (prefsz + 2) (pref ^ "");
2023-06-07 19:10:50 +03:00
pp_print_cut fmt ();
2023-07-07 15:48:53 +03:00
blue fmt prefsz pref;
print_sons pref prefsz " ├──" sons
2023-04-07 17:35:09 +03:00
in
2023-06-07 19:10:50 +03:00
Format.pp_open_vbox fmt 0;
2023-07-07 15:48:53 +03:00
print_node "" 0 t;
2023-06-07 19:10:50 +03:00
Format.pp_close_box fmt ()
2023-04-07 17:35:09 +03:00
let build_exception_tree exc_graph =
let base_cases =
Dependency.ExceptionsDependencies.fold_vertex
(fun v base_cases ->
if Dependency.ExceptionsDependencies.out_degree exc_graph v = 0 then
v :: base_cases
else base_cases)
exc_graph []
in
let rec build_tree (base_cases : Dependency.ExceptionVertex.t) =
let exceptions =
Dependency.ExceptionsDependencies.pred exc_graph base_cases
in
match exceptions with
| [] -> Leaf base_cases
| _ -> Node (List.map build_tree exceptions, base_cases)
in
List.map build_tree base_cases
let print_exceptions_graph
2023-04-07 17:35:09 +03:00
(scope : ScopeName.t)
(var : Ast.ScopeDef.t)
(g : Dependency.ExceptionsDependencies.t) =
Message.result
"Printing the tree of exceptions for the definitions of variable \"%a\" of \
scope \"%a\"."
Ast.ScopeDef.format var ScopeName.format scope;
2023-04-07 17:35:09 +03:00
Dependency.ExceptionsDependencies.iter_vertex
(fun ex ->
2024-05-03 16:04:56 +03:00
Message.result "Definitions with label@ \"%a\":" LabelName.format
ex.Dependency.ExceptionVertex.label
~extra_pos:
(List.map
(fun p -> "", p)
(RuleName.Map.values ex.Dependency.ExceptionVertex.rules)))
2023-04-07 17:35:09 +03:00
g;
let tree = build_exception_tree g in
Message.result "@[<v>The exception tree structure is as follows:@,@,%a@]"
2023-04-07 17:35:09 +03:00
(Format.pp_print_list
2023-07-07 15:48:53 +03:00
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,@,")
2023-04-07 17:35:09 +03:00
(fun fmt tree -> format_exception_tree fmt tree))
tree